From 8d8c0db442aaa2be048406b47083ed704612a5e7 Mon Sep 17 00:00:00 2001 From: Ulrik Strid Date: Tue, 8 Nov 2022 17:21:53 +0100 Subject: [PATCH 01/21] Initial stuff --- flake.nix | 19 +++++++++++- nix/deku-p/default.nix | 1 + nix/overlay.nix | 66 +++++++++++++++++++++++++++++++++++++----- 3 files changed, 78 insertions(+), 8 deletions(-) diff --git a/flake.nix b/flake.nix index 8bc6cef2da..76b0fdf813 100644 --- a/flake.nix +++ b/flake.nix @@ -58,8 +58,25 @@ pkgs = nixpkgs.makePkgs { inherit system; extraOverlays = [ - tezos.overlays.default + (final: prev: { + ocaml-ng = + prev.ocaml-ng + // { + ocamlPackages_5_00 = + prev.ocaml-ng.ocamlPackages_5_00.overrideScope' + (oself: osuper: { + ringo = osuper.ringo.overrideAttrs (_: { + src = builtins.fetchurl { + url = + https://gitlab.com/nomadic-labs/ringo/-/archive/5514a34ccafdea498e4b018fb141217c1bf43da9/ringo-5514a34ccafdea498e4b018fb141217c1bf43da9.tar.gz; + sha256 = "1qadbvmqirn1scc4r4lwzqs4rrwmp1vnzhczy9pipfnf9bb9c0j7"; + }; + }); + }); + }; + }) (import ./nix/overlay.nix) + tezos.overlays.default (final: prev: { ocamlPackages = prev.ocaml-ng.ocamlPackages_5_00; }) diff --git a/nix/deku-p/default.nix b/nix/deku-p/default.nix index 976feef1af..080bf2709e 100644 --- a/nix/deku-p/default.nix +++ b/nix/deku-p/default.nix @@ -46,6 +46,7 @@ packages = { default = deku; inherit deku deku-static docker; + ligo-utils = pkgs.ocamlPackages.proto-alpha-utils; }; apps = { node = { diff --git a/nix/overlay.nix b/nix/overlay.nix index 110c48b541..e3078770c6 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -44,13 +44,7 @@ with super; { fetchSubmodules = true; }; }); - ringo = super.ringo.overrideAttrs (_: { - src = builtins.fetchurl { - url = - https://gitlab.com/nomadic-labs/ringo/-/archive/5514a34ccafdea498e4b018fb141217c1bf43da9/ringo-5514a34ccafdea498e4b018fb141217c1bf43da9.tar.gz; - sha256 = "1qadbvmqirn1scc4r4lwzqs4rrwmp1vnzhczy9pipfnf9bb9c0j7"; - }; - }); + tezos-stdlib = super.tezos-stdlib.overrideAttrs (_: { postPatch = '' substituteInPlace "src/lib_stdlib/hash_queue.mli" --replace \ @@ -95,6 +89,64 @@ with super; { "(name wasm) (public_name wasm)" ''; }; + + ligo-simple-utils = oself.buildDunePackage rec { + pname = "simple-utils"; + inherit (self.ligo) version; + src = "${self.ligo.src}/vendors/ligo-utils/simple-utils"; + + propagatedBuildInputs = with oself; [ + base + core + yojson + ppx_deriving + ppx_deriving_yojson + ppx_hash + ]; + }; + + proto-alpha-utils = oself.buildDunePackage rec { + pname = "proto-alpha-utils"; + inherit (self.ligo) version; + src = "${self.ligo.src}/vendors/ligo-utils/proto-alpha-utils"; + + propagatedBuildInputs = with oself; [ + base + bigstring + calendar + cohttp-lwt-unix + cstruct + ezjsonm + hex + hidapi + ipaddr + macaddr + irmin + js_of_ocaml + lwt + lwt_log + mtime + ocplib-endian + ocp-ocamlres + re + rresult + stdio + uri + uutf + zarith + ocplib-json-typed + ocplib-json-typed-bson + tezos-crypto + tezos-error-monad + tezos-stdlib-unix + tezos-protocol-environment + tezos-011-PtHangz2.protocol + tezos-011-PtHangz2.client + # tezos-memory-proto-alpha + ligo-simple-utils + # tezos-utils + ]; + }; }); }); } From 26b3417c995563388e694d6bd30839dc479af6e8 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 8 Nov 2022 15:38:18 -0300 Subject: [PATCH 02/21] Fix build for ringo package --- flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/flake.nix b/flake.nix index 76b0fdf813..9b2af902b6 100644 --- a/flake.nix +++ b/flake.nix @@ -58,6 +58,7 @@ pkgs = nixpkgs.makePkgs { inherit system; extraOverlays = [ + tezos.overlays.default (final: prev: { ocaml-ng = prev.ocaml-ng @@ -76,7 +77,6 @@ }; }) (import ./nix/overlay.nix) - tezos.overlays.default (final: prev: { ocamlPackages = prev.ocaml-ng.ocamlPackages_5_00; }) From c979072f14bed86d752809fb9668f647a6363e18 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Thu, 27 Oct 2022 12:38:27 -0300 Subject: [PATCH 03/21] new tunac iteration --- deku-c/tunac/bin/dune | 18 - deku-c/tunac/bin/tunacc_test.ml | 24 - deku-c/tunac/bin/tunacc_test_operation.ml | 81 --- deku-c/tunac/lib/Interface.mli | 59 -- deku-c/tunac/lib/compiler.ml | 484 ---------------- deku-c/tunac/lib/dune | 13 +- deku-c/tunac/lib/helpers.ml | 73 +-- deku-c/tunac/lib/helpers.mli | 82 --- deku-c/tunac/lib/iR.ml | 55 ++ deku-c/tunac/lib/iR_of_michelson.ml | 413 +++++++++++++ ...imitives.ml => michelson_v1_primitives.ml} | 547 +++++++++++------- deku-c/tunac/lib/output.ml | 21 - deku-c/tunac/lib/output.mli | 6 - deku-c/tunac/lib/parser.ml | 24 - deku-c/tunac/lib/parser.mli | 8 - deku-c/tunac/lib/path.ml | 37 -- deku-c/tunac/lib/template.ml | 259 --------- deku-c/tunac/lib/template.mli | 2 - deku-c/tunac/lib/tunac.ml | 20 + deku-c/tunac/lib/tunac.mli | 10 + deku-c/tunac/lib/values.ml | 1 - deku-c/tunac/lib/values.mli | 3 - deku-c/tunac/lib/wasm_of_ir.ml | 140 +++++ deku-c/tunac/tests/DexFA2.tz | 381 ------------ deku-c/tunac/tests/compile.ml | 26 + deku-c/tunac/tests/compile_value.ml | 290 ---------- deku-c/tunac/tests/decookie.t | 1 - deku-c/tunac/tests/decookie.tz | 37 -- deku-c/tunac/tests/dune | 15 +- deku-c/tunac/tests/fa12.t | 2 - deku-c/tunac/tests/fa12.tz | 235 -------- deku-c/tunac/tests/fa2.t | 4 - deku-c/tunac/tests/fa2_no_metadata.tz | 112 ---- deku-c/tunac/tests/fa2_only_transfer.t | 3 - deku-c/tunac/tests/increment.t | 2 - deku-c/tunac/tests/increment.tz | 1 - deku-c/tunac/tests/increment_originate.t | 10 - deku-c/tunac/tests/nft_auction.t | 5 - deku-c/tunac/tests/nft_auction.tz | 159 ----- deku-c/tunac/tests/nft_wallet.t | 2 - deku-c/tunac/tests/nft_wallet.tz | 159 ----- deku-c/tunac/tests/tests.js | 308 ++++++++++ deku-c/tunac/tests/tunac.t | 0 flake.lock | 14 +- nix/deku-c/tuna.nix | 21 +- 45 files changed, 1332 insertions(+), 2835 deletions(-) delete mode 100644 deku-c/tunac/bin/dune delete mode 100644 deku-c/tunac/bin/tunacc_test.ml delete mode 100644 deku-c/tunac/bin/tunacc_test_operation.ml delete mode 100644 deku-c/tunac/lib/Interface.mli delete mode 100644 deku-c/tunac/lib/compiler.ml delete mode 100644 deku-c/tunac/lib/helpers.mli create mode 100644 deku-c/tunac/lib/iR.ml create mode 100644 deku-c/tunac/lib/iR_of_michelson.ml rename deku-c/tunac/lib/{michelson_primitives.ml => michelson_v1_primitives.ml} (65%) delete mode 100644 deku-c/tunac/lib/output.ml delete mode 100644 deku-c/tunac/lib/output.mli delete mode 100644 deku-c/tunac/lib/parser.ml delete mode 100644 deku-c/tunac/lib/parser.mli delete mode 100644 deku-c/tunac/lib/path.ml delete mode 100644 deku-c/tunac/lib/template.ml delete mode 100644 deku-c/tunac/lib/template.mli create mode 100644 deku-c/tunac/lib/tunac.ml create mode 100644 deku-c/tunac/lib/tunac.mli delete mode 100644 deku-c/tunac/lib/values.ml delete mode 100644 deku-c/tunac/lib/values.mli create mode 100644 deku-c/tunac/lib/wasm_of_ir.ml delete mode 100644 deku-c/tunac/tests/DexFA2.tz create mode 100644 deku-c/tunac/tests/compile.ml delete mode 100644 deku-c/tunac/tests/compile_value.ml delete mode 100644 deku-c/tunac/tests/decookie.t delete mode 100644 deku-c/tunac/tests/decookie.tz delete mode 100644 deku-c/tunac/tests/fa12.t delete mode 100644 deku-c/tunac/tests/fa12.tz delete mode 100644 deku-c/tunac/tests/fa2.t delete mode 100644 deku-c/tunac/tests/fa2_no_metadata.tz delete mode 100644 deku-c/tunac/tests/fa2_only_transfer.t delete mode 100644 deku-c/tunac/tests/increment.t delete mode 100644 deku-c/tunac/tests/increment.tz delete mode 100644 deku-c/tunac/tests/increment_originate.t delete mode 100644 deku-c/tunac/tests/nft_auction.t delete mode 100644 deku-c/tunac/tests/nft_auction.tz delete mode 100644 deku-c/tunac/tests/nft_wallet.t delete mode 100644 deku-c/tunac/tests/nft_wallet.tz create mode 100644 deku-c/tunac/tests/tests.js delete mode 100644 deku-c/tunac/tests/tunac.t diff --git a/deku-c/tunac/bin/dune b/deku-c/tunac/bin/dune deleted file mode 100644 index e017bc03b4..0000000000 --- a/deku-c/tunac/bin/dune +++ /dev/null @@ -1,18 +0,0 @@ -(executable - (name tunacc_test) - (libraries tunac yojson core core_unix core_unix.command_unix wasm) - (modules tunacc_test) - (preprocess - (pps ppx_deriving.ord ppx_deriving.show ppx_deriving.eq ppx_yojson_conv))) - -(executable - (name tunacc_test_operation) - (libraries tunac yojson core core_unix core_unix.command_unix wasm) - (modules tunacc_test_operation) - (preprocess - (pps - ppx_deriving.ord - ppx_deriving.show - ppx_deriving.eq - ppx_yojson_conv - ppx_jane))) diff --git a/deku-c/tunac/bin/tunacc_test.ml b/deku-c/tunac/bin/tunacc_test.ml deleted file mode 100644 index b535aad0b9..0000000000 --- a/deku-c/tunac/bin/tunacc_test.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* let read_file name = - let f = open_in name in - let buf = Bytes.create 100000 in - let size = input f buf 0 100000 in - Bytes.to_string @@ Bytes.sub buf 0 size - - let compile_contract filename = - let wat, constants, entrypoints = - filename |> read_file |> Tunac.Compiler.compile |> Result.get_ok - in - let out = Tunac.Output.make wat constants |> Result.get_ok in - - print_endline @@ Yojson.Safe.pretty_to_string @@ Tunac.Output.yojson_of_t out - - let compile_value code = - let _, value = code |> Tunac.Compiler.compile_value |> Result.get_ok in - let out = value |> Tunac.Values.yojson_of_t |> Yojson.Safe.pretty_to_string in - print_endline out - - let () = - match Sys.argv.(1) with - | "contract" -> compile_contract Sys.argv.(2) - | "value" -> compile_value Sys.argv.(2) - | _ -> failwith "Invalid command" *) diff --git a/deku-c/tunac/bin/tunacc_test_operation.ml b/deku-c/tunac/bin/tunacc_test_operation.ml deleted file mode 100644 index 324c83075b..0000000000 --- a/deku-c/tunac/bin/tunacc_test_operation.ml +++ /dev/null @@ -1,81 +0,0 @@ -[@@@warning "-32-69-37"] - -open Ocaml_wasm_vm - -let read_file name = - let f = open_in name in - let buf = Bytes.create 100000 in - let size = input f buf 0 100000 in - Bytes.to_string @@ Bytes.sub buf 0 size - -let originate contract init = - let tickets, init = Tunac.Compiler.compile_value init |> Result.get_ok in - let inputs = - if Core.String.is_suffix ~suffix:"tz" contract then read_file contract - else contract - in - let wat, constants, entrypoints = - inputs |> Tunac.Compiler.compile |> Result.get_ok - in - let out = Tunac.Output.make wat constants |> Result.get_ok in - let entrypoints = entrypoints |> Option.value ~default:[] in - Operation_payload. - { - tickets; - operation = - Operation.Originate - { - module_ = out.module_; - entrypoints = Entrypoints.of_assoc entrypoints; - constants; - initial_storage = init; - }; - } - |> Operation_payload.yojson_of_t |> Yojson.Safe.to_string |> print_endline - -let invoke address arg = - let tickets, init = Tunac.Compiler.compile_value arg |> Result.get_ok in - - Operation_payload. - { - tickets; - operation = - Operation.Call - { - address = Deku_ledger.Address.of_b58 address |> Option.get; - argument = init; - }; - } - |> Operation_payload.yojson_of_t |> Yojson.Safe.to_string |> print_endline - -open Core - -let originate = - Command.basic - ~summary: - "Originate a smart contract with given [contract_code] and \ - [initial_storage]" - ~readme:(fun () -> - "Contract code = valid michelson contract.\n\ - Initial_storage = valid michelson value") - Command.Let_syntax.( - let%map_open base = anon ("contract_code" %: string) - and storage = anon ("initial_storage" %: string) in - fun () -> originate base storage) - -let invoke = - Command.basic - ~readme:(fun () -> - "Contract address = valid [DK1] address.\n\ - Contract argument = valid michelson value") - ~summary: - "Invoke a contract with given [contract_address] and [contract_argument]" - (let%map_open.Command address = anon ("contract_address" %: string) - and argument = anon ("contract_argument" %: string) in - fun () -> invoke address argument) - -let command = - Command.group ~summary:"Originate/invoke contracts" - [ ("originate", originate); ("invoke", invoke) ] - -let () = Command_unix.run command diff --git a/deku-c/tunac/lib/Interface.mli b/deku-c/tunac/lib/Interface.mli deleted file mode 100644 index 30f12ad02d..0000000000 --- a/deku-c/tunac/lib/Interface.mli +++ /dev/null @@ -1,59 +0,0 @@ -module Error : sig - type t = [ `Out_of_gas | `Type_error ] [@@deriving show, yojson] -end - -module rec Value : sig - type union = Left of t | Right of t - - and t = - | Int of Z.t - | String of string - | Bool of int - | Pair of t * t - | Union of union - | List of t list - | Option of t option - | Unit - | Map of t Map.t - | Set of Set.t - [@@deriving ord, eq, yojson, show] -end - -and Map : (Helpers.Map.S_with_yojson with type key = Value.t) -and Set : (Helpers.Set.S_with_yojson with type elt = Value.t) - -module Ticket : sig - type t = { ticketer : string; owner : string; data : bytes; amount : Z.t } - [@@deriving eq, yojson, show] -end - -module InvocationPayload : sig - type t = private { - mod_ : string; - arg : string; (* in fact is Value.t *) - initial_storage : string; (* in fact is Value.t *) - tickets : Ticket.t list; - source : string; - sender : string; - self_addr : string; - gas_limit : int64; - } - [@@deriving eq, yojson, show] -end - -module InvocationResult : sig - type t = private { - new_storage : string; - operations : string; - contract_tickets : Ticket.t list; - remaining_gas : int64; - } - [@@deriving eq, yojson, show] -end - -module Vm : sig - val invoke : - InvocationPayload.t -> - get_contract_opt:(string -> string) -> - (InvocationResult.t, Error.t) result Lwt.t -end diff --git a/deku-c/tunac/lib/compiler.ml b/deku-c/tunac/lib/compiler.ml deleted file mode 100644 index 15ac1a5cd4..0000000000 --- a/deku-c/tunac/lib/compiler.ml +++ /dev/null @@ -1,484 +0,0 @@ -[@@@warning "-40-4"] - -open Tezos_micheline.Micheline -open Michelson_primitives - -type context = { - mutable symbol_count : int; - mutable constant_count : int; - mutable constants : (int * Values.t) list; - mutable lambda_count : int; - mutable lambdas : (int * string * string) list; -} - -let gen_symbol ~ctx name = - let id = ctx.symbol_count in - ctx.symbol_count <- ctx.symbol_count + 1; - Printf.sprintf "%s.%d" name id - -let compile_constant ~ctx value = - let id = ctx.constant_count in - match value with - | Values.Int z when Z.equal Z.zero z -> - Printf.sprintf "(call $push (call $zero))" - | _ -> ( - match - List.find_map - (fun (k, x) -> if x = value then Some k else None) - ctx.constants - with - | None -> - ctx.constants <- (id, value) :: ctx.constants; - ctx.constant_count <- ctx.constant_count + 1; - Printf.sprintf "(call $push (call $const (i32.const %d)))" id - | Some x -> Printf.sprintf "(call $push (call $const (i32.const %d)))" x) - -let rec compile_instruction ~ctx instruction = - match instruction with - | Prim (_, I_UNPAIR, _, _) -> "(call $unpair (call $pop)) ;; implicit return" - | Prim (_, I_PAIR, _, _) -> - "(call $push (call $pair (call $pop) (call $pop)))" - | Prim (_, I_ADD, _, _) -> - "(call $push (call $z_add (call $pop) (call $pop)))" - | Prim (_, I_AMOUNT, _, _) -> "(call $push (call $amount))" - | Prim (_, I_AND, _, _) -> "(call $push (call $and (call $pop) (call $pop)))" - | Prim (_, I_BALANCE, _, _) -> "(call $push (call $balance))" - | Prim (_, I_CAR, _, _) -> "(call $push (call $car (call $pop)))" - | Prim (_, I_CDR, _, _) -> "(call $push (call $cdr (call $pop)))" - | Prim (_, I_COMPARE, _, _) -> - "(call $push (call $compare (call $pop) (call $pop)))" - | Prim (_, I_CONS, _, _) -> - "(call $push (call $cons (call $pop) (call $pop)))" - | Prim (_, I_EDIV, _, _) -> - "(call $push (call $ediv (call $pop) (call $pop)))" - | Prim (_, I_EMPTY_SET, _, _) -> "(call $push (call $empty_set))" - | Prim (_, I_EMPTY_MAP, _, _) -> "(call $push (call $empty_map))" - | Prim (_, I_EQ, _, _) -> "(call $push (call $eq (call $pop)))" - | Prim (_, I_EXEC, _, _) -> - "(call $push (call $exec (call $pop) (call $pop)))" - | Prim (_, I_APPLY, _, _) -> - "(call $push (call $apply (call $pop) (call $pop)))" - | Prim (_, I_FAILWITH, _, _) -> "(call $failwith (call $pop)) unreachable" - | Prim (_, I_GE, _, _) -> "(call $push (call $ge (call $pop)))" - | Prim (_, I_GT, _, _) -> "(call $push (call $gt (call $pop)))" - | Prim (_, I_GET, [], _) -> - "(call $push (call $map_get (call $pop) (call $pop)))" - | Prim (_, I_GET, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - Printf.sprintf "(call $push (call $get_n (i32.const %ld) (call $pop)))" n - | Prim (_, I_IF, [ Seq (_, branch_if); Seq (_, branch_else) ], _) -> - let branch_if = - branch_if |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - let branch_else = - branch_else |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - Printf.sprintf "(call $deref_bool (call $pop)) (if (then %s) (else %s))" - branch_if branch_else - | Prim (_, I_IF_CONS, [ Seq (_, branch_if_cons); Seq (_, branch_if_nil) ], _) - -> - let branch_if_cons = - branch_if_cons - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - let branch_if_nil = - branch_if_nil - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - Printf.sprintf "(call $if_cons (call $pop)) (if (then %s) (else %s))" - branch_if_cons branch_if_nil - | Prim (_, I_IF_LEFT, [ Seq (_, branch_if_left); Seq (_, branch_if_right) ], _) - -> - let branch_if_left = - branch_if_left - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - let branch_if_right = - branch_if_right - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - let if_body = - Printf.sprintf "(if (then %s) (else %s))" branch_if_left branch_if_right - in - Printf.sprintf "(call $if_left (call $pop)) %s" if_body - | Prim (_, I_IF_NONE, [ Seq (_, branch_if_none); Seq (_, branch_if_some) ], _) - -> - let branch_if_none = - branch_if_none - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - let branch_if_some = - branch_if_some - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - Printf.sprintf "(call $if_none (call $pop)) (if (then %s) (else %s))" - branch_if_none branch_if_some - | Prim (_, I_LE, _, _) -> "(call $push (call $le (call $pop)))" - | Prim (_, I_LEFT, _, _) -> "(call $push (call $left (call $pop)))" - | Prim (_, I_LT, _, _) -> "(call $push (call $lt (call $pop)))" - | Prim (_, I_MEM, _, _) -> "(call $push (call $mem (call $pop) (call $pop)))" - | Prim (_, I_MUL, _, _) -> - "(call $push (call $z_mul (call $pop) (call $pop)))" - | Prim (_, I_NEG, _, _) -> "(call $push (call $neg (call $pop)))" - | Prim (_, I_NEQ, _, _) -> "(call $push (call $neq (call $pop)))" - | Prim (_, I_NIL, _, _) -> "(call $push (call $nil))" - | Prim (_, I_NONE, _, _) -> "(call $push (call $none))" - | Prim (_, I_NOT, _, _) -> "(call $push (call $not (call $pop)))" - | Prim (_, I_OR, _, _) -> "(call $push (call $or (call $pop) (call $pop)))" - | Prim (_, I_RIGHT, _, _) -> "(call $push (call $right (call $pop)))" - | Prim (_, I_SIZE, _, _) -> "(call $push (call $size (call $pop)))" - | Prim (_, I_SOME, _, _) -> "(call $push (call $some (call $pop)))" - | Prim (_, I_SOURCE, _, _) -> "(call $push (call $source))" - | Prim (_, I_SUB, _, _) -> - "(call $push (call $z_sub (call $pop) (call $pop)))" - | Prim (_, I_SWAP, _, _) -> "(call $swap)" - | Prim (_, I_UNIT, _, _) -> "(call $push (call $unit))" - | Prim (_, I_UPDATE, _, _) -> - "(call $push (call $update (call $pop) (call $pop) (call $pop)))" - | Prim (_, I_XOR, _, _) -> "(call $push (call $xor (call $pop) (call $pop)))" - | Prim (_, I_ISNAT, _, _) -> "(call $push (call $isnat (call $pop)))" - | Prim (_, I_DIG, [ Int (_, n) ], _) -> ( - let n = Z.to_int32 n in - match n with - | 0l -> "" - | 1l -> Printf.sprintf "(call $swap)" - | n -> Printf.sprintf "(call $dig (i32.const %ld))" n) - | Prim (_, I_DUG, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - Printf.sprintf "(call $dug (i32.const %ld))" n - | Prim (_, I_DUP, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - Printf.sprintf "(call $dup (i32.const %ld))" (Int32.sub n 1l) - | Prim (_loc, I_DUP, [], _annot) -> - Printf.sprintf "(call $dup (i32.const %ld))" 0l - | Prim (_, I_DROP, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - Printf.sprintf "(call $drop (i32.const %ld))" n - | Prim (loc, I_DROP, [], annot) -> - compile_instruction ~ctx (Prim (loc, I_DROP, [ Int (loc, Z.one) ], annot)) - | Prim (_, I_DIP, [ Int (_, n); Seq (_, body) ], _) -> - let n = Z.to_int32 n in - let body = - body |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - Printf.sprintf - "(block %s (call $dip (i32.const %ld)) %s (call $undip (i32.const \ - %ld)))" - (gen_symbol ~ctx "dip") n body n - | Prim (loc, I_DIP, [], annot) -> - compile_instruction ~ctx (Prim (loc, I_DIP, [ Int (loc, Z.one) ], annot)) - | Prim (_, I_ABS, _, _) -> "(call $push (call $abs (call $pop)))" - | Prim (_, I_EMPTY_BIG_MAP, _, _) -> "(call $push (call $empty_big_map))" - | Prim (_, I_GET_AND_UPDATE, _, _) -> - "(call $get_and_update (call $pop) (call $pop) (call $pop)) ;; implicit \ - update" - | Prim (_, I_INT, _, _) -> "(call $push (call $int (call $pop)))" - | Prim (_, I_LSL, _, _) -> "(call $push (call $lsl (call $pop) (call $pop)))" - | Prim (_, I_LSR, _, _) -> "(call $push (call $lsr (call $pop) (call $pop)))" - | Prim (_, I_NOW, _, _) -> "(call $push (call $now))" - | Prim (_, I_SELF, _, _) -> "(call $push (call $self))" - | Prim (_, I_SELF_ADDRESS, _, _) -> "(call $push (call $self_address))" - | Prim (_, I_SENDER, _, _) -> "(call $push (call $sender))" - | Prim (_, I_ADDRESS, _, _) -> "(call $push (call $address (call $pop)))" - | Prim (_, I_CONTRACT, _, _) -> "(call $push (call $contract (call $pop)))" - | Prim (_, I_IMPLICIT_ACCOUNT, _, _) -> - "(call $push (call $implicit_account (call $pop)))" - (* | Prim (_, I_LEVEL, _, _) -> "(call $push (call $level))" *) - | Prim (_, I_TRANSFER_TOKENS, _, _) -> - (* 'ty : mutez : contract 'ty : A -> operation : A *) - "(call $push (call $transfer_tokens (call $pop) (call $pop) (call $pop)))" - | Prim (_, I_LOOP, [ Seq (_, body) ], _) -> - let body = - body |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - let loop_name = gen_symbol ~ctx "$loop" in - Printf.sprintf "(loop %s (call $deref_bool (call $pop)) br_if %s %s)" - loop_name loop_name body - | Prim (_, I_LOOP_LEFT, [ Seq (_, body) ], _) -> - let body = - body |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - let loop_name = gen_symbol ~ctx "$loop_left" in - Printf.sprintf "(loop %s (call $if_left (call $pop)) br_if %s %s)" - loop_name loop_name body - | Prim (_, I_ITER, [ Seq (_, body) ], _) -> - let name = gen_symbol ~ctx "$iter_lambda" in - let lambda = compile_lambda ~ctx ~unit:true name body in - Printf.sprintf "(call $iter (call $pop) (i32.const %d) (; %s ;) )" lambda - name - | Prim (_, I_MAP, [ Seq (_, body) ], _) -> - let name = gen_symbol ~ctx "$map_lambda" in - let lambda = compile_lambda ~ctx ~unit:false name body in - Printf.sprintf - "(call $push (call $map (call $pop) (i32.const %d) (; %s ;) ))" lambda - name - | Prim (_, I_PUSH, [ _; Int (_, z) ], _) -> - Printf.sprintf "%s (; %s ;)" - (compile_constant ~ctx (Values.Int z)) - (Z.to_string z) - | Prim (_, I_PUSH, [ _; String (_, s) ], _) -> - Printf.sprintf "%s (; \"%s\" ;)" - (compile_constant ~ctx (Values.String s)) - s - | Prim (_, I_PUSH, [ _; Bytes (_, b) ], _) -> - compile_constant ~ctx (Values.Bytes b) - | Prim (_, I_LAMBDA, [ _; _; Seq (_, body) ], _) -> - let name = gen_symbol ~ctx "$lambda" in - let lambda = compile_lambda ~ctx ~unit:false name body in - Printf.sprintf "(call $push (call $closure (i32.const %d) (; %s ;) ))" - lambda name - | Prim (_, I_BLAKE2B, _, _) -> "(call $push (call $blake2b (call $pop)))" - | Prim (_, I_CHECK_SIGNATURE, _, _) -> - let () = failwith "todo" in - - (* key : signature : bytes : A -> bool : A *) - "(call $push (call $check_signature (call $pop) (call $pop) (call $pop)))" - | Prim (_, I_HASH_KEY, _, _) -> - let () = failwith "todo" in - - (* key : A -> key_hash : A *) - "(call $push (call $hash_key (call $pop)))" - | Prim (_, I_KECCAK, _, _) -> - (* bytes : A -> bytes : A *) - "(call $push (call $keccak (call $pop)))" - | Prim (_, I_PAIRING_CHECK, _, _) -> - let () = failwith "todo" in - (* list ( pair bls12_381_g1 bls12_381_g2 ) : A -> bool : A *) - "(call $push (call $pairing_check (call $pop)))" - | Prim (_, I_SHA256, _, _) -> - (* bytes : A -> bytes : A *) - "(call $push (call $sha256 (call $pop)))" - | Prim (_, I_SHA3, _, _) -> - (* bytes : A -> bytes : A *) - "(call $push (call $sha3 (call $pop)))" - | Prim (_, I_SHA512, _, _) -> - (* bytes : A -> bytes : A *) - "(call $push (call $sha512 (call $pop)))" - | Prim (_, I_CAST, _, _) -> (* Ignored *) "" - | Prim (_, I_CONCAT, _, _) -> - "(call $push (call $concat (call $pop) (call $pop)))" - | Prim (_, I_TICKET, _, _) -> - (* pair ( ticket cty ) ( ticket cty ) : A -> option (ticket cty) : A *) - "(call $push (call $ticket (call $pop) (call $pop)))" - | Prim (_, I_SPLIT_TICKET, _, _) -> - (* ticket cty : pair nat nat : A -> option ( pair ( ticket cty ) ( ticket cty ) ) : A *) - "(call $push (call $split_ticket (call $pop) (call $pop)))" - | Prim (_, I_READ_TICKET, _, _) -> - (* ticket cty : A -> pair address cty nat : A *) - "(call $read_ticket (call $pop)) ;; implicit return" - | Prim (_, I_JOIN_TICKETS, _, _) -> - (* pair ( ticket cty ) ( ticket cty ) : A -> option ( ticket cty ) : A *) - "(call $push (call $join_tickets (call $pop)))" - | Prim (_, I_PACK, _, _) -> "(call $push (call $pack (call $pop)))" - | Prim (_, D_False, _, _) -> "(call $push (call $false))" - | Prim (_, D_True, _, _) -> "(call $push (call $true))" - | Prim (_, I_UNPACK, _, _) -> "(call $push (call $unpack (call $pop)))" - | Prim (_, prim, _, _) -> - failwith - ("Unsupported primitive " ^ Michelson_primitives.string_of_prim prim) - | Seq _ | Int _ | String _ | Bytes _ -> failwith "cant happen" - -and compile_lambda ~ctx ~unit name body = - let body = - body |> List.map (compile_instruction ~ctx) |> String.concat "\n" - in - let lambda = - Printf.sprintf - "(func %s (param $arg i64) %s (local $1 i64) (call $push (local.get \ - $arg)) %s %s)" - name - (if unit then "(result)" else "(result i64)") - body - (if unit then "" else "(call $pop)") - in - let id = ctx.lambda_count in - ctx.lambda_count <- id + 1; - ctx.lambdas <- (id, name, lambda) :: ctx.lambdas; - id - -open Ocaml_wasm_vm - -let rec compile_entry ~state ~path = - let open Helpers.Option.Let_syntax in - function - | Prim (_, T_or, [ (Prim _ as left); (Prim _ as right) ], _) -> - let* state = compile_entry ~state ~path:(Entrypoints.Left :: path) left in - let* state = - compile_entry ~state ~path:(Entrypoints.Right :: path) right - in - Some state - | Prim (_, _, _, annot) -> Some ((List.hd annot, List.rev path) :: state) - | _ -> assert false - -let check_entrypoints = function - | Prim (_, T_or, _, _) -> Some ([], []) - | _ -> None - -let get_entrypoints = - let open Helpers.Option.Let_syntax in - fun x -> - let* state, path = check_entrypoints x in - compile_entry ~state ~path x - -let compile code = - let open Helpers.Result.Let_syntax in - let* parsed = - match Parser.parse_expr code with - | Ok expr -> Ok (root expr) - | (Error (`Parsing_error _) | Error (`Prim_parsing_error _)) as x -> x - in - match parsed with - | Seq - ( _, - [ - Prim (_, K_parameter, [ prim ], _); - Prim (_, K_storage, _, _); - Prim (_, K_code, [ Seq (_, instructions) ], _); - ] ) -> - let ctx = - { - symbol_count = 0; - constant_count = 0; - constants = []; - lambda_count = 0; - lambdas = []; - } - in - let body = - instructions - |> List.map (compile_instruction ~ctx) - |> String.concat "\n" - in - let lambda_code = - ctx.lambdas |> List.map (fun (_, _, x) -> x) |> String.concat "\n" - in - let lambda_table = - ctx.lambdas - |> List.rev_map (fun (_, name, _) -> name) - |> String.concat " " - |> Printf.sprintf "(table $closures funcref (elem %s))\n" - in - Ok - ( Template.base - (lambda_table ^ lambda_code) - (fun fmt b -> Format.pp_print_string fmt b) - body, - Array.of_list ctx.constants, - get_entrypoints prim ) - | _ -> Error `Unexpected_error - -let rec compile_value ~tickets parsed : - (Values.t, [> `Unexpected_error ]) result = - let open Helpers.Result.Let_syntax in - let open Values in - match parsed with - | Prim (_, D_Unit, _, _) -> Ok Unit - | Prim (_, D_False, _, _) -> Ok (Bool 0) - | Prim (_, D_True, _, _) -> Ok (Bool 1) - | Prim (_, D_None, _, _) -> Ok (Option None) - | Prim (_, D_Some, [ value ], _) -> - let* value = compile_value ~tickets value in - Ok (Option (Some value)) - | Prim (_, D_Left, [ value ], _) -> - let* value = compile_value ~tickets value in - Ok (Union (Left value)) - | Prim (_, D_Right, [ value ], _) -> - let* value = compile_value ~tickets value in - Ok (Union (Right value)) - | Prim (_, D_Pair, fst :: values, _) -> - let* fst = compile_value ~tickets fst in - let[@warning "-8"] values, [ end_ ] = - Core.List.split_n values (List.length values - 1) - in - let* end_ = compile_value ~tickets end_ in - let snd = - List.fold_right - (fun x acc -> Pair (compile_value ~tickets x |> Result.get_ok, acc)) - values end_ - in - Ok (Pair (fst, snd)) - | Int (_, z) -> Ok (Values.Int z) - | String (_, s) -> Ok (Values.String s) - | Bytes (_, b) -> Ok (Values.Bytes b) - | Seq (_, Prim (_, D_Elt, _, _) :: _) -> - compile_map ~tickets parsed - (* TODO: sets have the same representation as lists, types should help disambiguate. *) - | Seq (_, elements) -> - let rec aux elts = - match elts with - | elt :: elts -> - let* elt = compile_value ~tickets elt in - let* lst = aux elts in - Ok (elt :: lst) - | [] -> Ok [] - in - let* elements = aux elements in - Ok (Values.List (elements, Other)) - | Prim (_, I_EMPTY_MAP, _, _) -> Ok (Map Map.empty) - | Prim (_, I_EMPTY_SET, _, _) -> Ok (Set Set.empty) - | Prim (_, T_ticket, [ fst ], _) -> - let* result = compile_value ~tickets fst in - let[@warning "-8"] (Pair - ( Values.String ticketer, - Pair (Values.Bytes data, Values.Int amount) )) = - result - in - let ticketer = - Deku_repr.decode_variant - [ - (fun x -> - Deku_ledger.Contract_address.of_b58 x - |> Option.map (fun x -> Deku_ledger.Ticket_id.Deku x)); - (fun x -> - Deku_tezos.Contract_hash.of_b58 x - |> Option.map (fun x -> Deku_ledger.Ticket_id.Tezos x)); - ] - ticketer - |> Option.get - in - let amount = - Deku_stdlib.N.of_z amount - |> Option.map (fun x -> Deku_concepts.Amount.of_n x) - |> Option.get - in - tickets := (Deku_ledger.Ticket_id.make ticketer data, amount) :: !tickets; - Ok - (Ticket { ticket_id = Deku_ledger.Ticket_id.make ticketer data; amount }) - | Prim (_, prim, _, _) -> - print_endline (Michelson_primitives.string_of_prim prim); - Error `Unexpected_error - -and compile_map ~tickets parsed = - let open Helpers.Result.Let_syntax in - match parsed with - | Seq (_, elements) -> - let rec aux m elts = - match elts with - | Prim (_, D_Elt, [ key; value ], _) :: elts -> - let* key = compile_value ~tickets key in - let* value = compile_value ~tickets value in - let m = Values.Map.add key value m in - aux m elts - | [] -> Ok m - | _ -> Error `Unexpected_error - in - let* m = aux Values.Map.empty elements in - Ok (Values.V.Map m) - | _ -> Error `Unexpected_error - -let compile_value expr = - let open Helpers.Result.Let_syntax in - let* parsed = - match Parser.parse_expr expr with - | Ok expr -> Ok (root expr) - | Error (`Parsing_error _ | `Prim_parsing_error _) as err -> err - in - let tickets = ref [] in - let* result = compile_value ~tickets parsed in - Ok (!tickets, result) diff --git a/deku-c/tunac/lib/dune b/deku-c/tunac/lib/dune index 6c751166d2..9cf1b0132a 100644 --- a/deku-c/tunac/lib/dune +++ b/deku-c/tunac/lib/dune @@ -1,14 +1,3 @@ (library (name tunac) - (libraries - core - tezos-micheline - data-encoding - zarith - wasm - ocaml_wasm_vm - deku_concepts - deku_ledger) - (modules_without_implementation interface) - (preprocess - (pps ppx_deriving.ord ppx_deriving.show ppx_deriving.eq ppx_yojson_conv))) + (libraries tezos-micheline binaryen)) diff --git a/deku-c/tunac/lib/helpers.ml b/deku-c/tunac/lib/helpers.ml index cfa9c6dff7..acaea7a24c 100644 --- a/deku-c/tunac/lib/helpers.ml +++ b/deku-c/tunac/lib/helpers.ml @@ -3,11 +3,13 @@ module Result = struct module Let_syntax = struct let ( let* ) a f = Result.bind a f + let ( let+ ) a f = Result.map f a end module Infix = struct let ( >>= ) a f = Result.bind a f + let ( >>| ) a f = Result.map f a end @@ -19,80 +21,19 @@ module Option = struct module Let_syntax = struct let ( let* ) a f = Option.bind a f + let ( let+ ) a f = Option.map f a end module Infix = struct let ( >>= ) a f = Option.bind a f - let ( >>| ) a f = Option.map f a - end -end - -module Z = struct - include Z - - let yojson_of_t t = `String (Z.to_string t) - - let t_of_yojson = function - | `String string -> Z.of_string string - | _ -> failwith "invalid type" -end - -module Map = struct - include Map - - module type S_with_yojson = sig - include Map.S - val yojson_of_t : ('a -> Yojson.Safe.t) -> 'a t -> Yojson.Safe.t - val t_of_yojson : (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a t - end - - module Make_with_yojson (K : sig - type t [@@deriving ord, yojson] - end) = - struct - include Map.Make (K) - - let yojson_of_t f t : Yojson.Safe.t = - let bindings = bindings t in - `List (List.map (fun (k, v) -> `List [ K.yojson_of_t k; f v ]) bindings) - - let t_of_yojson f (json : Yojson.Safe.t) = - match json with - | `List l -> - List.map - (function - | `List [ k; v ] -> (K.t_of_yojson k, f v) - | _ -> failwith "invalid arg") - l - |> List.to_seq |> of_seq - | _ -> failwith "invalid arg" + let ( >>| ) a f = Option.map f a end end -module Set = struct - include Set +module Z = Z - module type S_with_yojson = sig - include Set.S +module Map = Map - val yojson_of_t : t -> Yojson.Safe.t - val t_of_yojson : Yojson.Safe.t -> t - end - - module Make_with_yojson (V : sig - type t [@@deriving ord, yojson] - end) = - struct - include Set.Make (V) - - let yojson_of_t t = - `List (fold (fun x acc -> V.yojson_of_t x :: acc) t [] |> List.rev) - - let t_of_yojson json = - match json with - | `List l -> of_list (List.map V.t_of_yojson l) - | _ -> failwith "invalid arg" - end -end +module Set = Set diff --git a/deku-c/tunac/lib/helpers.mli b/deku-c/tunac/lib/helpers.mli deleted file mode 100644 index 0c419ba268..0000000000 --- a/deku-c/tunac/lib/helpers.mli +++ /dev/null @@ -1,82 +0,0 @@ -module Result : sig - include module type of Result - - module Let_syntax : sig - val ( let* ) : - ('a, 'b) result -> ('a -> ('weak1, 'b) result) -> ('weak1, 'b) result - - val ( let+ ) : ('a, 'b) result -> ('a -> 'c) -> ('c, 'b) result - end - - module Infix : sig - val ( >>= ) : ('a, 'b) t -> ('a -> ('c, 'b) t) -> ('c, 'b) t - val ( >>| ) : ('a, 'b) t -> ('a -> 'c) -> ('c, 'b) t - end - - val wrap : 'a 'b 'c. ('a, 'b) result -> f:('b -> 'c) -> ('a, 'c) result -end - -module Option : sig - include module type of Option - - module Let_syntax : sig - val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t - val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t - end - - module Infix : sig - val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t - end -end - -module Z : sig - include module type of struct - include Z - end - - val yojson_of_t : t -> Yojson.Safe.t - val t_of_yojson : Yojson.Safe.t -> t -end - -module Map : sig - include module type of Map - - module type S_with_yojson = sig - include Map.S - - val yojson_of_t : ('a -> Yojson.Safe.t) -> 'a t -> Yojson.Safe.t - val t_of_yojson : (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a t - end - - module Make_with_yojson : functor - (K : sig - type t [@@deriving ord, yojson] - end) - -> sig - include Map.S with type key = K.t - - val yojson_of_t : ('a -> Yojson.Safe.t) -> 'a t -> Yojson.Safe.t - val t_of_yojson : (Yojson.Safe.t -> 'a) -> Yojson.Safe.t -> 'a t - end -end - -module Set : sig - include module type of Set - - module type S_with_yojson = sig - include Set.S - - val yojson_of_t : t -> Yojson.Safe.t - val t_of_yojson : Yojson.Safe.t -> t - end - - module Make_with_yojson (K : sig - type t [@@deriving ord, yojson] - end) : sig - include Set.S with type elt = K.t - - val yojson_of_t : t -> Yojson.Safe.t - val t_of_yojson : Yojson.Safe.t -> t - end -end diff --git a/deku-c/tunac/lib/iR.ml b/deku-c/tunac/lib/iR.ml new file mode 100644 index 0000000000..9a3a2033cb --- /dev/null +++ b/deku-c/tunac/lib/iR.ml @@ -0,0 +1,55 @@ + +type var = int +[@@deriving show] + +type global = string +[@@deriving show] + +type wasm_operation = + | Wasm_clz + | Wasm_ctz + | Wasm_popcnt + | Wasm_add + | Wasm_sub + | Wasm_mul + | Wasm_div + | Wasm_rem + | Wasm_and + | Wasm_or + | Wasm_xor + | Wasm_shl + | Wasm_shr + | Wasm_rotl + | Wasm_rotr + | Wasm_eqz + | Wasm_eq + | Wasm_ne + | Wasm_lt + | Wasm_gt + | Wasm_le + | Wasm_ge +[@@deriving show] + +type operation = + | Capply of string + | Cload of int + | Calloc of int + | Cwasm of wasm_operation +[@@deriving show] + +type expression = + | Cconst_i32 of int32 + | Cvar of var + | Cglobal of global + | Cop of operation * expression list + [@@deriving show] + +type statement = + | Cassign of var * expression + | Cglobal_assign of global * expression + | Cifthenelse of expression * statement * statement + | Cwhile of expression * statement + | Ccontinue + | Cblock of statement list + | Cstore of int * expression * expression +[@@deriving show] \ No newline at end of file diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml new file mode 100644 index 0000000000..7a688511cf --- /dev/null +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -0,0 +1,413 @@ +open Tezos_micheline +open Micheline +open Michelson_v1_primitives +open IR + +module Env = struct + module Set = Set.Make(Int) + + type t = { mutable allocated: Set.t; mutable max: int } + + let make () = { allocated = Set.of_list [ 0 ]; max = 0 } + + let max t = t.max + + let alloc_local t = + let rec aux reg = + if Set.mem reg t.allocated then + aux (reg + 1) + else if reg > t.max then ( + t.max <- reg; + t.allocated <- Set.add reg t.allocated; + reg + ) else ( + t.allocated <- Set.add reg t.allocated; + reg + ) + in + aux 0 + + let free_local t local = + t.allocated <- Set.remove local t.allocated + +end + +let list_cons var hd tl = + Cblock + [ Cassign (var, Cop (Calloc 2, [])) + ; Cstore (0, Cvar var, hd) + ; Cstore (1, Cvar var, tl) ] + +let compile_car expr = Cop (Cload 0, [ expr ]) + +let compile_cdr expr = Cop (Cload 1, [ expr ]) + +let compile_pop var = + Cblock + [ Cassign (var, compile_car (Cglobal "stack")) + ; Cglobal_assign ("stack", compile_cdr (Cglobal "stack")) ] + +let compile_push ~env expr = + let cell = Env.alloc_local env in + let block = + Cblock + [ list_cons cell expr (Cglobal "stack") + ; Cglobal_assign ("stack", Cvar cell) ] + in + Env.free_local env cell; + block + +let compile_pair ~env = + let cell = Env.alloc_local env in + let item = Env.alloc_local env in + let block = + Cblock + [ Cassign (cell, Cop (Calloc 2, [])) + ; compile_pop item + ; Cstore (0, Cvar cell, Cvar item) + ; compile_pop item + ; Cstore (1, Cvar cell, Cvar item) + ; compile_push ~env (Cvar cell) ] + in + Env.free_local env cell; + Env.free_local env item; + block + +let compile_dig ~env n = + let n = Int32.sub n 1l in + let counter = Env.alloc_local env in + let node = Env.alloc_local env in + let loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, Cglobal "stack") + ; Cwhile (Cvar counter, + Cblock + [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) + ; Cassign (node, compile_cdr (Cvar node)) ]) ] + in + Env.free_local env counter; + let a = Env.alloc_local env in + let block = + Cblock + [ loop + ; Cassign (a, compile_cdr (Cvar node)) + ; Cstore (1, Cvar node, compile_cdr (Cvar a)) + ; Cstore (1, Cvar a, Cglobal "stack") + ; Cglobal_assign ("stack", Cvar a) ] + in + Env.free_local env a; + Env.free_local env node; + block + +let compile_dug ~env n = + let n = Int32.sub n 1l in + let node = Env.alloc_local env in + let counter = Env.alloc_local env in + let inner_loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, compile_cdr (Cglobal "stack")) + ; Cwhile (Cvar counter, + Cblock + [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) + ; Cassign (node, compile_cdr (Cvar node)) ]) ] + in + Env.free_local env counter; + let head = Env.alloc_local env in + let block = + Cblock + [ inner_loop + ; Cassign (head, Cglobal "stack") + ; Cglobal_assign ("stack", compile_cdr (Cvar head)) + ; Cstore (1, Cvar head, compile_cdr (Cvar node)) + ; Cstore (1, Cvar node, Cvar head) ] + in + Env.free_local env node; + Env.free_local env head; + block + +let compile_drop ~env n = + let counter = Env.alloc_local env in + let node = Env.alloc_local env in + let inner_loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, Cglobal "stack") + ; Cwhile (Cvar counter, + Cblock + [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) + ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + in + Env.free_local env counter; + let block = + Cblock + [ inner_loop + ; Cglobal_assign ("stack", Cvar node) ] + in + Env.free_local env node; + block + +let compile_dup ~env n = + let n = Int32.sub n 1l in + let counter = Env.alloc_local env in + let node = Env.alloc_local env in + let inner_loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, Cglobal "stack") + ; Cwhile (Cvar counter + , Cblock + [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) + ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + in + Env.free_local env counter; + let block = + Cblock + [ inner_loop + ; compile_push ~env (compile_car (Cvar node)) ] + in + Env.free_local env node; + block + +let compile_dip ~env n block = + let n = Int32.sub n 1l in + let node = Env.alloc_local env in + let counter = Env.alloc_local env in + let inner_loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, Cglobal "stack") + ; Cwhile (Cvar counter + , Cblock + [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) + ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + in + Env.free_local env counter; + + let pair = Env.alloc_local env in + let save_stack_block = + Cblock + [ Cassign (pair, Cop (Calloc 2, [])) + ; Cstore (0, Cvar pair, Cglobal "stack") + ; Cstore (1, Cvar pair, Cvar node) + ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_add, [ Cglobal "dip_stack"; Cconst_i32 4l ])) + ; Cstore (0, Cglobal "dip_stack", Cvar pair) + ; Cglobal_assign ("stack", compile_cdr (Cvar node)) ] + in + Env.free_local env pair; + Env.free_local env node; + + (* Deallocate and allocate again so it does not conflict with DIP's internal block *) + let pair = Env.alloc_local env in + let restore_stack = + Cblock + [ Cassign (pair, Cop (Cload 0, [ Cglobal "dip_stack" ])) + ; Cstore (1, compile_cdr (Cvar pair), Cglobal "stack") + ; Cglobal_assign ("stack", compile_car (Cvar pair)) + ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_sub, [ Cglobal "dip_stack"; Cconst_i32 4l ] )) ] + in + + Cblock [ inner_loop; save_stack_block; block; restore_stack ] + +let rec compile_instruction ~env instr = + match instr with + | Prim (_, I_CAR, _, _) -> + let top = Env.alloc_local env in + let block = + Cblock [ compile_pop top + ; compile_push ~env (compile_car (Cvar top)) ] + in + Env.free_local env top; + block + + | Prim (_, I_CDR, _, _) -> + let top = Env.alloc_local env in + let block = + Cblock [ compile_pop top + ; compile_push ~env (compile_cdr (Cvar top)) ] + in + Env.free_local env top; + block + + | Prim (_, I_UNPAIR, _, _) -> + let top = Env.alloc_local env in + let block = + Cblock [ compile_pop top + ; compile_push ~env (compile_cdr (Cvar top)) + ; compile_push ~env (compile_car (Cvar top)) ] + in + Env.free_local env top; + block + + | Prim (_, I_ADD, _, _) -> + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let block = + Cblock [ compile_pop x + ; compile_pop y + ; compile_push ~env (Cop (Cwasm Wasm_add, [ Cvar x; Cvar y ])) ] + in + Env.free_local env x; + Env.free_local env y; + block + + | Prim (_, I_SUB, _, _) -> + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let block = + Cblock [ compile_pop x + ; compile_pop y + ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cvar x; Cvar y ])) ] + in + Env.free_local env x; + Env.free_local env y; + block + + + | Prim (_, I_NIL, _, _) -> + compile_push ~env (Cconst_i32 0l) + + | Prim (_, I_PAIR, _, _) -> + compile_pair ~env + + | Prim (_, I_IF_LEFT, [ Seq (_, left_branch); Seq (_, right_branch) ], _) -> + let p = Env.alloc_local env in + let block = + Cblock [ compile_pop p + ; compile_push ~env (Cop (Cload 1, [ Cvar p ])) + ; Cifthenelse + (Cop (Cload 0, [ Cvar p ]) + , Cblock (List.map (compile_instruction ~env) left_branch) + , Cblock (List.map (compile_instruction ~env) right_branch)) ] + in + Env.free_local env p; + block + + | Prim (_, I_SWAP, _, _) -> + let fst = Env.alloc_local env in + let snd = Env.alloc_local env in + let block = + Cblock [ compile_pop fst + ; compile_pop snd + ; compile_push ~env (Cvar fst) + ; compile_push ~env (Cvar snd) ] + in + Env.free_local env fst; + Env.free_local env snd; + block + + | Prim (_, I_PUSH, [ Prim (_, T_int, _, _); Int (_, z) ], _) -> + let value = Z.to_int32 z in + compile_push ~env (Cconst_i32 value) + + | Prim (_, I_DIG, [ Int (_, n) ], _) -> + let n = Z.to_int32 n in + compile_dig ~env n + + | Prim (_, I_DUG, [ Int (_, n) ], _) -> + let n = Z.to_int32 n in + compile_dug ~env n + + | Prim (_, I_DROP, [], _) -> + compile_drop ~env 1l + + | Prim (_, I_DROP, [ Int (_, n) ], _) -> + let n = Z.to_int32 n in + compile_drop ~env n + + | Prim (_, I_DUP, [], _) -> + compile_dup ~env 1l + + | Prim (_, I_DUP, [ Int (_, n) ], _) -> + compile_dup ~env (Z.to_int32 n) + + | Prim (_, I_DIP, [ Int (_, n); Seq (_, instr) ], _) -> + let n = Z.to_int32 n in + let block = Cblock (List.map (compile_instruction ~env) instr) in + if n = 0l then block + else compile_dip ~env n block + + | Prim (_, I_DIP, [ Seq (_, instr) ], _) -> + compile_dip ~env 1l (Cblock (List.map (compile_instruction ~env) instr)) + + | _ -> assert false + +let rec compile_value_decoder ~env typ var ptr = + match typ with + | Prim (_, T_nat, _, _) + | Prim (_, T_int, _, _) + | Prim (_, T_unit, _, _) -> + Cblock + [ Cassign (var, Cop (Cload 0, [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) ] + + | Prim (_, T_or, [ left; right ], _) -> + let wrapped_value = Env.alloc_local env in + let block = + Cblock + [ Cassign (var, Cop (Calloc 2, [])) + ; Cstore (0, Cvar var, Cop (Cload 0, [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) + ; Cifthenelse (Cop (Cload 0, [ Cvar var ]) + , compile_value_decoder ~env left wrapped_value ptr + , compile_value_decoder ~env right wrapped_value ptr ) + ; Cstore (1, Cvar var, Cvar wrapped_value) ] + in + Env.free_local env wrapped_value; + block + + | _ -> assert false + +let compile_value_encoder ~env:_ typ ptr size value = + match typ with + | Prim (_, T_int, _, _) -> + Cblock + [ Cassign (ptr, Cop (Calloc 1, [])) + ; Cstore (0, Cvar ptr, Cvar value) + ; Cassign (size, Cconst_i32 4l) ] + + | _ -> assert false + +let compile_contract contract = + let env = Env.make () in + match contract with + | Seq (_ + , [ Prim (_, K_parameter, [ parameter_type ], _) + ; Prim (_, K_storage, [ storage_type ], _) + ; Prim (_, K_code, [ Seq (_, code) ], _) ]) -> + let parameter = Env.alloc_local env in + let q = Env.alloc_local env in + let parameter_var = Env.alloc_local env in + let param_block = + Cblock + [ Cassign (parameter, Cop (Calloc 0, [ Cop (Capply "parameter_size", []) ])) + ; Cassign (q, Cop (Capply "parameter_load", [ Cvar parameter ])) + ; Cassign (parameter_var, Cop (Calloc 2, [])) + ; compile_value_decoder ~env parameter_type q parameter + ; Cstore (0, Cvar parameter_var, Cvar q) + ; compile_value_decoder ~env storage_type q parameter + ; Cstore (1, Cvar parameter_var, Cvar q) + ; compile_push ~env (Cvar parameter_var) ] + in + Env.free_local env parameter; + Env.free_local env q; + Env.free_local env parameter_var; + + let store_block = + let ptr = Env.alloc_local env in + let size = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + [ Cassign (value, compile_cdr (compile_car (Cglobal "stack"))) + ; compile_value_encoder ~env storage_type ptr size value + ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] + in + Env.free_local env ptr; + Env.free_local env size; + Env.free_local env value; + block + in + + Cblock (param_block :: List.map (compile_instruction ~env) code @ store_block), env + | _ -> assert false \ No newline at end of file diff --git a/deku-c/tunac/lib/michelson_primitives.ml b/deku-c/tunac/lib/michelson_v1_primitives.ml similarity index 65% rename from deku-c/tunac/lib/michelson_primitives.ml rename to deku-c/tunac/lib/michelson_v1_primitives.ml index f07de1165b..e003c6c11b 100644 --- a/deku-c/tunac/lib/michelson_primitives.ml +++ b/deku-c/tunac/lib/michelson_v1_primitives.ml @@ -194,38 +194,160 @@ type namespace = let namespace = function | K_code | K_view | K_parameter | K_storage -> Keyword_namespace - | D_Elt | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True - | D_Unit -> - Constant_namespace - | I_ABS | I_ADD | I_ADDRESS | I_AMOUNT | I_AND | I_APPLY | I_BALANCE - | I_BLAKE2B | I_CAR | I_CAST | I_CDR | I_CHAIN_ID | I_CHECK_SIGNATURE - | I_COMPARE | I_CONCAT | I_CONS | I_CONTRACT | I_CREATE_ACCOUNT - | I_CREATE_CONTRACT | I_DIG | I_DIP | I_DROP | I_DUG | I_DUP | I_VIEW | I_EDIV - | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_FAILWITH - | I_GE | I_GET | I_GET_AND_UPDATE | I_GT | I_HASH_KEY | I_IF | I_IF_CONS - | I_IF_LEFT | I_IF_NONE | I_IMPLICIT_ACCOUNT | I_INT | I_ISNAT | I_ITER - | I_JOIN_TICKETS | I_KECCAK | I_LAMBDA | I_LE | I_LEFT | I_LEVEL | I_LOOP - | I_LOOP_LEFT | I_LSL | I_LSR | I_LT | I_MAP | I_MEM | I_MUL | I_NEG | I_NEQ - | I_NEVER | I_NIL | I_NONE | I_NOT | I_NOW | I_OR | I_PACK | I_PAIR - | I_PAIRING_CHECK | I_PUSH | I_READ_TICKET | I_RENAME | I_RIGHT - | I_SAPLING_EMPTY_STATE | I_SAPLING_VERIFY_UPDATE | I_SELF | I_SELF_ADDRESS - | I_SENDER | I_SET_DELEGATE | I_SHA256 | I_SHA512 | I_SHA3 | I_SIZE | I_SLICE - | I_SOME | I_SOURCE | I_SPLIT_TICKET | I_STEPS_TO_QUOTA | I_SUB | I_SUB_MUTEZ - | I_SWAP | I_TICKET | I_TOTAL_VOTING_POWER | I_TRANSFER_TOKENS | I_UNIT - | I_UNPACK | I_UNPAIR | I_UPDATE | I_VOTING_POWER | I_XOR | I_OPEN_CHEST -> - Instr_namespace - | T_address | T_big_map | T_bool | T_bytes | T_chain_id | T_contract | T_int - | T_key | T_key_hash | T_lambda | T_list | T_map | T_mutez | T_nat | T_never - | T_operation | T_option | T_or | T_pair | T_sapling_state - | T_sapling_transaction | T_set | T_signature | T_string | T_timestamp - | T_unit | T_bls12_381_fr | T_bls12_381_g1 | T_bls12_381_g2 | T_ticket - | T_chest_key | T_chest -> - Type_namespace + | D_Elt + | D_False + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit -> Constant_namespace + | I_ABS + | I_ADD + | I_ADDRESS + | I_AMOUNT + | I_AND + | I_APPLY + | I_BALANCE + | I_BLAKE2B + | I_CAR + | I_CAST + | I_CDR + | I_CHAIN_ID + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CONTRACT + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_DIG + | I_DIP + | I_DROP + | I_DUG + | I_DUP + | I_VIEW + | I_EDIV + | I_EMPTY_BIG_MAP + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GET_AND_UPDATE + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_IMPLICIT_ACCOUNT + | I_INT + | I_ISNAT + | I_ITER + | I_JOIN_TICKETS + | I_KECCAK + | I_LAMBDA + | I_LE + | I_LEFT + | I_LEVEL + | I_LOOP + | I_LOOP_LEFT + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NEVER + | I_NIL + | I_NONE + | I_NOT + | I_NOW + | I_OR + | I_PACK + | I_PAIR + | I_PAIRING_CHECK + | I_PUSH + | I_READ_TICKET + | I_RENAME + | I_RIGHT + | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE + | I_SELF + | I_SELF_ADDRESS + | I_SENDER + | I_SET_DELEGATE + | I_SHA256 + | I_SHA512 + | I_SHA3 + | I_SIZE + | I_SLICE + | I_SOME + | I_SOURCE + | I_SPLIT_TICKET + | I_STEPS_TO_QUOTA + | I_SUB + | I_SUB_MUTEZ + | I_SWAP + | I_TICKET + | I_TOTAL_VOTING_POWER + | I_TRANSFER_TOKENS + | I_UNIT + | I_UNPACK + | I_UNPAIR + | I_UPDATE + | I_VOTING_POWER + | I_XOR + | I_OPEN_CHEST -> Instr_namespace + | T_address + | T_big_map + | T_bool + | T_bytes + | T_chain_id + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_mutez + | T_nat + | T_never + | T_operation + | T_option + | T_or + | T_pair + | T_sapling_state + | T_sapling_transaction + | T_set + | T_signature + | T_string + | T_timestamp + | T_unit + | T_bls12_381_fr + | T_bls12_381_g1 + | T_bls12_381_g2 + | T_ticket + | T_chest_key + | T_chest -> Type_namespace | H_constant -> Constant_hash_namespace let valid_case name = - let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in - let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in + let is_lower = function + | '_' | 'a' .. 'z' -> true + | _ -> false + in + let is_upper = function + | '_' | 'A' .. 'Z' -> true + | _ -> false + in let rec for_all a b f = a > b || (f a && for_all (a + 1) b f) in let len = String.length name in Int.(equal len 0 |> not) @@ -538,13 +660,14 @@ let prim_of_string = | "chest" -> ok T_chest | "constant" -> ok H_constant | n -> - if valid_case n then error (Unknown_primitive_name n) - else error (Invalid_case n) + if valid_case n then error (Unknown_primitive_name n) + else error (Invalid_case n) module type MONAD = sig type 'a t val return : 'a -> 'a t + val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t end @@ -567,20 +690,21 @@ let prims_of_strings expr = type nonrec 'a t = ('a, error) t let return t = Ok t + let ( >>= ) = Result.bind end) in let open Result.Let_syntax in let rec convert = function | (Int _ | String _ | Bytes _) as expr -> Result.ok expr | Prim (loc, prim, args, annot) -> - let* prim = - prim_of_string prim - |> Result.map_error (fun _ -> Invalid_primitive_name (expr, loc)) - in - Lt.traverse convert args - |> Result.map (fun args -> Prim (loc, prim, args, annot)) + let* prim = + prim_of_string prim + |> Result.map_error (fun _ -> Invalid_primitive_name (expr, loc)) + in + Lt.traverse convert args + |> Result.map (fun args -> Prim (loc, prim, args, annot)) | Seq (loc, args) -> - Lt.traverse convert args |> Result.map (fun args -> Seq (loc, args)) + Lt.traverse convert args |> Result.map (fun args -> Seq (loc, args)) in convert (root expr) |> Result.map (fun expr -> strip_locations expr) @@ -588,12 +712,12 @@ let strings_of_prims expr = let rec convert = function | (Int _ | String _ | Bytes _) as expr -> expr | Prim (loc, prim, args, annot) -> - let prim = string_of_prim prim in - let args = List.map convert args in - Prim (loc, prim, args, annot) + let prim = string_of_prim prim in + let args = List.map convert args in + Prim (loc, prim, args, annot) | Seq (loc, args) -> - let args = List.map convert args in - Seq (loc, args) + let args = List.map convert args in + Seq (loc, args) in strip_locations (convert (root expr)) @@ -602,180 +726,179 @@ let prim_encoding = def "michelson.v1.primitives" @@ string_enum (* Add the comment below every 10 lines *) - [ - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("parameter", K_parameter); - ("storage", K_storage); - ("code", K_code); - ("False", D_False); - ("Elt", D_Elt); - ("Left", D_Left); - ("None", D_None); - ("Pair", D_Pair); - ("Right", D_Right); - ("Some", D_Some); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("True", D_True); - ("Unit", D_Unit); - ("PACK", I_PACK); - ("UNPACK", I_UNPACK); - ("BLAKE2B", I_BLAKE2B); - ("SHA256", I_SHA256); - ("SHA512", I_SHA512); - ("ABS", I_ABS); - ("ADD", I_ADD); - ("AMOUNT", I_AMOUNT); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("AND", I_AND); - ("BALANCE", I_BALANCE); - ("CAR", I_CAR); - ("CDR", I_CDR); - ("CHECK_SIGNATURE", I_CHECK_SIGNATURE); - ("COMPARE", I_COMPARE); - ("CONCAT", I_CONCAT); - ("CONS", I_CONS); - ("CREATE_ACCOUNT", I_CREATE_ACCOUNT); - ("CREATE_CONTRACT", I_CREATE_CONTRACT); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT); - ("DIP", I_DIP); - ("DROP", I_DROP); - ("DUP", I_DUP); - ("EDIV", I_EDIV); - ("EMPTY_MAP", I_EMPTY_MAP); - ("EMPTY_SET", I_EMPTY_SET); - ("EQ", I_EQ); - ("EXEC", I_EXEC); - ("FAILWITH", I_FAILWITH); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("GE", I_GE); - ("GET", I_GET); - ("GT", I_GT); - ("HASH_KEY", I_HASH_KEY); - ("IF", I_IF); - ("IF_CONS", I_IF_CONS); - ("IF_LEFT", I_IF_LEFT); - ("IF_NONE", I_IF_NONE); - ("INT", I_INT); - ("LAMBDA", I_LAMBDA); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("LE", I_LE); - ("LEFT", I_LEFT); - ("LOOP", I_LOOP); - ("LSL", I_LSL); - ("LSR", I_LSR); - ("LT", I_LT); - ("MAP", I_MAP); - ("MEM", I_MEM); - ("MUL", I_MUL); - ("NEG", I_NEG); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("NEQ", I_NEQ); - ("NIL", I_NIL); - ("NONE", I_NONE); - ("NOT", I_NOT); - ("NOW", I_NOW); - ("OR", I_OR); - ("PAIR", I_PAIR); - ("PUSH", I_PUSH); - ("RIGHT", I_RIGHT); - ("SIZE", I_SIZE); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("SOME", I_SOME); - ("SOURCE", I_SOURCE); - ("SENDER", I_SENDER); - ("SELF", I_SELF); - ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA); - ("SUB", I_SUB); - ("SWAP", I_SWAP); - ("TRANSFER_TOKENS", I_TRANSFER_TOKENS); - ("SET_DELEGATE", I_SET_DELEGATE); - ("UNIT", I_UNIT); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("UPDATE", I_UPDATE); - ("XOR", I_XOR); - ("ITER", I_ITER); - ("LOOP_LEFT", I_LOOP_LEFT); - ("ADDRESS", I_ADDRESS); - ("CONTRACT", I_CONTRACT); - ("ISNAT", I_ISNAT); - ("CAST", I_CAST); - ("RENAME", I_RENAME); - ("bool", T_bool); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("contract", T_contract); - ("int", T_int); - ("key", T_key); - ("key_hash", T_key_hash); - ("lambda", T_lambda); - ("list", T_list); - ("map", T_map); - ("big_map", T_big_map); - ("nat", T_nat); - ("option", T_option); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("or", T_or); - ("pair", T_pair); - ("set", T_set); - ("signature", T_signature); - ("string", T_string); - ("bytes", T_bytes); - ("mutez", T_mutez); - ("timestamp", T_timestamp); - ("unit", T_unit); - ("operation", T_operation); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("address", T_address); - (* Alpha_002 addition *) - ("SLICE", I_SLICE); - (* Alpha_005 addition *) - ("DIG", I_DIG); - ("DUG", I_DUG); - ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP); - ("APPLY", I_APPLY); - ("chain_id", T_chain_id); - ("CHAIN_ID", I_CHAIN_ID); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("parameter", K_parameter) + ; ("storage", K_storage) + ; ("code", K_code) + ; ("False", D_False) + ; ("Elt", D_Elt) + ; ("Left", D_Left) + ; ("None", D_None) + ; ("Pair", D_Pair) + ; ("Right", D_Right) + ; ("Some", D_Some) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("True", D_True) + ; ("Unit", D_Unit) + ; ("PACK", I_PACK) + ; ("UNPACK", I_UNPACK) + ; ("BLAKE2B", I_BLAKE2B) + ; ("SHA256", I_SHA256) + ; ("SHA512", I_SHA512) + ; ("ABS", I_ABS) + ; ("ADD", I_ADD) + ; ("AMOUNT", I_AMOUNT) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("AND", I_AND) + ; ("BALANCE", I_BALANCE) + ; ("CAR", I_CAR) + ; ("CDR", I_CDR) + ; ("CHECK_SIGNATURE", I_CHECK_SIGNATURE) + ; ("COMPARE", I_COMPARE) + ; ("CONCAT", I_CONCAT) + ; ("CONS", I_CONS) + ; ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) + ; ("CREATE_CONTRACT", I_CREATE_CONTRACT) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) + ; ("DIP", I_DIP) + ; ("DROP", I_DROP) + ; ("DUP", I_DUP) + ; ("EDIV", I_EDIV) + ; ("EMPTY_MAP", I_EMPTY_MAP) + ; ("EMPTY_SET", I_EMPTY_SET) + ; ("EQ", I_EQ) + ; ("EXEC", I_EXEC) + ; ("FAILWITH", I_FAILWITH) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("GE", I_GE) + ; ("GET", I_GET) + ; ("GT", I_GT) + ; ("HASH_KEY", I_HASH_KEY) + ; ("IF", I_IF) + ; ("IF_CONS", I_IF_CONS) + ; ("IF_LEFT", I_IF_LEFT) + ; ("IF_NONE", I_IF_NONE) + ; ("INT", I_INT) + ; ("LAMBDA", I_LAMBDA) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("LE", I_LE) + ; ("LEFT", I_LEFT) + ; ("LOOP", I_LOOP) + ; ("LSL", I_LSL) + ; ("LSR", I_LSR) + ; ("LT", I_LT) + ; ("MAP", I_MAP) + ; ("MEM", I_MEM) + ; ("MUL", I_MUL) + ; ("NEG", I_NEG) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("NEQ", I_NEQ) + ; ("NIL", I_NIL) + ; ("NONE", I_NONE) + ; ("NOT", I_NOT) + ; ("NOW", I_NOW) + ; ("OR", I_OR) + ; ("PAIR", I_PAIR) + ; ("PUSH", I_PUSH) + ; ("RIGHT", I_RIGHT) + ; ("SIZE", I_SIZE) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("SOME", I_SOME) + ; ("SOURCE", I_SOURCE) + ; ("SENDER", I_SENDER) + ; ("SELF", I_SELF) + ; ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) + ; ("SUB", I_SUB) + ; ("SWAP", I_SWAP) + ; ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) + ; ("SET_DELEGATE", I_SET_DELEGATE) + ; ("UNIT", I_UNIT) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("UPDATE", I_UPDATE) + ; ("XOR", I_XOR) + ; ("ITER", I_ITER) + ; ("LOOP_LEFT", I_LOOP_LEFT) + ; ("ADDRESS", I_ADDRESS) + ; ("CONTRACT", I_CONTRACT) + ; ("ISNAT", I_ISNAT) + ; ("CAST", I_CAST) + ; ("RENAME", I_RENAME) + ; ("bool", T_bool) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("contract", T_contract) + ; ("int", T_int) + ; ("key", T_key) + ; ("key_hash", T_key_hash) + ; ("lambda", T_lambda) + ; ("list", T_list) + ; ("map", T_map) + ; ("big_map", T_big_map) + ; ("nat", T_nat) + ; ("option", T_option) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("or", T_or) + ; ("pair", T_pair) + ; ("set", T_set) + ; ("signature", T_signature) + ; ("string", T_string) + ; ("bytes", T_bytes) + ; ("mutez", T_mutez) + ; ("timestamp", T_timestamp) + ; ("unit", T_unit) + ; ("operation", T_operation) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("address", T_address) + ; (* Alpha_002 addition *) + ("SLICE", I_SLICE) + ; (* Alpha_005 addition *) + ("DIG", I_DIG) + ; ("DUG", I_DUG) + ; ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) + ; ("APPLY", I_APPLY) + ; ("chain_id", T_chain_id) + ; ("CHAIN_ID", I_CHAIN_ID) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) (* Alpha_008 addition *) - ("LEVEL", I_LEVEL); - ("SELF_ADDRESS", I_SELF_ADDRESS); - ("never", T_never); - ("NEVER", I_NEVER); - ("UNPAIR", I_UNPAIR); - ("VOTING_POWER", I_VOTING_POWER); - ("TOTAL_VOTING_POWER", I_TOTAL_VOTING_POWER); - ("KECCAK", I_KECCAK); - ("SHA3", I_SHA3); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("LEVEL", I_LEVEL) + ; ("SELF_ADDRESS", I_SELF_ADDRESS) + ; ("never", T_never) + ; ("NEVER", I_NEVER) + ; ("UNPAIR", I_UNPAIR) + ; ("VOTING_POWER", I_VOTING_POWER) + ; ("TOTAL_VOTING_POWER", I_TOTAL_VOTING_POWER) + ; ("KECCAK", I_KECCAK) + ; ("SHA3", I_SHA3) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) (* Alpha_008 addition *) - ("PAIRING_CHECK", I_PAIRING_CHECK); - ("bls12_381_g1", T_bls12_381_g1); - ("bls12_381_g2", T_bls12_381_g2); - ("bls12_381_fr", T_bls12_381_fr); - ("sapling_state", T_sapling_state); - ("sapling_transaction", T_sapling_transaction); - ("SAPLING_EMPTY_STATE", I_SAPLING_EMPTY_STATE); - ("SAPLING_VERIFY_UPDATE", I_SAPLING_VERIFY_UPDATE); - ("ticket", T_ticket); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("PAIRING_CHECK", I_PAIRING_CHECK) + ; ("bls12_381_g1", T_bls12_381_g1) + ; ("bls12_381_g2", T_bls12_381_g2) + ; ("bls12_381_fr", T_bls12_381_fr) + ; ("sapling_state", T_sapling_state) + ; ("sapling_transaction", T_sapling_transaction) + ; ("SAPLING_EMPTY_STATE", I_SAPLING_EMPTY_STATE) + ; ("SAPLING_VERIFY_UPDATE", I_SAPLING_VERIFY_UPDATE) + ; ("ticket", T_ticket) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) (* Alpha_008 addition *) - ("TICKET", I_TICKET); - ("READ_TICKET", I_READ_TICKET); - ("SPLIT_TICKET", I_SPLIT_TICKET); - ("JOIN_TICKETS", I_JOIN_TICKETS); - ("GET_AND_UPDATE", I_GET_AND_UPDATE); - (* Alpha_011 addition *) - ("chest", T_chest); - ("chest_key", T_chest_key); - ("OPEN_CHEST", I_OPEN_CHEST); - (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) - ("VIEW", I_VIEW); - ("view", K_view); - ("constant", H_constant); - (* Alpha_012 addition *) + ("TICKET", I_TICKET) + ; ("READ_TICKET", I_READ_TICKET) + ; ("SPLIT_TICKET", I_SPLIT_TICKET) + ; ("JOIN_TICKETS", I_JOIN_TICKETS) + ; ("GET_AND_UPDATE", I_GET_AND_UPDATE) + ; (* Alpha_011 addition *) + ("chest", T_chest) + ; ("chest_key", T_chest_key) + ; ("OPEN_CHEST", I_OPEN_CHEST) + ; (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) + ("VIEW", I_VIEW) + ; ("view", K_view) + ; ("constant", H_constant) + ; (* Alpha_012 addition *) ("SUB_MUTEZ", I_SUB_MUTEZ) (* New instructions must be added here, for backward compatibility of the encoding. *) - (* Keep the comment above at the end of the list *); + (* Keep the comment above at the end of the list *) ] let string_of_namespace = function diff --git a/deku-c/tunac/lib/output.ml b/deku-c/tunac/lib/output.ml deleted file mode 100644 index d05fb29ecc..0000000000 --- a/deku-c/tunac/lib/output.ml +++ /dev/null @@ -1,21 +0,0 @@ -type t = { module_ : string; constants : (int * Values.t) array } - -let make module_ constants = - let open Wasm.Script in - let open Wasm.Source in - try - let m = Wasm.Parse.string_to_module module_ in - match m.it with - | Textual m -> - Wasm.Valid.check_module m; - Array.sort (fun (x, _) (x2, _) -> Int.compare x x2) constants; - Ok - { - module_ = Hex.of_string (Wasm.Encode.encode m) |> Hex.show; - constants; - } - | Encoded _ | Quoted _ -> Error `Invalid_module - with Wasm.Parse.Syntax (at, msg) | Wasm.Valid.Invalid (at, msg) -> - Format.eprintf "Module validation error at %d:%d - %d:%d: %s" at.left.line - at.left.column at.right.line at.right.column msg; - Error `Module_validation_error diff --git a/deku-c/tunac/lib/output.mli b/deku-c/tunac/lib/output.mli deleted file mode 100644 index cf2f7baf4e..0000000000 --- a/deku-c/tunac/lib/output.mli +++ /dev/null @@ -1,6 +0,0 @@ -type t = { module_ : string; constants : (int * Values.t) array } - -val make : - string -> - (int * Values.t) array -> - (t, [ `Invalid_module | `Module_validation_error ]) result diff --git a/deku-c/tunac/lib/parser.ml b/deku-c/tunac/lib/parser.ml deleted file mode 100644 index 1216cd27d8..0000000000 --- a/deku-c/tunac/lib/parser.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Helpers -open Tezos_micheline -module MPrim = Michelson_primitives - -let to_parsing_error error = Result.wrap ~f:(fun x -> `Parsing_error x) error - -let to_prim_parsing_error error = - Result.wrap ~f:(fun x -> `Prim_parsing_error x) error - -let parse_expr expr = - let open Result.Let_syntax in - let* tokenized = - Micheline_parser.tokenize expr - |> Micheline_parser.no_parsing_error |> to_parsing_error - in - let* parsed = - Micheline_parser.parse_expression tokenized - |> Micheline_parser.no_parsing_error |> to_parsing_error - in - let* x = - parsed |> Micheline.strip_locations |> MPrim.prims_of_strings - |> to_prim_parsing_error - in - Ok x diff --git a/deku-c/tunac/lib/parser.mli b/deku-c/tunac/lib/parser.mli deleted file mode 100644 index 9d89aea88c..0000000000 --- a/deku-c/tunac/lib/parser.mli +++ /dev/null @@ -1,8 +0,0 @@ -module MPrim = Michelson_primitives - -val parse_expr : - string -> - ( MPrim.prim Tezos_micheline.Micheline.canonical, - [ `Parsing_error of Tezos_error_monad.Error_monad.tztrace - | `Prim_parsing_error of MPrim.error ] ) - result diff --git a/deku-c/tunac/lib/path.ml b/deku-c/tunac/lib/path.ml deleted file mode 100644 index f3ef104056..0000000000 --- a/deku-c/tunac/lib/path.ml +++ /dev/null @@ -1,37 +0,0 @@ -type path = Left | Right - -let yojson_of_path = function - | Left -> `String "Left" - | Right -> `String "Right" - -let path_of_yojson = function - | `String "Left" -> Left - | `String "Right" -> Right - | _ -> failwith "bad" - -module M = struct - include Map.Make (String) -end - -type t = path list M.t - -let t_of_yojson : Yojson.Safe.t -> t = function - | `Assoc l -> - List.to_seq l - |> Seq.map (fun (k, v) -> (k, [%of_yojson: path list] v)) - |> M.of_seq - | _ -> failwith "FIXME: what to do here?" - -let yojson_of_t map = - let assoc = - M.bindings map - |> List.map (fun (k, v) -> - (* FIXME: doing this for convenience for now, but it seems - like a bad idea in the long run. We should make the protocol - agnostic of the serialization format. *) - let v_json = [%yojson_of: path list] v in - (k, v_json)) - in - `Assoc assoc - -let empty = M.empty diff --git a/deku-c/tunac/lib/template.ml b/deku-c/tunac/lib/template.ml deleted file mode 100644 index 3925ce7dbb..0000000000 --- a/deku-c/tunac/lib/template.ml +++ /dev/null @@ -1,259 +0,0 @@ -let import_list = - let ref_unit = "(param i64 ) (result)" in - let ref_ref__ref = "(param i64 i64) (result i64)" in - let ref_i32__ref = "(param i64 i32) (result i64)" in - let ref_i32__unit = "(param i64 i32) (result )" in - - let ref_ref_ref__ref = "(param i64 i64 i64) (result i64)" in - let ref_ref_ref__ = "(param i64 i64 i64)" in - let ref__ref = "(param i64) (result i64)" in - let ref__i32 = "(param i64) (result i32)" in - let i32__ref = "(param i32) (result i64)" in - let i32_ref__ref = "(param i32 i64) (result i64)" in - let ref__ = "(param i64)" in - let const = "(result i64)" in - let func type_ name = - Printf.sprintf "(import \"env\" \"%s\" (func $%s %s))" name name type_ - in - [ - func ref_unit "dup_host"; - func ref_ref__ref "pair"; - func ref__ "unpair"; - func ref_ref__ref "z_add"; - func ref_ref__ref "z_sub"; - func ref_ref__ref "z_mul"; - func ref__ref "neg"; - func ref_ref__ref "lsl"; - func ref_ref__ref "concat"; - func ref_ref__ref "lsr"; - func ref_ref__ref "compare"; - func ref__ref "car"; - func ref__ref "cdr"; - func ref__ref "some" (* ; func const "now" *); - func const "nil"; - func const "true"; - func const "false"; - func const "none"; - func const "unit"; - func const "zero"; - func const "empty_map"; - func const "empty_set"; - func const "empty_big_map"; - func const "sender"; - func const "source"; - func ref_ref__ref "map_get"; - func ref_ref__ref "mem"; - func ref_ref_ref__ref "update"; - func ref_i32__unit "iter"; - func ref_i32__ref "map"; - func ref__i32 "if_left"; - func ref__i32 "if_none"; - func ref__i32 "if_cons"; - func ref__ref "isnat"; - func ref__ref "not"; - func ref_ref__ref "or"; - func ref_ref__ref "and"; - func ref_ref__ref "xor"; - func ref__i32 "deref_bool"; - func ref__ref "neq"; - func ref__ "failwith"; - func i32_ref__ref "get_n"; - func ref_ref__ref "exec"; - func ref_ref__ref "apply"; - func i32__ref "const"; - func ref__ref "abs"; - func ref__ref "eq"; - func ref__ref "gt"; - func ref__ref "lt"; - func i32__ref "closure"; - func ref__ref "left"; - func ref__ref "right"; - func ref_ref__ref "cons"; - func ref_ref_ref__ref "transfer_tokens"; - func ref__ref "address"; - func ref__ref "contract"; - func const "self"; - func const "self_address"; - func ref_ref_ref__ "get_and_update"; - func ref__ "read_ticket"; - func ref_ref__ref "ticket"; - func ref__ref "join_tickets"; - func ref_ref__ref "split_ticket"; - func const "amount"; - func const "balance" (* ; func const "level" *); - func ref_ref__ref "ediv"; - func ref__ref "ge"; - func ref__ref "le"; - func ref__ref "size"; - func ref__ref "int"; - func ref__ref "implicit_account"; - func ref__ref "blake2b"; - func ref__ref "pack"; - func ref__ref "unpack" - (* ; func ref_ref_ref__ref "check_signature" *) - (* ; func ref__ref "hash_key" *); - func ref__ref "keccak" (* ; func ref__ref "pairing_check" *); - func ref__ref "sha256"; - func ref__ref "sha3"; - func ref__ref "sha512"; - ] - |> String.concat "\n" - -let base t = - Format.asprintf - {| -(module - %s - - (global $mode i32 (i32.const 0)) - - (memory 4) - (global $sp (mut i32) (i32.const 4000)) ;; stack pointer - (global $sh_sp (mut i32) (i32.const 1000)) ;;shadow_stack stack pointer - - (global $__stack_base i32 (i32.const 32768)) - - (type $callback_t (func (param i64) (result i64))) - (func $call_callback (param $arg1 i64) (param $idx i32) (result i64) - (call_indirect (type $callback_t) (local.get $arg1) (local.get $idx))) - - (type $callback_t_unit (func (param i64) (result))) - (func $call_callback_unit (param $arg1 i64) (param $idx i32) (result ) - (call_indirect (type $callback_t_unit) - (local.get $arg1) - (local.get $idx))) - - (func $dip (param $n i32) (result) - (local $stop i32) - (local $sp' i32) - (local $sh_sp' i32) - (local.set $stop (i32.const 0)) - (local.set $sp' (global.get $sp)) - (local.tee $sh_sp' (i32.sub (global.get $sh_sp) (local.get $n))) - global.set $sh_sp - (loop $l - (i32.mul (i32.const 8) (i32.add (global.get $__stack_base) (i32.add (local.get $sh_sp') (local.get $stop)))) - (i64.load (i32.mul (i32.const 8) (i32.add (local.get $sp') (local.get $stop)))) - i64.store - (local.tee $stop (i32.add (local.get $stop) (i32.const 1))) - (local.get $n) - i32.ne - br_if $l) - - (global.set $sp - (i32.add - (local.get $sp') (local.get $n)))) - - (func $undip (param $n i32) (result) - (local $stop i32) - (local $sp' i32) - (local $sh_sp' i32) - (local.tee $sp' (i32.sub (global.get $sp) (local.get $n))) - global.set $sp - (local.set $sh_sp' (global.get $sh_sp)) - (local.set $stop (i32.const 0)) - (loop $l - (i32.mul (i32.const 8) (i32.add (local.get $sp') (local.get $stop))) - (i64.load - (i32.add - (global.get $__stack_base) - (i32.mul (i32.const 8) (i32.add (local.get $sh_sp') (local.get $stop))))) - (i64.store) - (local.tee $stop (i32.add (local.get $stop) (i32.const 1))) - (local.get $n) - i32.ne - br_if $l) - (global.set $sh_sp (i32.add (local.get $sh_sp') (local.get $n)))) - - (func $dup (param $n i32) (result) - (i64.load (i32.mul (i32.const 8) (i32.add (global.get $sp) (local.get $n)))) - (call $dup_host)) - - (func $swap (param) (result) - (local $v1 i64) - (local $v2 i64) - (local.set $v1 (call $pop)) - (local.set $v2 (call $pop)) - (call $push (local.get $v1)) - (call $push (local.get $v2))) - - (func $dug (param $n i32) (result) - (local $idx i32) - (local $loop_idx i32) - (local $sp' i32) - (local $top i64) - (local.set $sp' (i32.add (global.get $sp) (local.get $n))) - (local.tee $idx (global.get $sp)) - (local.tee $loop_idx) - (i32.mul (i32.const 8)) - i64.load - local.set $top - (loop $loop - (i32.mul (i32.const 8) (local.get $idx)) - (i32.add (local.get $loop_idx) (i32.const 1)) - local.tee $loop_idx - (i32.mul (i32.const 8)) - i64.load - i64.store - (local.set $idx (i32.add (local.get $idx) (i32.const 1))) - (local.get $idx) - (local.get $sp') - i32.lt_u - br_if $loop) - - (i64.store (i32.mul (i32.const 8) (local.get $sp')) (local.get $top))) - - (func $dig (param $n i32) (result) - (local $idx i32) (local $t i32) (local $digged i64) - - (local.set $digged - (i64.load - (i32.mul (i32.const 8) - (local.tee $idx (i32.add (global.get $sp) (local.get $n)))))) - - (loop $loop - (local.set $t (i32.mul (i32.const 8) (local.get $idx))) - - (i64.store (local.get $t) - (i64.load - (i32.mul - (i32.const 8) - (local.tee $idx (i32.sub (local.get $idx) (i32.const 1)))))) - - (br_if $loop - (i32.lt_u (global.get $sp) (local.get $idx)))) - - (i64.store (i32.mul (i32.const 8) (local.get $idx)) (local.get $digged))) - - (func $pop (result i64) - (local $spp i32) - (i32.mul (i32.const 8) (local.tee $spp (global.get $sp))) - i64.load - (global.set $sp (i32.add (local.get $spp) (i32.const 1)))) ;;set stackptr - - (func $push (param $value i64) (result) - (local $spp i32) - (i32.mul (i32.const 8) (local.tee $spp (i32.sub (global.get $sp) (i32.const 1)) )) - (i64.store (local.get $value)) - (global.set $sp (local.get $spp))) ;;set stackptr - - (func $drop (param $n i32) (result) - (global.set $sp (i32.add (global.get $sp) (local.get $n)))) ;;set stackptr - - %s - - (func $main (param $v1 i64) (result i64) - (local $1 i64) - (call $push (local.get $v1)) - %a - (call $pop)) - - (export "push" (func $push)) - (export "pop" (func $push)) - (export "main" (func $main)) - (export "closures" (table $closures)) - (export "call_callback" (func $call_callback)) - (export "call_callback_unit" (func $call_callback_unit)) - ) -|} - import_list t diff --git a/deku-c/tunac/lib/template.mli b/deku-c/tunac/lib/template.mli deleted file mode 100644 index 988db79f49..0000000000 --- a/deku-c/tunac/lib/template.mli +++ /dev/null @@ -1,2 +0,0 @@ -val import_list : string -val base : string -> (Format.formatter -> 'a -> unit) -> 'a -> string diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml new file mode 100644 index 0000000000..5b5a3823a4 --- /dev/null +++ b/deku-c/tunac/lib/tunac.ml @@ -0,0 +1,20 @@ + +type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node + +type contract = node + +let parse code = + let open Tezos_micheline in + let tokens, _ = Micheline_parser.tokenize code in + let code, _ = Micheline_parser.parse_expression tokens in + code + |> Micheline.strip_locations + |> Micheline.map (fun prim -> Michelson_v1_primitives.prim_of_string prim |> Result.get_ok) + |> Micheline.root + +let compile_contract contract = + let ir, env = IR_of_michelson.compile_contract contract in + Wasm_of_ir.compile_ir ~env ir + +let compile_value _node = + Bytes.empty \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.mli b/deku-c/tunac/lib/tunac.mli new file mode 100644 index 0000000000..8c7d4af920 --- /dev/null +++ b/deku-c/tunac/lib/tunac.mli @@ -0,0 +1,10 @@ + +type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node + +type contract = node + +val parse : string -> contract + +val compile_contract : contract -> Binaryen.Module.t + +val compile_value : node -> bytes \ No newline at end of file diff --git a/deku-c/tunac/lib/values.ml b/deku-c/tunac/lib/values.ml deleted file mode 100644 index fbf3caf3de..0000000000 --- a/deku-c/tunac/lib/values.ml +++ /dev/null @@ -1 +0,0 @@ -include Ocaml_wasm_vm.Value diff --git a/deku-c/tunac/lib/values.mli b/deku-c/tunac/lib/values.mli deleted file mode 100644 index 35074767a4..0000000000 --- a/deku-c/tunac/lib/values.mli +++ /dev/null @@ -1,3 +0,0 @@ -include module type of struct - include Ocaml_wasm_vm.Value -end diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml new file mode 100644 index 0000000000..5f9c2d29b3 --- /dev/null +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -0,0 +1,140 @@ +open IR +open Binaryen + +let gensym_count = ref 0 +let gensym name = + incr gensym_count; + Printf.sprintf "%s.%d" name !gensym_count + +let rec compile_expression wasm_mod expr = + match expr with + | Cglobal global -> Expression.Global_get.make wasm_mod global Type.int32 + | Cvar var -> Expression.Local_get.make wasm_mod var Type.int32 + | Cconst_i32 value -> Expression.Const.make wasm_mod (Literal.int32 value) + | Cop (op, params) -> compile_operation wasm_mod op params + + +and compile_operation wasm_mod op params = + match op, params with + | Capply name, params -> Expression.Call.make wasm_mod name (List.map (compile_expression wasm_mod) params) Type.int32 + | Cload cell, [ ptr ] -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 (compile_expression wasm_mod ptr) + | Calloc size, params -> + let final_size = + match size, params with + | 0, [ value ] -> compile_expression wasm_mod value + | size, [ ] -> Expression.Const.make wasm_mod (Literal.int32 (Int32.of_int (size * 4))) + | size, [ value ] -> + Expression.Binary.make wasm_mod Op.add_int32 + (compile_expression wasm_mod value) + (Expression.Const.make wasm_mod (Literal.int32 (Int32.of_int (size * 4)))) + | _ -> assert false + in + Expression.Block.make wasm_mod (gensym "alloc") + [ Expression.Local_set.make wasm_mod 0 (Expression.Global_get.make wasm_mod "heap_top" Type.int32) + ; Expression.Global_set.make wasm_mod "heap_top" + (Expression.Binary.make wasm_mod Op.add_int32 + (Expression.Global_get.make wasm_mod "heap_top" Type.int32) + final_size) + ; Expression.Local_get.make wasm_mod 0 Type.int32 ] + | Cwasm wasm_operation, params -> compile_wasm_operation wasm_mod wasm_operation params + + | _ -> assert false + +and compile_wasm_operation wasm_mod operation params = + match operation, params with + | Wasm_add, [ a; b ] -> + Expression.Binary.make wasm_mod Op.add_int32 + (compile_expression wasm_mod a) + (compile_expression wasm_mod b) + + | Wasm_sub, [ a; b ] -> + Expression.Binary.make wasm_mod Op.sub_int32 + (compile_expression wasm_mod a) + (compile_expression wasm_mod b) + + | _ -> assert false + +let loop_stack = ref [] + +let rec compile_statement wasm_mod statement = + match statement with + | Cblock statements -> + Expression.Block.make wasm_mod (gensym "block") + (List.map (compile_statement wasm_mod) statements) + + | Cassign (var, expr) -> + Expression.Local_set.make wasm_mod var (compile_expression wasm_mod expr) + + | Cstore (cell, ptr, value) -> + Expression.Store.make wasm_mod 4 (cell * 4) 0 + (compile_expression wasm_mod ptr) + (compile_expression wasm_mod value) + Type.int32 + + | Cglobal_assign (global, value) -> + Expression.Global_set.make wasm_mod global + (compile_expression wasm_mod value) + + | Cifthenelse (condition, _if, _else) -> + Expression.If.make wasm_mod + (compile_expression wasm_mod condition) + (compile_statement wasm_mod _if) + (compile_statement wasm_mod _else) + + | Cwhile (condition, statement) -> + let name = gensym "loop" in + loop_stack := name :: !loop_stack; + let loop = + Expression.Loop.make wasm_mod name + (Expression.If.make wasm_mod + (compile_expression wasm_mod condition) + (Expression.Block.make wasm_mod (gensym "while_body") + [ compile_statement wasm_mod statement + ; Expression.Break.make wasm_mod name + (Expression.Null.make ()) + (Expression.Null.make ()) ]) + (Expression.Null.make ())) + in + loop_stack := List.tl !loop_stack; + loop + + | Ccontinue -> + (* WASM break on loops works more like a continue than a break *) + Expression.Break.make wasm_mod (List.hd !loop_stack) (Expression.Null.make ()) (Expression.Null.make ()) + +let compile_ir ~env ast = + let wasm_mod = Module.create () in + + let locals = Array.make (IR_of_michelson.Env.max env + 1) Type.int32 in + let expr = compile_statement wasm_mod ast in + + ignore @@ + Function.add_function wasm_mod "main" Type.none Type.none locals expr; + ignore @@ + Export.add_function_export wasm_mod "main" "main"; + + ignore @@ + Global.add_global wasm_mod "stack" Type.int32 true + (Expression.Const.make wasm_mod (Literal.int32 0l)); + ignore @@ Export.add_global_export wasm_mod "stack" "stack"; + + ignore @@ + Global.add_global wasm_mod "heap_top" Type.int32 true + (Expression.Const.make wasm_mod (Literal.int32 512l)); + ignore @@ + Export.add_global_export wasm_mod "heap_top" "heap_top"; + + ignore @@ + Global.add_global wasm_mod "dip_stack" Type.int32 true + (Expression.Const.make wasm_mod (Literal.int32 256l)); + + Import.add_function_import wasm_mod "parameter_size" "env" "parameter_size" Type.none Type.int32; + Import.add_function_import wasm_mod "parameter_load" "env" "parameter_load" Type.int32 Type.int32; + Import.add_function_import wasm_mod "save_storage" "env" "save_storage" Type.(create [| int32; int32 |]) Type.int32; + + Memory.set_memory wasm_mod 1 10 "memory" [] true; + + if Module.validate wasm_mod <> 0 then + failwith "Generated module is invalid"; + + wasm_mod \ No newline at end of file diff --git a/deku-c/tunac/tests/DexFA2.tz b/deku-c/tunac/tests/DexFA2.tz deleted file mode 100644 index d2666e6cdc..0000000000 --- a/deku-c/tunac/tests/DexFA2.tz +++ /dev/null @@ -1,381 +0,0 @@ -{ parameter - (or (or (or (pair %balance_of - (list %requests (pair (address %owner) (nat %token_id))) - (contract %callback - (list (pair (pair %request (address %owner) (nat %token_id)) (nat %balance))))) - (unit %default)) - (or (contract %get_reserves (pair nat nat)) - (list %transfer - (pair (address %from_) - (list %txs (pair (address %to_) (pair (nat %token_id) (nat %amount)))))))) - (or (list %update_operators - (or (pair %add_operator (address %owner) (pair (address %operator) (nat %token_id))) - (pair %remove_operator (address %owner) (pair (address %operator) (nat %token_id))))) - (or %use - (or (or (pair %divestLiquidity (pair (nat %min_tez) (nat %min_tokens)) (nat %shares)) - (nat %initializeExchange)) - (or (nat %investLiquidity) - (pair %tezToTokenPayment (nat %min_out) (address %receiver)))) - (or (or (pair %tokenToTezPayment (pair (nat %amount) (nat %min_out)) (address %receiver)) - (pair %veto (nat %value) (address %voter))) - (or (pair %vote (pair (key_hash %candidate) (nat %value)) (address %voter)) - (address %withdrawProfit)))))) ; - storage - (pair (pair (big_map %dex_lambdas - nat - (lambda - (pair (pair (or (or (or (pair %divestLiquidity (pair (nat %min_tez) (nat %min_tokens)) (nat %shares)) - (nat %initializeExchange)) - (or (nat %investLiquidity) - (pair %tezToTokenPayment (nat %min_out) (address %receiver)))) - (or (or (pair %tokenToTezPayment (pair (nat %amount) (nat %min_out)) (address %receiver)) - (pair %veto (nat %value) (address %voter))) - (or (pair %vote (pair (key_hash %candidate) (nat %value)) (address %voter)) - (address %withdrawProfit)))) - (pair (pair (pair (pair (pair (address %baker_validator) (option %current_candidate key_hash)) - (pair (option %current_delegated key_hash) (timestamp %last_update_time))) - (pair (pair (timestamp %last_veto) - (big_map %ledger - address - (pair (pair (set %allowances address) (nat %balance)) (nat %frozen_balance)))) - (pair (timestamp %period_finish) (nat %reward)))) - (pair (pair (pair (nat %reward_paid) (nat %reward_per_sec)) - (pair (nat %reward_per_share) (nat %tez_pool))) - (pair (pair (address %token_address) (nat %token_id)) - (pair (nat %token_pool) (nat %total_reward))))) - (pair (pair (pair (nat %total_supply) (nat %total_votes)) - (pair (big_map %user_rewards address (pair (nat %reward) (nat %reward_paid))) - (nat %veto))) - (pair (pair (big_map %vetos key_hash timestamp) - (big_map %voters - address - (pair (pair (option %candidate key_hash) (timestamp %last_veto)) - (pair (nat %veto) (nat %vote))))) - (big_map %votes key_hash nat))))) - address) - (pair (list operation) - (pair (pair (pair (pair (pair (address %baker_validator) (option %current_candidate key_hash)) - (pair (option %current_delegated key_hash) (timestamp %last_update_time))) - (pair (pair (timestamp %last_veto) - (big_map %ledger - address - (pair (pair (set %allowances address) (nat %balance)) (nat %frozen_balance)))) - (pair (timestamp %period_finish) (nat %reward)))) - (pair (pair (pair (nat %reward_paid) (nat %reward_per_sec)) - (pair (nat %reward_per_share) (nat %tez_pool))) - (pair (pair (address %token_address) (nat %token_id)) - (pair (nat %token_pool) (nat %total_reward))))) - (pair (pair (pair (nat %total_supply) (nat %total_votes)) - (pair (big_map %user_rewards address (pair (nat %reward) (nat %reward_paid))) - (nat %veto))) - (pair (pair (big_map %vetos key_hash timestamp) - (big_map %voters - address - (pair (pair (option %candidate key_hash) (timestamp %last_veto)) - (pair (nat %veto) (nat %vote))))) - (big_map %votes key_hash nat))))))) - (big_map %metadata string bytes)) - (pair (pair %storage - (pair (pair (pair (pair (address %baker_validator) (option %current_candidate key_hash)) - (pair (option %current_delegated key_hash) (timestamp %last_update_time))) - (pair (pair (timestamp %last_veto) - (big_map %ledger - address - (pair (pair (set %allowances address) (nat %balance)) (nat %frozen_balance)))) - (pair (timestamp %period_finish) (nat %reward)))) - (pair (pair (pair (nat %reward_paid) (nat %reward_per_sec)) - (pair (nat %reward_per_share) (nat %tez_pool))) - (pair (pair (address %token_address) (nat %token_id)) - (pair (nat %token_pool) (nat %total_reward))))) - (pair (pair (pair (nat %total_supply) (nat %total_votes)) - (pair (big_map %user_rewards address (pair (nat %reward) (nat %reward_paid))) - (nat %veto))) - (pair (pair (big_map %vetos key_hash timestamp) - (big_map %voters - address - (pair (pair (option %candidate key_hash) (timestamp %last_veto)) - (pair (nat %veto) (nat %vote))))) - (big_map %votes key_hash nat)))) - (big_map %token_lambdas - nat - (lambda - (pair (pair (or (or (pair %iBalance_of - (list %requests (pair (address %owner) (nat %token_id))) - (contract %callback - (list (pair (pair %request (address %owner) (nat %token_id)) (nat %balance))))) - (list %iTransfer - (pair (address %from_) - (list %txs (pair (address %to_) (pair (nat %token_id) (nat %amount))))))) - (list %iUpdate_operators - (or (pair %add_operator (address %owner) (pair (address %operator) (nat %token_id))) - (pair %remove_operator (address %owner) (pair (address %operator) (nat %token_id)))))) - (pair (pair (pair (pair (pair (address %baker_validator) (option %current_candidate key_hash)) - (pair (option %current_delegated key_hash) (timestamp %last_update_time))) - (pair (pair (timestamp %last_veto) - (big_map %ledger - address - (pair (pair (set %allowances address) (nat %balance)) (nat %frozen_balance)))) - (pair (timestamp %period_finish) (nat %reward)))) - (pair (pair (pair (nat %reward_paid) (nat %reward_per_sec)) - (pair (nat %reward_per_share) (nat %tez_pool))) - (pair (pair (address %token_address) (nat %token_id)) - (pair (nat %token_pool) (nat %total_reward))))) - (pair (pair (pair (nat %total_supply) (nat %total_votes)) - (pair (big_map %user_rewards address (pair (nat %reward) (nat %reward_paid))) - (nat %veto))) - (pair (pair (big_map %vetos key_hash timestamp) - (big_map %voters - address - (pair (pair (option %candidate key_hash) (timestamp %last_veto)) - (pair (nat %veto) (nat %vote))))) - (big_map %votes key_hash nat))))) - address) - (pair (list operation) - (pair (pair (pair (pair (pair (address %baker_validator) (option %current_candidate key_hash)) - (pair (option %current_delegated key_hash) (timestamp %last_update_time))) - (pair (pair (timestamp %last_veto) - (big_map %ledger - address - (pair (pair (set %allowances address) (nat %balance)) (nat %frozen_balance)))) - (pair (timestamp %period_finish) (nat %reward)))) - (pair (pair (pair (nat %reward_paid) (nat %reward_per_sec)) - (pair (nat %reward_per_share) (nat %tez_pool))) - (pair (pair (address %token_address) (nat %token_id)) - (pair (nat %token_pool) (nat %total_reward))))) - (pair (pair (pair (nat %total_supply) (nat %total_votes)) - (pair (big_map %user_rewards address (pair (nat %reward) (nat %reward_paid))) - (nat %veto))) - (pair (pair (big_map %vetos key_hash timestamp) - (big_map %voters - address - (pair (pair (option %candidate key_hash) (timestamp %last_veto)) - (pair (nat %veto) (nat %vote))))) - (big_map %votes key_hash nat))))))))) ; - code { DUP ; - CDR ; - SWAP ; - CAR ; - SELF ; - ADDRESS ; - SWAP ; - IF_LEFT - { IF_LEFT - { IF_LEFT - { DIG 2 ; - PUSH nat 2 ; - PAIR ; - DUG 2 ; - LEFT (list (pair address (list (pair address (pair nat nat))))) ; - LEFT (list (or (pair address (pair address nat)) (pair address (pair address nat)))) ; - DIG 2 ; - DUP ; - CDR ; - SWAP ; - CAR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - GET ; - IF_NONE - { SWAP ; DROP ; SWAP ; DROP ; PUSH string "Dex/function-not-set" ; FAILWITH } - { DIG 3 ; DIG 2 ; DUP ; DUG 3 ; CDR ; CAR ; DIG 4 ; PAIR ; PAIR ; EXEC } ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - PAIR ; - DIG 2 ; - CAR ; - PAIR ; - SWAP ; - CAR ; - PAIR } - { DROP 2 ; - DUP ; - CAR ; - CAR ; - PUSH nat 8 ; - GET ; - IF_NONE - { PUSH string "Dex/function-not-set" ; FAILWITH } - { SELF ; - ADDRESS ; - DIG 2 ; - DUP ; - DUG 3 ; - CDR ; - CAR ; - PUSH nat 0 ; - RIGHT (pair (pair nat nat) nat) ; - LEFT (or nat (pair nat address)) ; - LEFT (or (or (pair (pair nat nat) address) (pair nat address)) - (or (pair (pair key_hash nat) address) address)) ; - PAIR ; - PAIR ; - EXEC } ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - PAIR ; - DIG 2 ; - CAR ; - PAIR ; - SWAP ; - CAR ; - PAIR } } - { IF_LEFT - { SWAP ; - DROP ; - SWAP ; - DUP ; - DUG 2 ; - NIL operation ; - DIG 2 ; - PUSH mutez 0 ; - DIG 4 ; - DUP ; - DUG 5 ; - CDR ; - CAR ; - CAR ; - CDR ; - CDR ; - CDR ; - CAR ; - DIG 5 ; - CDR ; - CAR ; - CAR ; - CDR ; - CAR ; - CDR ; - CDR ; - PAIR ; - TRANSFER_TOKENS ; - CONS ; - PAIR } - { DIG 2 ; - PUSH nat 0 ; - PAIR ; - DUG 2 ; - RIGHT (pair (list (pair address nat)) (contract (list (pair (pair address nat) nat)))) ; - LEFT (list (or (pair address (pair address nat)) (pair address (pair address nat)))) ; - DIG 2 ; - DUP ; - CDR ; - SWAP ; - CAR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - GET ; - IF_NONE - { SWAP ; DROP ; SWAP ; DROP ; PUSH string "Dex/function-not-set" ; FAILWITH } - { DIG 3 ; DIG 2 ; DUP ; DUG 3 ; CDR ; CAR ; DIG 4 ; PAIR ; PAIR ; EXEC } ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - PAIR ; - DIG 2 ; - CAR ; - PAIR ; - SWAP ; - CAR ; - PAIR } } } - { IF_LEFT - { DIG 2 ; - PUSH nat 1 ; - PAIR ; - DUG 2 ; - RIGHT - (or (pair (list (pair address nat)) (contract (list (pair (pair address nat) nat)))) - (list (pair address (list (pair address (pair nat nat)))))) ; - DIG 2 ; - DUP ; - CDR ; - SWAP ; - CAR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - GET ; - IF_NONE - { SWAP ; DROP ; SWAP ; DROP ; PUSH string "Dex/function-not-set" ; FAILWITH } - { DIG 3 ; DIG 2 ; DUP ; DUG 3 ; CDR ; CAR ; DIG 4 ; PAIR ; PAIR ; EXEC } ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - PAIR ; - DIG 2 ; - CAR ; - PAIR ; - SWAP ; - CAR ; - PAIR } - { DIG 2 ; - DUP ; - DUG 3 ; - CAR ; - CAR ; - SWAP ; - DUP ; - DUG 2 ; - IF_LEFT - { IF_LEFT - { IF_LEFT { DROP ; PUSH nat 5 } { DROP ; PUSH nat 0 } } - { IF_LEFT { DROP ; PUSH nat 4 } { DROP ; PUSH nat 1 } } } - { IF_LEFT - { IF_LEFT { DROP ; PUSH nat 2 } { DROP ; PUSH nat 7 } } - { IF_LEFT { DROP ; PUSH nat 6 } { DROP ; PUSH nat 3 } } } ; - GET ; - IF_NONE - { DROP 2 ; PUSH string "Dex/function-not-set" ; FAILWITH } - { DIG 2 ; DIG 3 ; DUP ; DUG 4 ; CDR ; CAR ; DIG 3 ; PAIR ; PAIR ; EXEC } ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - CDR ; - SWAP ; - DUP ; - DUG 2 ; - CDR ; - PAIR ; - DIG 2 ; - CAR ; - PAIR ; - SWAP ; - CAR ; - PAIR } } } } diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml new file mode 100644 index 0000000000..5d0a329485 --- /dev/null +++ b/deku-c/tunac/tests/compile.ml @@ -0,0 +1,26 @@ +let read_all () = + (* FIXME: Doing concat directly results in a segfault ??? *) + let rec aux s = + try aux (input_line stdin :: s) + with End_of_file -> s + in + aux [] + |> List.rev + |> String.concat "\n" + +let contract = + let code = read_all () in + Tunac.parse code + +let save_module wasm_mod = + let output = open_out_bin "mod.wasm" in + let mod_, _ = Binaryen.Module.write wasm_mod None in + output_bytes output mod_; + close_out output + +let _ = + let wasm_mod = Tunac.compile_contract contract in + Binaryen.Module.print wasm_mod; + save_module wasm_mod + + \ No newline at end of file diff --git a/deku-c/tunac/tests/compile_value.ml b/deku-c/tunac/tests/compile_value.ml deleted file mode 100644 index 88fd583112..0000000000 --- a/deku-c/tunac/tests/compile_value.ml +++ /dev/null @@ -1,290 +0,0 @@ -let value = Alcotest.of_pp Tunac.Values.V.pp - -let error : - [ `Parsing_error of Tezos_error_monad.Error_monad.tztrace - | `Prim_parsing_error of Tunac.Parser.MPrim.error - | `Unexpected_error ] - Alcotest.testable = - Alcotest.of_pp (fun _fmt _t -> ()) - -let compile x = Tunac.Compiler.compile_value x |> Result.map snd - -let integers () = - Alcotest.(check @@ result value error) - "Same value" - (Ok (Tunac.Values.V.Int (Z.of_int 42))) - (compile "42") - -(* let tickets () = - Alcotest.(check @@ result value error) - "Same value" - (Ok - Tunac.Values.( - Ticket - { - ticket_id = - { - ticketer = "awdwadwad"; - data = - Bytes.of_seq @@ List.to_seq - @@ List.map Char.chr - [ 5; 1; 0; 0; 0; 5; 104; 101; 108; 108; 111 ]; - }; - amount = Z.one; - })) - (compile "ticket (Pair \"awdwadwad\" 0x05010000000568656c6c6f 1)") *) - -let booleans () = - Alcotest.(check @@ result value error) - "Same value" (Ok (Tunac.Values.Bool 0)) (compile "False"); - Alcotest.(check @@ result value error) - "Same value" (Ok (Tunac.Values.Bool 1)) (compile "True") - -let bytes_ () = - Alcotest.(check @@ result value error) - "Same value" - (Ok (Tunac.Values.V.Bytes (Bytes.of_string "ABC"))) - (compile "0x414243"); - Alcotest.(check @@ result value error) - "Same value" (Ok (Tunac.Values.Bytes Bytes.empty)) (compile "0x") - -let strings () = - Alcotest.(check @@ result value error) - "Same value" (Ok (Tunac.Values.String "Alcotest")) (compile "\"Alcotest\"") - -let unit_ () = - Alcotest.(check @@ result value error) - "Same value" (Ok Tunac.Values.Unit) (compile "Unit") - -let pairs () = - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.(Pair (Bool 1, Int (Z.of_int 42)))) - (compile "(Pair True 42)") - -let unions () = - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.(Union (Left (Int (Z.of_int 13))))) - (compile "(Left 13)"); - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.(Union (Right (Int (Z.of_int 45))))) - (compile "(Right 45)") - -let optionals () = - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.(Option None)) - (compile "None"); - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.V.(Option (Some (String "Hello world")))) - (compile "(Some \"Hello world\")") - -let lists () = - Alcotest.(check @@ result value error) - "Same value" - (Ok Tunac.Values.(List ([], Other))) - (compile "{ }"); - Alcotest.(check @@ result value error) - "Same value" - (Ok - Tunac.Values.( - List ([ Int (Z.of_int 0); Int (Z.of_int 1); Int (Z.of_int 3) ], Other))) - (compile "{ 0; 1; 3 }") - -let maps () = - Alcotest.(check @@ result value error) - "Same value" - (Ok - Tunac.Values.( - Map - (Map.of_seq - (List.to_seq - [ - (Int (Z.of_int 0), String "zero"); - (Int (Z.of_int 1), String "one"); - (Int (Z.of_int 3), String "three"); - ])))) - (compile "{ Elt 0 \"zero\"; Elt 1 \"one\" ; Elt 3 \"three\" }") - -let fa12_storage () = - let unparsed_value = - {| - (Pair - { Elt "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM" - (Pair { Elt "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" 500 } 10000) - ; Elt "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" - (Pair { Elt "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" 1000 } 50000) - ; Elt "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" - (Pair EMPTY_MAP 1000) } - 4000) - |} - in - let expected = - Tunac.Values.( - Pair - ( Map - (Map.of_seq - (List.to_seq - [ - ( String "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM", - Pair - ( Map - (Map.of_seq - (List.to_seq - [ - ( String - "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - Int (Z.of_int 500) ); - ])), - Int (Z.of_int 10000) ) ); - ( String "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - Pair - ( Map - (Map.of_seq - (List.to_seq - [ - ( String - "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK", - Int (Z.of_int 1000) ); - ])), - Int (Z.of_int 50000) ) ); - ( String "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK", - Pair (Map Map.empty, Int (Z.of_int 1000)) ); - ])), - Int (Z.of_int 4000) )) - in - Alcotest.(check @@ result value error) - "Same value" (Ok expected) (compile unparsed_value) - -let fa12_entrypoints () = - let unparsed_value = - {| (Left (Left (Left (Pair "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" 1000)))) |} - in - let expected = - Tunac.Values.( - Union - (Left - (Union - (Left - (Union - (Left - (Pair - ( String "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - Int (Z.of_int 1000) )))))))) - in - Alcotest.(check @@ result value error) - "%%approve" (Ok expected) (compile unparsed_value); - - let unparsed_value = - {| ( Left - ( Left - ( Right - ( Pair - ( Pair "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM" ) - "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" ) ) ) ) |} - in - let expected = - Tunac.Values.( - Union - (Left - (Union - (Left - (Union - (Right - (Pair - ( Pair - ( String "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - String "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM" ), - String "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" )))))))) - in - Alcotest.(check @@ result value error) - "%%getAllowance" (Ok expected) (compile unparsed_value); - - let unparsed_value = - {| - ( Left - ( Right - ( Left - ( Pair "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" ) ) ) ) - |} - in - let expected = - Tunac.Values.( - Union - (Left - (Union - (Right - (Union - (Left - (Pair - ( String "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - String "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" )))))))) - in - Alcotest.(check @@ result value error) - "%%getBalance" (Ok expected) (compile unparsed_value); - - let unparsed_value = - {| - ( Left - ( Right - ( Right - ( Pair Unit "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK" ) ) )) - |} - in - let expected = - Tunac.Values.( - Union - (Left - (Union - (Right - (Union - (Right - (Pair - (Unit, String "KT1WiBZHtvv3EczaN628DkNob4cayHzTEDNK")))))))) - in - Alcotest.(check @@ result value error) - "%%getTotalSupply" (Ok expected) (compile unparsed_value); - - let unparsed_value = - {| ( Right ( Pair "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU" ( Pair "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM" 500 ) ) ) |} - in - let expected = - Tunac.Values.( - Union - (Right - (Pair - ( String "tz1VjdQ5kZpGjk5tH4hADaee9MAd1knsBVSU", - Pair - ( String "tz1gvF4cD2dDtqitL3ZTraggSR1Mju2BKFEM", - Int (Z.of_int 500) ) )))) - in - Alcotest.(check @@ result value error) - "%%transfer" (Ok expected) (compile unparsed_value) - -let () = - let open Alcotest in - run "Compile value" - [ - ( "Values", - [ - test_case "Integers" `Quick integers; - (* test_case "Tickets" `Quick tickets; *) - test_case "Booleans" `Quick booleans; - test_case "Bytes" `Quick bytes_; - test_case "Strings" `Quick strings; - test_case "Unit" `Quick unit_; - test_case "Pairs" `Quick pairs; - test_case "Unions" `Quick unions; - test_case "Optionals" `Quick optionals; - test_case "Lists" `Quick lists; - test_case "Maps" `Quick maps; - ] ); - ( "Complex values", - [ - test_case "FA1.2 storage" `Quick fa12_storage; - test_case "FA1.2 entrypoints" `Quick fa12_entrypoints; - ] ); - ] diff --git a/deku-c/tunac/tests/decookie.t b/deku-c/tunac/tests/decookie.t deleted file mode 100644 index 10849ac7ee..0000000000 --- a/deku-c/tunac/tests/decookie.t +++ /dev/null @@ -1 +0,0 @@ - $ ../bin/tunacc_test.exe contract decookie.tz diff --git a/deku-c/tunac/tests/decookie.tz b/deku-c/tunac/tests/decookie.tz deleted file mode 100644 index b7de6ba4a9..0000000000 --- a/deku-c/tunac/tests/decookie.tz +++ /dev/null @@ -1,37 +0,0 @@ -{ parameter - (pair (or %operation (or (unit %cookie) (unit %cursor)) (unit %grandma)) - (or %operationType (or (unit %eat) (unit %mint)) (unit %transfer))) ; - storage (pair (pair (int %cookies) (int %cursors)) (int %grandmas)) ; - code { UNPAIR ; - CAR ; - IF_LEFT - { IF_LEFT - { DROP ; - PUSH int 1 ; - DUP 2 ; - CAR ; - CAR ; - ADD ; - DUP 2 ; - CDR ; - DIG 2 ; - CAR ; - CDR ; - DIG 2 } - { DROP ; - PUSH int 1 ; - DUP 2 ; - CAR ; - CDR ; - ADD ; - DUP 2 ; - CDR ; - SWAP ; - DIG 2 ; - CAR ; - CAR } ; - PAIR } - { DROP ; PUSH int 1 ; DUP 2 ; CDR ; ADD ; SWAP ; CAR } ; - PAIR ; - NIL operation ; - PAIR } } diff --git a/deku-c/tunac/tests/dune b/deku-c/tunac/tests/dune index de388bad01..3366171bd8 100644 --- a/deku-c/tunac/tests/dune +++ b/deku-c/tunac/tests/dune @@ -1,9 +1,8 @@ -(cram - (deps - ../bin/tunacc_test.exe - ../bin/tunacc_test_operation.exe - (glob_files ./**.tz))) +(executable + (name compile) + (libraries tunac)) -(test - (name compile_value) - (libraries tunac alcotest)) +(rule + (alias runtest) + (action (run node tests.js)) + (deps tests.js compile.exe)) \ No newline at end of file diff --git a/deku-c/tunac/tests/fa12.t b/deku-c/tunac/tests/fa12.t deleted file mode 100644 index c1de8d0ee3..0000000000 --- a/deku-c/tunac/tests/fa12.t +++ /dev/null @@ -1,2 +0,0 @@ -FA1.2 - $ ../bin/tunacc_test.exe contract fa12.tz diff --git a/deku-c/tunac/tests/fa12.tz b/deku-c/tunac/tests/fa12.tz deleted file mode 100644 index b3ab5191a5..0000000000 --- a/deku-c/tunac/tests/fa12.tz +++ /dev/null @@ -1,235 +0,0 @@ -{ parameter - (or (or (or (pair %approve (address %spender) (nat %value)) - (pair %getAllowance (pair (address %owner) (address %spender)) (contract nat))) - (or (pair %getBalance (address %owner) (contract nat)) - (pair %getTotalSupply unit (contract nat)))) - (pair %transfer (address %from) (address %to) (nat %value))) ; - storage - (pair (map %ledger address (pair (map %allowances address nat) (nat %balance))) - (nat %totalSupply)) ; - code { NIL operation ; - LAMBDA - (pair address (map address (pair (map address nat) nat)) nat) - (pair (map address nat) nat) - { UNPAIR ; - SWAP ; - CAR ; - SWAP ; - GET ; - IF_NONE - { UNIT ; PUSH nat 0 ; EMPTY_MAP address nat ; PAIR } - { UNIT ; SWAP } ; - SWAP ; - DROP } ; - LAMBDA - (pair (pair (pair (map address nat) nat) address) - (map address (pair (map address nat) nat)) - nat) - nat - { CAR ; UNPAIR ; CAR ; SWAP ; GET ; IF_NONE { PUSH nat 0 } {} } ; - DIG 3 ; - UNPAIR ; - IF_LEFT - { IF_LEFT - { IF_LEFT - { UNPAIR ; - DUP 3 ; - SENDER ; - PAIR ; - DIG 5 ; - SWAP ; - EXEC ; - DUP 4 ; - DUP 3 ; - DUP 3 ; - PAIR ; - PAIR ; - DIG 5 ; - SWAP ; - EXEC ; - PUSH nat 0 ; - DUP 5 ; - COMPARE ; - GT ; - PUSH nat 0 ; - DIG 2 ; - COMPARE ; - GT ; - AND ; - IF { PUSH string "UnsafeAllowanceChange" ; FAILWITH } {} ; - DUP 4 ; - CDR ; - DIG 4 ; - CAR ; - DUP 3 ; - CDR ; - DIG 3 ; - CAR ; - DIG 5 ; - DIG 5 ; - SWAP ; - SOME ; - SWAP ; - UPDATE ; - PAIR ; - SENDER ; - SWAP ; - SOME ; - SWAP ; - UPDATE ; - PAIR ; - SWAP } - { DIG 4 ; - DROP ; - DUP 2 ; - DUP 2 ; - CAR ; - CAR ; - PAIR ; - DIG 4 ; - SWAP ; - EXEC ; - DUP 3 ; - DUP 3 ; - CAR ; - CDR ; - DIG 2 ; - PAIR ; - PAIR ; - DIG 3 ; - SWAP ; - EXEC ; - DIG 2 ; - NIL operation ; - DIG 3 ; - CDR ; - PUSH mutez 0 ; - DIG 4 ; - TRANSFER_TOKENS ; - CONS } } - { DIG 2 ; - DIG 4 ; - DROP 2 ; - IF_LEFT - { UNPAIR ; - DUP 3 ; - SWAP ; - PAIR ; - DIG 3 ; - SWAP ; - EXEC ; - DIG 2 ; - NIL operation ; - DIG 3 ; - PUSH mutez 0 ; - DIG 4 ; - CDR ; - TRANSFER_TOKENS } - { DIG 2 ; - DROP ; - DUP 2 ; - NIL operation ; - DIG 2 ; - CDR ; - PUSH mutez 0 ; - DIG 4 ; - CDR ; - TRANSFER_TOKENS } ; - CONS } } - { DUP ; - CDR ; - CAR ; - DUP 2 ; - CAR ; - DIG 2 ; - CDR ; - CDR ; - DUP 4 ; - DUP 3 ; - PAIR ; - DUP 7 ; - SWAP ; - EXEC ; - DUP 2 ; - DUP 2 ; - CDR ; - COMPARE ; - LT ; - IF { PUSH string "NotEnoughBalance" ; FAILWITH } {} ; - SENDER ; - DUP 4 ; - COMPARE ; - NEQ ; - IF { DUP 5 ; - SENDER ; - DUP 3 ; - PAIR ; - PAIR ; - DIG 6 ; - SWAP ; - EXEC ; - DUP 3 ; - DUP 2 ; - COMPARE ; - LT ; - IF { PUSH string "NotEnoughAllowance" ; FAILWITH } {} ; - DUP 2 ; - CDR ; - DIG 2 ; - CAR ; - DUP 4 ; - DIG 3 ; - SUB ; - ABS ; - SENDER ; - SWAP ; - SOME ; - SWAP ; - UPDATE ; - PAIR } - { DIG 5 ; DROP } ; - DUP 2 ; - DUP 2 ; - CDR ; - SUB ; - ABS ; - SWAP ; - CAR ; - PAIR ; - DUP 5 ; - CDR ; - DIG 5 ; - CAR ; - DIG 2 ; - DIG 4 ; - SWAP ; - SOME ; - SWAP ; - UPDATE ; - PAIR ; - DUP ; - DUP 4 ; - PAIR ; - DIG 4 ; - SWAP ; - EXEC ; - DIG 2 ; - DUP 2 ; - CDR ; - ADD ; - SWAP ; - CAR ; - PAIR ; - DUP 2 ; - CDR ; - DIG 2 ; - CAR ; - DIG 2 ; - DIG 3 ; - SWAP ; - SOME ; - SWAP ; - UPDATE ; - PAIR ; - SWAP } ; - PAIR } } diff --git a/deku-c/tunac/tests/fa2.t b/deku-c/tunac/tests/fa2.t deleted file mode 100644 index 4f1bd20bb1..0000000000 --- a/deku-c/tunac/tests/fa2.t +++ /dev/null @@ -1,4 +0,0 @@ -Quipuswap FA2 contract - $ ../bin/tunacc_test.exe contract DexFA2.tz - - diff --git a/deku-c/tunac/tests/fa2_no_metadata.tz b/deku-c/tunac/tests/fa2_no_metadata.tz deleted file mode 100644 index 6930ac6e93..0000000000 --- a/deku-c/tunac/tests/fa2_no_metadata.tz +++ /dev/null @@ -1,112 +0,0 @@ -{ parameter - (or (or (pair %balance_of - (list %requests (pair (address %owner) (nat %token_id))) - (contract %callback - (list (pair (pair %request (address %owner) (nat %token_id)) (nat %balance))))) - (list %transfer - (pair (address %from_) (list %txs (pair (address %to_) (nat %token_id) (nat %amount)))))) - (list %update_operators - (or (pair %add_operator (address %owner) (address %operator) (nat %token_id)) - (pair %remove_operator (address %owner) (address %operator) (nat %token_id))))) ; - storage (map address (pair (nat %balance) (set %operators address))) ; - code { EMPTY_SET address ; - PUSH nat 0 ; - PAIR ; - LAMBDA - (pair (pair nat (set address)) (pair address (map address (pair nat (set address))))) - (pair nat (set address)) - { UNPAIR ; SWAP ; UNPAIR ; GET ; IF_NONE {} { SWAP ; DROP } } ; - DUP 2 ; - APPLY ; - DIG 2 ; - UNPAIR ; - IF_LEFT - { IF_LEFT - { DROP 4 ; PUSH string "FA2_NOT_SUPPORTED" ; FAILWITH } - { ITER { SWAP ; - DUP ; - DUP 3 ; - CAR ; - PAIR ; - DUP 4 ; - SWAP ; - EXEC ; - SWAP ; - PAIR ; - DUP 2 ; - CDR ; - ITER { SWAP ; - UNPAIR ; - DUP ; - DUP 4 ; - CAR ; - PAIR ; - DUP 6 ; - SWAP ; - EXEC ; - DUP 4 ; - GET 4 ; - DUP ; - DUP 5 ; - CAR ; - SUB ; - PUSH int 0 ; - DUP 2 ; - COMPARE ; - LT ; - IF { PUSH string "FA2_INSUFFICIENT_BALANCE" ; FAILWITH } {} ; - DIG 4 ; - CDR ; - SWAP ; - ABS ; - PAIR ; - DUP 3 ; - CDR ; - DIG 2 ; - DIG 3 ; - CAR ; - ADD ; - PAIR ; - PUSH nat 0 ; - DUP 5 ; - GET 3 ; - COMPARE ; - NEQ ; - IF { PUSH string "FA2_TOKEN_UNDEFINED" ; FAILWITH } {} ; - SENDER ; - DUP 4 ; - DUP 7 ; - CAR ; - GET ; - IF_NONE { DUP 8 } {} ; - CDR ; - DUP 2 ; - MEM ; - NOT ; - DUP 7 ; - CAR ; - DIG 2 ; - COMPARE ; - NEQ ; - OR ; - IF { PUSH string "FA2_NOT_OPERATOR" ; FAILWITH } {} ; - SWAP ; - DUG 2 ; - SOME ; - DIG 3 ; - CAR ; - UPDATE ; - PAIR } ; - UNPAIR ; - SWAP ; - SOME ; - DIG 2 ; - CAR ; - UPDATE } ; - SWAP ; - DIG 2 ; - DROP 2 ; - NIL operation ; - PAIR } } - { DROP 4 ; PUSH string "FA2_NOT_SUPPORTED" ; FAILWITH } } } - diff --git a/deku-c/tunac/tests/fa2_only_transfer.t b/deku-c/tunac/tests/fa2_only_transfer.t deleted file mode 100644 index c1eea29deb..0000000000 --- a/deku-c/tunac/tests/fa2_only_transfer.t +++ /dev/null @@ -1,3 +0,0 @@ - -FA2 with only transfer semantics - $ ../bin/tunacc_test.exe contract fa2_no_metadata.tz diff --git a/deku-c/tunac/tests/increment.t b/deku-c/tunac/tests/increment.t deleted file mode 100644 index e892615f25..0000000000 --- a/deku-c/tunac/tests/increment.t +++ /dev/null @@ -1,2 +0,0 @@ -Simple increment/decrement contract - $ ../bin/tunacc_test.exe contract increment.tz diff --git a/deku-c/tunac/tests/increment.tz b/deku-c/tunac/tests/increment.tz deleted file mode 100644 index ef2020f34d..0000000000 --- a/deku-c/tunac/tests/increment.tz +++ /dev/null @@ -1 +0,0 @@ -{ parameter (or (or (int %decrement) (int %increment)) (unit %reset)) ; storage int ; code { UNPAIR ; IF_LEFT { IF_LEFT { SWAP ; SUB } { ADD } } { DROP 2 ; PUSH int 0 } ; NIL operation ; PAIR } } diff --git a/deku-c/tunac/tests/increment_originate.t b/deku-c/tunac/tests/increment_originate.t deleted file mode 100644 index 88b824d17b..0000000000 --- a/deku-c/tunac/tests/increment_originate.t +++ /dev/null @@ -1,10 +0,0 @@ -Simple increment/decrement contract - $ ../bin/tunacc_test_operation.exe originate increment.tz "5" - {"operation":"{ \"initial_storage\": [ \"Int\", \"5\" ],\n \"module\":\n \"0061736d0100000001c3808080000d60017e017e60017e0060027e7e017e6000017e60037e7e7e017e60027e7f0060027e7f017e60017e017f60027f7e017e60017f017e60037e7e7e0060017f0060000002e0878080004e03656e76086475705f686f7374000103656e760470616972000203656e7606756e70616972000103656e76057a5f616464000203656e76057a5f737562000203656e76057a5f6d756c000203656e76036e6567000003656e76036c736c000203656e7606636f6e636174000203656e76036c7372000203656e7607636f6d70617265000203656e7603636172000003656e7603636472000003656e7604736f6d65000003656e76036e696c000303656e760474727565000303656e760566616c7365000303656e76046e6f6e65000303656e7604756e6974000303656e76047a65726f000303656e7609656d7074795f6d6170000303656e7609656d7074795f736574000303656e760d656d7074795f6269675f6d6170000303656e760673656e646572000303656e7606736f75726365000303656e76076d61705f676574000203656e76036d656d000203656e7606757064617465000403656e760469746572000503656e76036d6170000603656e760769665f6c656674000703656e760769665f6e6f6e65000703656e760769665f636f6e73000703656e760569736e6174000003656e76036e6f74000003656e76026f72000203656e7603616e64000203656e7603786f72000203656e760a64657265665f626f6f6c000703656e76036e6571000003656e76086661696c77697468000103656e76056765745f6e000803656e760465786563000203656e76056170706c79000203656e7605636f6e7374000903656e7603616273000003656e76026571000003656e76026774000003656e76026c74000003656e7607636c6f73757265000903656e76046c656674000003656e76057269676874000003656e7604636f6e73000203656e760f7472616e736665725f746f6b656e73000403656e760761646472657373000003656e7608636f6e7472616374000003656e760473656c66000303656e760c73656c665f61646472657373000303656e760e6765745f616e645f757064617465000a03656e760b726561645f7469636b6574000103656e76067469636b6574000203656e760c6a6f696e5f7469636b657473000003656e760c73706c69745f7469636b6574000203656e7606616d6f756e74000303656e760762616c616e6365000303656e760465646976000203656e76026765000003656e76026c65000003656e760473697a65000003656e7603696e74000003656e7610696d706c696369745f6163636f756e74000003656e7607626c616b653262000003656e76047061636b000003656e7606756e7061636b000003656e76066b656363616b000003656e7606736861323536000003656e760473686133000003656e76067368613531320000038d808080000c06050b0b0b0c0b0b03010b000485808080000170010000058380808000010004069980808000047f0041000b7f0141a01f0b7f0141e8070b7f00418080020b07c580808000060470757368005703706f700057046d61696e005908636c6f737572657301000d63616c6c5f63616c6c6261636b004e1263616c6c5f63616c6c6261636b5f756e6974004f098680808000010041000b000a80848080000c898080800000200020011100000b898080800000200020011101000bc48080800001037f4100210123012102230220006b22032402034041082303200320016a6a6c4108200220016a6c290300370300200141016a22012000470d000b200220006a24010bc48080800001037f230120006b22022401230221034100210103404108200220016a6c23034108200320016a6c6a290300370300200141016a22012000470d000b200320006a24020b8f80808000004108230120006a6c29030010000b948080800001027e105621001056210120001057200110570bcb8080800002037f017e230120006a210323012201220241086c29030021040340410820016c200241016a220241086c290300370300200141016a210120012003490d000b410820036c20043703000bc28080800002027f017e4108230120006a22016c29030021030340410820016c210220024108200141016b22016c29030037030023012001490d000b410820016c20033703000b958080800001017f4108230122006c290300200041016a24010b978080800001017f4108230141016b22016c2000370300200124010b898080800000230120006a24010bc48080800001017e20001057105610021056101e04401056101e0440105310561056100410570510561056100310570b0541021058101310570b100e1057105610561001105710560b\",\n \"constants\": [],\n \"entrypoints\":\n { \"%decrement\": [ \"Left\", \"Left\" ], \"%increment\": [ \"Left\", \"Right\" ],\n \"%reset\": [ \"Right\" ] } }","tickets":[]} -Simple increment/decrement contract - $ ../bin/tunacc_test_operation.exe "invoke" "DK1NmndDdhkWdWpX7NMArqEjjnWR3xLfM4Kf" "Left (Right 5)" - {"operation":"{ \"address\": \"DK1NmndDdhkWdWpX7NMArqEjjnWR3xLfM4Kf\",\n \"argument\":\n [ \"Union\", [ \"Left\", [ \"Union\", [ \"Right\", [ \"Int\", \"5\" ] ] ] ] ] }","tickets":[]} - -Originate with string - $ ../bin/tunacc_test_operation.exe originate '{ parameter (or (or (int %decrement) (int %increment)) (unit %reset)) ; storage int ; code { UNPAIR ; IF_LEFT { IF_LEFT { SWAP ; SUB } { ADD } } { DROP 2 ; PUSH int 0 } ; NIL operation ; PAIR } }' 5 - {"operation":"{ \"initial_storage\": [ \"Int\", \"5\" ],\n \"module\":\n \"0061736d0100000001c3808080000d60017e017e60017e0060027e7e017e6000017e60037e7e7e017e60027e7f0060027e7f017e60017e017f60027f7e017e60017f017e60037e7e7e0060017f0060000002e0878080004e03656e76086475705f686f7374000103656e760470616972000203656e7606756e70616972000103656e76057a5f616464000203656e76057a5f737562000203656e76057a5f6d756c000203656e76036e6567000003656e76036c736c000203656e7606636f6e636174000203656e76036c7372000203656e7607636f6d70617265000203656e7603636172000003656e7603636472000003656e7604736f6d65000003656e76036e696c000303656e760474727565000303656e760566616c7365000303656e76046e6f6e65000303656e7604756e6974000303656e76047a65726f000303656e7609656d7074795f6d6170000303656e7609656d7074795f736574000303656e760d656d7074795f6269675f6d6170000303656e760673656e646572000303656e7606736f75726365000303656e76076d61705f676574000203656e76036d656d000203656e7606757064617465000403656e760469746572000503656e76036d6170000603656e760769665f6c656674000703656e760769665f6e6f6e65000703656e760769665f636f6e73000703656e760569736e6174000003656e76036e6f74000003656e76026f72000203656e7603616e64000203656e7603786f72000203656e760a64657265665f626f6f6c000703656e76036e6571000003656e76086661696c77697468000103656e76056765745f6e000803656e760465786563000203656e76056170706c79000203656e7605636f6e7374000903656e7603616273000003656e76026571000003656e76026774000003656e76026c74000003656e7607636c6f73757265000903656e76046c656674000003656e76057269676874000003656e7604636f6e73000203656e760f7472616e736665725f746f6b656e73000403656e760761646472657373000003656e7608636f6e7472616374000003656e760473656c66000303656e760c73656c665f61646472657373000303656e760e6765745f616e645f757064617465000a03656e760b726561645f7469636b6574000103656e76067469636b6574000203656e760c6a6f696e5f7469636b657473000003656e760c73706c69745f7469636b6574000203656e7606616d6f756e74000303656e760762616c616e6365000303656e760465646976000203656e76026765000003656e76026c65000003656e760473697a65000003656e7603696e74000003656e7610696d706c696369745f6163636f756e74000003656e7607626c616b653262000003656e76047061636b000003656e7606756e7061636b000003656e76066b656363616b000003656e7606736861323536000003656e760473686133000003656e76067368613531320000038d808080000c06050b0b0b0c0b0b03010b000485808080000170010000058380808000010004069980808000047f0041000b7f0141a01f0b7f0141e8070b7f00418080020b07c580808000060470757368005703706f700057046d61696e005908636c6f737572657301000d63616c6c5f63616c6c6261636b004e1263616c6c5f63616c6c6261636b5f756e6974004f098680808000010041000b000a80848080000c898080800000200020011100000b898080800000200020011101000bc48080800001037f4100210123012102230220006b22032402034041082303200320016a6a6c4108200220016a6c290300370300200141016a22012000470d000b200220006a24010bc48080800001037f230120006b22022401230221034100210103404108200220016a6c23034108200320016a6c6a290300370300200141016a22012000470d000b200320006a24020b8f80808000004108230120006a6c29030010000b948080800001027e105621001056210120001057200110570bcb8080800002037f017e230120006a210323012201220241086c29030021040340410820016c200241016a220241086c290300370300200141016a210120012003490d000b410820036c20043703000bc28080800002027f017e4108230120006a22016c29030021030340410820016c210220024108200141016b22016c29030037030023012001490d000b410820016c20033703000b958080800001017f4108230122006c290300200041016a24010b978080800001017f4108230141016b22016c2000370300200124010b898080800000230120006a24010bc48080800001017e20001057105610021056101e04401056101e0440105310561056100410570510561056100310570b0541021058101310570b100e1057105610561001105710560b\",\n \"constants\": [],\n \"entrypoints\":\n { \"%decrement\": [ \"Left\", \"Left\" ], \"%increment\": [ \"Left\", \"Right\" ],\n \"%reset\": [ \"Right\" ] } }","tickets":[]} diff --git a/deku-c/tunac/tests/nft_auction.t b/deku-c/tunac/tests/nft_auction.t deleted file mode 100644 index e2ce0d2f87..0000000000 --- a/deku-c/tunac/tests/nft_auction.t +++ /dev/null @@ -1,5 +0,0 @@ -NFT Auction - $ ../bin/tunacc_test.exe contract nft_auction.tz - - - diff --git a/deku-c/tunac/tests/nft_auction.tz b/deku-c/tunac/tests/nft_auction.tz deleted file mode 100644 index 67602bfb7f..0000000000 --- a/deku-c/tunac/tests/nft_auction.tz +++ /dev/null @@ -1,159 +0,0 @@ -{ parameter - (or (or (or (pair %auction - (contract %destination - (pair (nat %opening_price) - (nat %set_reserve_price) - (timestamp %set_start_time) - (int %set_round_time) - (ticket %ticket nat))) - (nat %opening_price) - (nat %reserve_price) - (timestamp %start_time) - (int %round_time) - (nat %ticket_id)) - (nat %burn)) - (or (map %mint string bytes) (ticket %receive nat))) - (pair %send (contract %destination (ticket nat)) (nat %ticket_id))) ; - storage - (pair (address %admin) - (big_map %tickets nat (ticket nat)) - (nat %current_id) - (big_map %token_metadata nat (pair nat (map string bytes)))) ; - code { PUSH mutez 0 ; - AMOUNT ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - UNPAIR ; - SWAP ; - UNPAIR 4 ; - DIG 4 ; - IF_LEFT - { IF_LEFT - { IF_LEFT - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 2 ; - NONE (ticket nat) ; - DUP 3 ; - GET 10 ; - GET_AND_UPDATE ; - IF_NONE - { DROP 5 ; PUSH string "no tickets" ; FAILWITH } - { DUP 3 ; - CAR ; - PUSH mutez 0 ; - DIG 2 ; - DUP 5 ; - GET 9 ; - DUP 6 ; - GET 7 ; - DUP 7 ; - GET 5 ; - DIG 7 ; - GET 3 ; - PAIR 5 ; - TRANSFER_TOKENS ; - DIG 4 ; - DIG 4 ; - DIG 3 ; - DIG 4 ; - PAIR 4 ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 4 ; - PUSH nat 1 ; - DIG 5 ; - ADD ; - DIG 4 ; - NONE (ticket nat) ; - DIG 4 ; - UPDATE ; - DIG 3 ; - PAIR 4 ; - NIL operation ; - PAIR } } - { IF_LEFT - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - PUSH nat 1 ; - DUP 5 ; - TICKET ; - DIG 3 ; - SWAP ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - DIG 4 ; - DIG 2 ; - DUP 5 ; - PAIR ; - SOME ; - DUP 5 ; - UPDATE ; - PUSH nat 1 ; - DIG 4 ; - ADD } - { READ_TICKET ; - CDR ; - CDR ; - DIG 3 ; - DIG 2 ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - PUSH nat 1 ; - DIG 2 ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 3 ; - PUSH nat 1 ; - DIG 4 ; - ADD } ; - DIG 2 ; - DIG 3 ; - PAIR 4 ; - NIL operation ; - PAIR } } - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 2 ; - NONE (ticket nat) ; - DUP 3 ; - CDR ; - GET_AND_UPDATE ; - IF_NONE - { DROP 5 ; PUSH string "no tickets" ; FAILWITH } - { DIG 2 ; - CAR ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - DIG 4 ; - DIG 4 ; - DIG 3 ; - DIG 4 ; - PAIR 4 ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } } diff --git a/deku-c/tunac/tests/nft_wallet.t b/deku-c/tunac/tests/nft_wallet.t deleted file mode 100644 index 32e9d28807..0000000000 --- a/deku-c/tunac/tests/nft_wallet.t +++ /dev/null @@ -1,2 +0,0 @@ -NFT Wallet - $ ../bin/tunacc_test.exe contract nft_wallet.tz diff --git a/deku-c/tunac/tests/nft_wallet.tz b/deku-c/tunac/tests/nft_wallet.tz deleted file mode 100644 index 67602bfb7f..0000000000 --- a/deku-c/tunac/tests/nft_wallet.tz +++ /dev/null @@ -1,159 +0,0 @@ -{ parameter - (or (or (or (pair %auction - (contract %destination - (pair (nat %opening_price) - (nat %set_reserve_price) - (timestamp %set_start_time) - (int %set_round_time) - (ticket %ticket nat))) - (nat %opening_price) - (nat %reserve_price) - (timestamp %start_time) - (int %round_time) - (nat %ticket_id)) - (nat %burn)) - (or (map %mint string bytes) (ticket %receive nat))) - (pair %send (contract %destination (ticket nat)) (nat %ticket_id))) ; - storage - (pair (address %admin) - (big_map %tickets nat (ticket nat)) - (nat %current_id) - (big_map %token_metadata nat (pair nat (map string bytes)))) ; - code { PUSH mutez 0 ; - AMOUNT ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - UNPAIR ; - SWAP ; - UNPAIR 4 ; - DIG 4 ; - IF_LEFT - { IF_LEFT - { IF_LEFT - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 2 ; - NONE (ticket nat) ; - DUP 3 ; - GET 10 ; - GET_AND_UPDATE ; - IF_NONE - { DROP 5 ; PUSH string "no tickets" ; FAILWITH } - { DUP 3 ; - CAR ; - PUSH mutez 0 ; - DIG 2 ; - DUP 5 ; - GET 9 ; - DUP 6 ; - GET 7 ; - DUP 7 ; - GET 5 ; - DIG 7 ; - GET 3 ; - PAIR 5 ; - TRANSFER_TOKENS ; - DIG 4 ; - DIG 4 ; - DIG 3 ; - DIG 4 ; - PAIR 4 ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 4 ; - PUSH nat 1 ; - DIG 5 ; - ADD ; - DIG 4 ; - NONE (ticket nat) ; - DIG 4 ; - UPDATE ; - DIG 3 ; - PAIR 4 ; - NIL operation ; - PAIR } } - { IF_LEFT - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - PUSH nat 1 ; - DUP 5 ; - TICKET ; - DIG 3 ; - SWAP ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - DIG 4 ; - DIG 2 ; - DUP 5 ; - PAIR ; - SOME ; - DUP 5 ; - UPDATE ; - PUSH nat 1 ; - DIG 4 ; - ADD } - { READ_TICKET ; - CDR ; - CDR ; - DIG 3 ; - DIG 2 ; - SOME ; - DUP 5 ; - GET_AND_UPDATE ; - DROP ; - PUSH nat 1 ; - DIG 2 ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 3 ; - PUSH nat 1 ; - DIG 4 ; - ADD } ; - DIG 2 ; - DIG 3 ; - PAIR 4 ; - NIL operation ; - PAIR } } - { DUP 2 ; - SENDER ; - COMPARE ; - EQ ; - IF {} { PUSH string "failed assertion" ; FAILWITH } ; - DIG 2 ; - NONE (ticket nat) ; - DUP 3 ; - CDR ; - GET_AND_UPDATE ; - IF_NONE - { DROP 5 ; PUSH string "no tickets" ; FAILWITH } - { DIG 2 ; - CAR ; - PUSH mutez 0 ; - DIG 2 ; - TRANSFER_TOKENS ; - DIG 4 ; - DIG 4 ; - DIG 3 ; - DIG 4 ; - PAIR 4 ; - NIL operation ; - DIG 2 ; - CONS ; - PAIR } } } } diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js new file mode 100644 index 0000000000..c6ab684449 --- /dev/null +++ b/deku-c/tunac/tests/tests.js @@ -0,0 +1,308 @@ +const fs = require('fs') +const child_process = require('child_process') +const assert = require('assert') + +function load(exports, addr, cell) { + return exports.memory[addr / 4 + cell] +} + +function store(exports, addr, cell, value) { + exports.memory[addr / 4 + cell] = value +} + +function alloc(heap, words) { + const addr = heap.value + heap.value = addr + words * 4 + return addr +} + +function car(exports, list) { + return load(exports, list, 0) +} + +function cdr(exports, list) { + return load(exports, list, 1) +} + +function create_pair(exports, fst, snd) { + const addr = alloc(exports.heap, 2) + store(exports, addr, 0, fst) + store(exports, addr, 1, snd) + return addr +} + +function push(exports, value) { + exports.stack.value = create_pair(exports, value, exports.stack.value) +} + +function stack_n(exports, n) { + let stack = exports.stack.value + + while (true) { + if (stack === 0) { return 0 } + + if (n === 0) { + return load(exports, stack, 0) + } + + stack = load(exports, stack, 1) + n-- + } +} + +function stack_top(exports) { + return load(exports, exports.stack.value, 0) +} + +function intToBuffer(int) { + return Buffer.from(new Uint32Array([ int ]).buffer) +} + +function encodeValue(value) { + if (value.int !== undefined) { + return intToBuffer(value.int) + } + + if (value.prim) { + switch (value.prim) { + case 'Unit': + return intToBuffer(0) + case 'Pair': + return Buffer.concat([ + encodeValue(value.args[0]), + encodeValue(value.args[1]) + ]) + case 'Left': + return Buffer.concat([ + intToBuffer(1), + encodeValue(value.args[0]) + ]) + case 'Right': + return Buffer.concat([ + intToBuffer(0), + encodeValue(value.args[0]) + ]) + } + } + + console.log(value) + assert(false) +} + +function inspect_all(exports) { + console.log('Stack pointer ', exports.stack.value) + console.log('Heap pointer ', exports.heap.value) + console.log('Stack') + + let stack = exports.stack.value + while (true) { + if (stack === 0) { + console.log(' -> nil') + break + } + + const value = car(exports, stack) + stack = cdr(exports, stack) + console.log(' ->', value) + } + + console.log('Heap') + for (let i = 512; i <= exports.heap.value; i += 4) { + console.log('%d | %d', i, load(exports, i, 0)) + } +} + +function compileMichelsonCode(code) { + const p = child_process.exec('./compile.exe') + + p.stdin.end(code) + p.stderr.pipe(process.stderr) + + return new Promise((resolve, _) => { + let buf = '' + p.stdout.on('data', chunk => buf += chunk) + p.stdout.on('end', () => { + resolve(Buffer.from(buf)) + }) + }) +} + +async function wasmModuleOfMichelson(code) { + await compileMichelsonCode(code) + const wasm = fs.readFileSync('./mod.wasm') + return WebAssembly.compile(wasm) +} + +async function eval(code, parameter, storage) { + const module = await wasmModuleOfMichelson(code) + + const parameterBuffer = encodeValue({ + prim: 'Pair', + args: [ parameter, storage ], + annots: [] + }) + + let storageBuffer + + const imports = { + env: { + parameter_size() { + return parameterBuffer.length + }, + parameter_load(ptr) { + // console.log('Parameter at %d', ptr) + for (let i = 0; i < parameterBuffer.length; i++) { + bytes[i + ptr] = parameterBuffer[i] + } + + return 0 + }, + save_storage(ptr, size) { + storageBuffer = Buffer.alloc(size) + + for (let i = 0; i < size; i++) { + storageBuffer[i] = bytes[ptr + i] + } + + return 0 + } + } + } + const instance = new WebAssembly.Instance(module, imports) + + const memory = instance.exports.memory.buffer + const bytes = new Uint8Array(memory) + const words = new Uint32Array(memory) + + const exports = { + memory: words, + buffer: memory, + heap: instance.exports.heap_top, + stack: instance.exports.stack + } + + // parameter = encodeValue(exports, parameter) + // storage = encodeValue(exports, storage) + // push(exports, create_pair(exports, parameter, storage)) + + // inspect_all(exports) + instance.exports.main() + // inspect_all(exports) + + return { storage: storageBuffer, exports } +} + +function assertStorage(res, value) { + assert.equal(res.storage.toString('hex'), value) +} + +async function main() { + let res = await eval(` + { parameter unit; storage int; code { CDR; NIL operation; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '2a000000') + + res = await eval(` + { parameter int; storage int; code { UNPAIR; ADD; NIL operation; PAIR } } + `, { int: 13 }, { int: 42 }) + assertStorage(res, '37000000') + + res = await eval(` + { parameter (or (or int int) unit); + storage int; + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + `, { prim: 'Left', args: [ { prim: 'Right', args: [ { int: 13 } ], annots: [] } ], annots: [] }, { int: 42 }) + assertStorage(res, '37000000') + + res = await eval(` + { parameter (or (or int int) unit); + storage int; + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + `, { prim: 'Left', args: [ { prim: 'Left', args: [ { int: 13 } ], annots: [] } ], annots: [] }, { int: 42 }) + assertStorage(res, '1d000000') + + res = await eval(` + { parameter (or (or int int) unit); + storage int; + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + `, { prim: 'Right', args: [ { prim: 'Unit', args: [], annots: [] } ], annots: [] }, { int: 42 }) + assertStorage(res, '00000000') + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIG 2 } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // inspect_all(res.exports) + assert(stack_n(res.exports, 0) === 3) + assert(stack_n(res.exports, 2) === 4) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUG 2 } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) === 4) + assert(stack_n(res.exports, 1) === 3) + assert(stack_n(res.exports, 2) === 5) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 4; PUSH int 5; DROP } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) === 4) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 3; PUSH int 4; PUSH int 5; DROP 2 } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) === 3) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 4; PUSH int 5; DUP } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) === 5) + assert(stack_n(res.exports, 1) === 5) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUP 3 } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) === 3) + assert(stack_n(res.exports, 1) === 5) + + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 2 { PUSH int 7 } } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) == 5) + assert(stack_n(res.exports, 1) == 4) + assert(stack_n(res.exports, 2) == 7) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP { PUSH int 7 } } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) == 5) + assert(stack_n(res.exports, 1) == 7) + assert(stack_n(res.exports, 2) == 4) + + res = await eval(` + { parameter unit; + storage int; + code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 0 { PUSH int 7 } } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert(stack_n(res.exports, 0) == 7) + assert(stack_n(res.exports, 1) == 5) + assert(stack_n(res.exports, 2) == 4) +} + +main() \ No newline at end of file diff --git a/deku-c/tunac/tests/tunac.t b/deku-c/tunac/tests/tunac.t deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/flake.lock b/flake.lock index 06197f73af..522666df7d 100644 --- a/flake.lock +++ b/flake.lock @@ -495,11 +495,11 @@ "nixpkgs": "nixpkgs_6" }, "locked": { - "lastModified": 1666367900, - "narHash": "sha256-//6mUOaLaXfRrr4R+/bD/sKujAKcJ1oGs/uypgr+0ns=", + "lastModified": 1666860743, + "narHash": "sha256-R5XRiZFb0nJxx7Y3gUKiYX58aTzSQroKHrU4+aB9f6I=", "owner": "nix-ocaml", "repo": "nix-overlays", - "rev": "13c2b1372d10d257b1b30cea7bfc0a2af317d572", + "rev": "fa04529f97c16f1fc156230d3e31ab62f6ff2405", "type": "github" }, "original": { @@ -510,17 +510,17 @@ }, "nixpkgs_6": { "locked": { - "lastModified": 1666333455, - "narHash": "sha256-oHXIeLB/sPWxKNcSdV1DQi1ddNVoJ17T1yDiMMeygL4=", + "lastModified": 1666688649, + "narHash": "sha256-i1Tq2VgXbEZKgjM2p2OqZdxcnK4FZjRZ9Oy4Ewx8gjA=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "93e0ac196106dce51878469c9a763c6233af5c57", + "rev": "03a00f66fc4e893dccba1579df6d0c83852e1c2c", "type": "github" }, "original": { "owner": "NixOS", "repo": "nixpkgs", - "rev": "93e0ac196106dce51878469c9a763c6233af5c57", + "rev": "03a00f66fc4e893dccba1579df6d0c83852e1c2c", "type": "github" } }, diff --git a/nix/deku-c/tuna.nix b/nix/deku-c/tuna.nix index 88ccd9752b..4dd8394eca 100644 --- a/nix/deku-c/tuna.nix +++ b/nix/deku-c/tuna.nix @@ -2,17 +2,9 @@ nix-filter, lib, buildDunePackage, - zarith, - ppx_deriving, - ppx_yojson_conv, - yojson, - wasm, - data-encoding, tezos-micheline, - core, - core_unix, - ppx_jane, alcotest, + binaryen, }: buildDunePackage rec { pname = "deku"; @@ -29,19 +21,12 @@ buildDunePackage rec { }; propagatedBuildInputs = [ - zarith - ppx_deriving - ppx_yojson_conv - data-encoding - wasm tezos-micheline + binaryen ]; buildInputs = [ - yojson - core - core_unix - ppx_jane + binaryen ]; checkInputs = [ From d06f701508e9de66d92d0660a16eb90e8723aa5e Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Thu, 27 Oct 2022 14:16:43 -0300 Subject: [PATCH 04/21] move serialization to ocaml --- deku-c/tunac/lib/serialize.ml | 48 ++++++++++++++++++++++ deku-c/tunac/lib/tunac.ml | 3 +- deku-c/tunac/tests/compile.ml | 14 ++++--- deku-c/tunac/tests/tests.js | 77 ++++++++--------------------------- 4 files changed, 75 insertions(+), 67 deletions(-) create mode 100644 deku-c/tunac/lib/serialize.ml diff --git a/deku-c/tunac/lib/serialize.ml b/deku-c/tunac/lib/serialize.ml new file mode 100644 index 0000000000..f40f1558b8 --- /dev/null +++ b/deku-c/tunac/lib/serialize.ml @@ -0,0 +1,48 @@ +open Tezos_micheline +open Micheline +open Michelson_v1_primitives + +let int32_to_bytes n = + let buffer = Bytes.create 4 in + Bytes.set_int32_le buffer 0 n; + buffer + +let rec compile_value node = + match node with + | Int (_, n) -> + int32_to_bytes (Z.to_int32 n) + + | Prim (_, D_Elt, args, _) + | Prim (_, D_Pair, args, _) -> + Bytes.concat Bytes.empty (List.map compile_value args) + + | Prim (_, D_Some, [ arg ], _) + | Prim (_, D_Left, [ arg ], _) -> + Bytes.(cat (int32_to_bytes 1l) (compile_value arg)) + + | Prim (_, D_Right, [ arg ], _) -> + Bytes.(cat (int32_to_bytes 0l) (compile_value arg)) + + | Prim (_, D_None, _, _) + | Prim (_, D_False, [], []) + | Prim (_, D_Unit, [], _) -> + int32_to_bytes 0l + + | Prim (_, D_True, [], []) -> + int32_to_bytes 0xffffffffl + + | Seq (_, lst) -> + let len = Int32.of_int (List.length lst) in + Bytes.(cat + (int32_to_bytes len) + (concat empty (List.map compile_value lst))) + + | String (_, s) -> + let len = Int32.of_int (String.length s) in + Bytes.(cat (int32_to_bytes len) (of_string s)) + + | Bytes (_, s) -> + let len = Int32.of_int (Bytes.length s) in + Bytes.(cat (int32_to_bytes len) s) + + | _ -> assert false diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index 5b5a3823a4..d596d8e570 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -16,5 +16,4 @@ let compile_contract contract = let ir, env = IR_of_michelson.compile_contract contract in Wasm_of_ir.compile_ir ~env ir -let compile_value _node = - Bytes.empty \ No newline at end of file +let compile_value = Serialize.compile_value \ No newline at end of file diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml index 5d0a329485..7689f4a802 100644 --- a/deku-c/tunac/tests/compile.ml +++ b/deku-c/tunac/tests/compile.ml @@ -19,8 +19,12 @@ let save_module wasm_mod = close_out output let _ = - let wasm_mod = Tunac.compile_contract contract in - Binaryen.Module.print wasm_mod; - save_module wasm_mod - - \ No newline at end of file + match Sys.argv.(1) with + | "contract" -> + let wasm_mod = Tunac.compile_contract contract in + Binaryen.Module.print wasm_mod; + save_module wasm_mod + | "value" -> + let value = Tunac.compile_value contract in + print_bytes value + | _ -> assert false diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index c6ab684449..eb36d48370 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -6,16 +6,6 @@ function load(exports, addr, cell) { return exports.memory[addr / 4 + cell] } -function store(exports, addr, cell, value) { - exports.memory[addr / 4 + cell] = value -} - -function alloc(heap, words) { - const addr = heap.value - heap.value = addr + words * 4 - return addr -} - function car(exports, list) { return load(exports, list, 0) } @@ -24,17 +14,6 @@ function cdr(exports, list) { return load(exports, list, 1) } -function create_pair(exports, fst, snd) { - const addr = alloc(exports.heap, 2) - store(exports, addr, 0, fst) - store(exports, addr, 1, snd) - return addr -} - -function push(exports, value) { - exports.stack.value = create_pair(exports, value, exports.stack.value) -} - function stack_n(exports, n) { let stack = exports.stack.value @@ -50,43 +29,27 @@ function stack_n(exports, n) { } } -function stack_top(exports) { - return load(exports, exports.stack.value, 0) -} - -function intToBuffer(int) { - return Buffer.from(new Uint32Array([ int ]).buffer) -} - -function encodeValue(value) { +function michelsonValueToString(value) { if (value.int !== undefined) { - return intToBuffer(value.int) + return value.int.toString() } if (value.prim) { - switch (value.prim) { - case 'Unit': - return intToBuffer(0) - case 'Pair': - return Buffer.concat([ - encodeValue(value.args[0]), - encodeValue(value.args[1]) - ]) - case 'Left': - return Buffer.concat([ - intToBuffer(1), - encodeValue(value.args[0]) - ]) - case 'Right': - return Buffer.concat([ - intToBuffer(0), - encodeValue(value.args[0]) - ]) - } + return '(' + value.prim + + ' ' + value.annots.join(' ') + ' ' + + value.args.map(michelsonValueToString).join(' ') + ')' } +} - console.log(value) - assert(false) +function encodeValue(value) { + return new Promise((resolve, reject) => { + const process = child_process.exec('./compile.exe value', (err, stdout) => { + if (err) return reject(err) + resolve(Buffer.from(stdout)) + }) + + process.stdin.end(michelsonValueToString(value)) + }) } function inspect_all(exports) { @@ -113,7 +76,7 @@ function inspect_all(exports) { } function compileMichelsonCode(code) { - const p = child_process.exec('./compile.exe') + const p = child_process.exec('./compile.exe contract') p.stdin.end(code) p.stderr.pipe(process.stderr) @@ -136,7 +99,7 @@ async function wasmModuleOfMichelson(code) { async function eval(code, parameter, storage) { const module = await wasmModuleOfMichelson(code) - const parameterBuffer = encodeValue({ + const parameterBuffer = await encodeValue({ prim: 'Pair', args: [ parameter, storage ], annots: [] @@ -181,13 +144,7 @@ async function eval(code, parameter, storage) { stack: instance.exports.stack } - // parameter = encodeValue(exports, parameter) - // storage = encodeValue(exports, storage) - // push(exports, create_pair(exports, parameter, storage)) - - // inspect_all(exports) instance.exports.main() - // inspect_all(exports) return { storage: storageBuffer, exports } } From e0f1524e619310ee1b05fcd5bf415a9ab825feb5 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 28 Oct 2022 12:23:19 -0300 Subject: [PATCH 05/21] wip: support for iter, loop and lambda --- deku-c/tunac/lib/iR.ml | 28 ++- deku-c/tunac/lib/iR_of_michelson.ml | 275 ++++++++++++++++++++++++---- 2 files changed, 260 insertions(+), 43 deletions(-) diff --git a/deku-c/tunac/lib/iR.ml b/deku-c/tunac/lib/iR.ml index 9a3a2033cb..9402bc63a8 100644 --- a/deku-c/tunac/lib/iR.ml +++ b/deku-c/tunac/lib/iR.ml @@ -1,4 +1,3 @@ - type var = int [@@deriving show] @@ -42,7 +41,7 @@ type expression = | Cvar of var | Cglobal of global | Cop of operation * expression list - [@@deriving show] +[@@deriving show] type statement = | Cassign of var * expression @@ -52,4 +51,27 @@ type statement = | Ccontinue | Cblock of statement list | Cstore of int * expression * expression -[@@deriving show] \ No newline at end of file + | Cfailwith of expression +[@@deriving show] + +module Data = struct + let alloc size = Cop (Calloc size, []) + + let cons var hd tl = + Cblock + [ Cassign (var, alloc 2) + ; Cstore (0, Cvar var, hd) + ; Cstore (1, Cvar var, tl) ] + + let car expr = Cop (Cload 0, [ expr ]) + + let cdr expr = Cop (Cload 1, [ expr ]) + + let add a b = Cop (Cwasm Wasm_add, [ a; b ]) + + let sub a b = Cop (Cwasm Wasm_sub, [ a; b ]) + + let inc x = add x (Cconst_i32 1l) + + let dec x = sub x (Cconst_i32 1l) +end \ No newline at end of file diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index 7a688511cf..cc45d61f94 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -31,27 +31,16 @@ module Env = struct t.allocated <- Set.remove local t.allocated end - -let list_cons var hd tl = - Cblock - [ Cassign (var, Cop (Calloc 2, [])) - ; Cstore (0, Cvar var, hd) - ; Cstore (1, Cvar var, tl) ] - -let compile_car expr = Cop (Cload 0, [ expr ]) - -let compile_cdr expr = Cop (Cload 1, [ expr ]) - let compile_pop var = Cblock - [ Cassign (var, compile_car (Cglobal "stack")) - ; Cglobal_assign ("stack", compile_cdr (Cglobal "stack")) ] + [ Cassign (var, Data.car (Cglobal "stack")) + ; Cglobal_assign ("stack", Data.cdr (Cglobal "stack")) ] let compile_push ~env expr = let cell = Env.alloc_local env in let block = Cblock - [ list_cons cell expr (Cglobal "stack") + [ Data.cons cell expr (Cglobal "stack") ; Cglobal_assign ("stack", Cvar cell) ] in Env.free_local env cell; @@ -62,7 +51,7 @@ let compile_pair ~env = let item = Env.alloc_local env in let block = Cblock - [ Cassign (cell, Cop (Calloc 2, [])) + [ Cassign (cell, Data.alloc 2) ; compile_pop item ; Cstore (0, Cvar cell, Cvar item) ; compile_pop item @@ -83,16 +72,16 @@ let compile_dig ~env n = ; Cassign (node, Cglobal "stack") ; Cwhile (Cvar counter, Cblock - [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) - ; Cassign (node, compile_cdr (Cvar node)) ]) ] + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] in Env.free_local env counter; let a = Env.alloc_local env in let block = Cblock [ loop - ; Cassign (a, compile_cdr (Cvar node)) - ; Cstore (1, Cvar node, compile_cdr (Cvar a)) + ; Cassign (a, Data.cdr (Cvar node)) + ; Cstore (1, Cvar node, Data.cdr (Cvar a)) ; Cstore (1, Cvar a, Cglobal "stack") ; Cglobal_assign ("stack", Cvar a) ] in @@ -107,11 +96,11 @@ let compile_dug ~env n = let inner_loop = Cblock [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, compile_cdr (Cglobal "stack")) + ; Cassign (node, Data.cdr (Cglobal "stack")) ; Cwhile (Cvar counter, Cblock - [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) - ; Cassign (node, compile_cdr (Cvar node)) ]) ] + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] in Env.free_local env counter; let head = Env.alloc_local env in @@ -119,8 +108,8 @@ let compile_dug ~env n = Cblock [ inner_loop ; Cassign (head, Cglobal "stack") - ; Cglobal_assign ("stack", compile_cdr (Cvar head)) - ; Cstore (1, Cvar head, compile_cdr (Cvar node)) + ; Cglobal_assign ("stack", Data.cdr (Cvar head)) + ; Cstore (1, Cvar head, Data.cdr (Cvar node)) ; Cstore (1, Cvar node, Cvar head) ] in Env.free_local env node; @@ -136,8 +125,8 @@ let compile_drop ~env n = ; Cassign (node, Cglobal "stack") ; Cwhile (Cvar counter, Cblock - [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) - ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ] ) ] in Env.free_local env counter; let block = @@ -158,14 +147,14 @@ let compile_dup ~env n = ; Cassign (node, Cglobal "stack") ; Cwhile (Cvar counter , Cblock - [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) - ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ] ) ] in Env.free_local env counter; let block = Cblock [ inner_loop - ; compile_push ~env (compile_car (Cvar node)) ] + ; compile_push ~env (Data.car (Cvar node)) ] in Env.free_local env node; block @@ -180,8 +169,8 @@ let compile_dip ~env n block = ; Cassign (node, Cglobal "stack") ; Cwhile (Cvar counter , Cblock - [ Cassign (counter, Cop (Cwasm Wasm_sub, [ Cvar counter; Cconst_i32 1l ])) - ; Cassign (node, compile_cdr (Cvar node)) ] ) ] + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ] ) ] in Env.free_local env counter; @@ -193,7 +182,7 @@ let compile_dip ~env n block = ; Cstore (1, Cvar pair, Cvar node) ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_add, [ Cglobal "dip_stack"; Cconst_i32 4l ])) ; Cstore (0, Cglobal "dip_stack", Cvar pair) - ; Cglobal_assign ("stack", compile_cdr (Cvar node)) ] + ; Cglobal_assign ("stack", Data.cdr (Cvar node)) ] in Env.free_local env pair; Env.free_local env node; @@ -203,20 +192,22 @@ let compile_dip ~env n block = let restore_stack = Cblock [ Cassign (pair, Cop (Cload 0, [ Cglobal "dip_stack" ])) - ; Cstore (1, compile_cdr (Cvar pair), Cglobal "stack") - ; Cglobal_assign ("stack", compile_car (Cvar pair)) + ; Cstore (1, Data.cdr (Cvar pair), Cglobal "stack") + ; Cglobal_assign ("stack", Data.car (Cvar pair)) ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_sub, [ Cglobal "dip_stack"; Cconst_i32 4l ] )) ] in Cblock [ inner_loop; save_stack_block; block; restore_stack ] +let lambdas = ref [] + let rec compile_instruction ~env instr = match instr with | Prim (_, I_CAR, _, _) -> let top = Env.alloc_local env in let block = Cblock [ compile_pop top - ; compile_push ~env (compile_car (Cvar top)) ] + ; compile_push ~env (Data.car (Cvar top)) ] in Env.free_local env top; block @@ -225,7 +216,7 @@ let rec compile_instruction ~env instr = let top = Env.alloc_local env in let block = Cblock [ compile_pop top - ; compile_push ~env (compile_cdr (Cvar top)) ] + ; compile_push ~env (Data.cdr (Cvar top)) ] in Env.free_local env top; block @@ -234,8 +225,8 @@ let rec compile_instruction ~env instr = let top = Env.alloc_local env in let block = Cblock [ compile_pop top - ; compile_push ~env (compile_cdr (Cvar top)) - ; compile_push ~env (compile_car (Cvar top)) ] + ; compile_push ~env (Data.cdr (Cvar top)) + ; compile_push ~env (Data.car (Cvar top)) ] in Env.free_local env top; block @@ -271,6 +262,22 @@ let rec compile_instruction ~env instr = | Prim (_, I_PAIR, _, _) -> compile_pair ~env + | Prim (_, I_SOME, _, _) -> + (* TODO: I actually think that optionals may have only one cell allocated *) + let p = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cassign (value, Data.alloc 2) + ; Cstore (0, Cvar value, Cconst_i32 1l) + ; Cstore (1, Cvar value, Cvar p) + ; compile_push ~env (Cvar value) ] + in + Env.free_local env p; + Env.free_local env value; + block + | Prim (_, I_IF_LEFT, [ Seq (_, left_branch); Seq (_, right_branch) ], _) -> let p = Env.alloc_local env in let block = @@ -284,6 +291,51 @@ let rec compile_instruction ~env instr = Env.free_local env p; block + | Prim (_, I_IF, [ Seq (_, branch_if); Seq (_, branch_else) ], _) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cvar p + , Cblock (List.map (compile_instruction ~env) branch_if) + , Cblock (List.map (compile_instruction ~env) branch_else)) ] + in + Env.free_local env p; + block + + | Prim (_, I_IF_CONS, [ Seq (_, branch_cons); Seq (_, branch_nil) ], _) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cvar p + , Cblock + ([ compile_push ~env (Data.cdr (Cvar p)) + ; compile_push ~env (Data.car (Cvar p)) ] + @ List.map (compile_instruction ~env) branch_cons) + , Cblock (List.map (compile_instruction ~env) branch_nil)) ] + in + Env.free_local env p; + block + + | Prim (_, I_IF_NONE, [ Seq (_, branch_none); Seq (_, branch_some) ], _) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cvar p + , Cblock + (compile_push ~env (Data.cdr (Cvar p)) + :: List.map (compile_instruction ~env) branch_some) + , Cblock (List.map (compile_instruction ~env) branch_none)) ] + in + Env.free_local env p; + block + + | Prim (_, I_SWAP, _, _) -> let fst = Env.alloc_local env in let snd = Env.alloc_local env in @@ -297,7 +349,7 @@ let rec compile_instruction ~env instr = Env.free_local env snd; block - | Prim (_, I_PUSH, [ Prim (_, T_int, _, _); Int (_, z) ], _) -> + | Prim (_, I_PUSH, [ _; Int (_, z) ], _) -> let value = Z.to_int32 z in compile_push ~env (Cconst_i32 value) @@ -331,10 +383,118 @@ let rec compile_instruction ~env instr = | Prim (_, I_DIP, [ Seq (_, instr) ], _) -> compile_dip ~env 1l (Cblock (List.map (compile_instruction ~env) instr)) + | Prim (_, I_FAILWITH, _, _) -> + let param = Env.alloc_local env in + Cblock [ compile_pop param; Cfailwith (Cvar param) ] + + | Prim (_, I_ITER, [ Seq (_, body) ], _) -> + let iter = Env.alloc_local env in + let iter_body = Cblock (List.map (compile_instruction ~env) body) in + let block = + Cblock + [ compile_pop iter + ; Cwhile (Cvar iter, + Cblock + [ compile_push ~env (Data.car (Cvar iter)) + ; iter_body + ; Cassign (iter, (Data.cdr (Cvar iter))) ]) ] + in + Env.free_local env iter; + block + + | Prim (_, I_LOOP, [ Seq (_, body) ], _) -> + (* TODO: Test it *) + let p = Env.alloc_local env in + let body = Cblock (List.map (compile_instruction ~env) body) in + let block = + Cblock + [ Cassign (p, Cconst_i32 1l) + ; Cwhile (Cconst_i32 1l, + Cblock + [ compile_pop p + ; body ]) ] + in + Env.free_local env p; + block + + | Prim (_, I_LOOP_LEFT, [ Seq (_, body) ], _) -> + (* TODO: Test it *) + let p = Env.alloc_local env in + let body = Cblock (List.map (compile_instruction ~env) body) in + Cblock + [ Cassign (p, Cconst_i32 1l) + ; Cwhile (Cvar p, + Cblock + [ compile_pop p + ; compile_push ~env (Data.cdr (Cvar p)) + ; Cifthenelse + (Cop (Cload 0, [ Cvar p ]) + , Cblock [ body ] + , Cblock []) ]) + ; Cassign (p, Data.car (Cvar p)) ] + + | Prim (_, I_LAMBDA, [ _; _; Seq (_, body) ], _) -> + let lenv = Env.make () in + let body = Cblock (List.map (compile_instruction ~env:lenv) body) in + let lambda_n = Int32.of_int (List.length !lambdas) in + lambdas := (body, env) :: !lambdas; + let p = Env.alloc_local env in + let block = + Cblock + [ Cassign (p, Data.alloc 2) + ; Cstore (0, Cvar p, Cconst_i32 0l) + ; Cstore (1, Cvar p, Cconst_i32 lambda_n) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + block + + | Prim (_, I_APPLY, _, _) -> + let top = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + Cblock + [ Cassign (value, Data.alloc 3) + ; Cstore (0, Cvar value, Cconst_i32 1l) + ; compile_pop top + ; Cstore (2, Cvar value, Cvar top) + ; compile_pop top + ; Cstore (1, Cvar value, Cvar top) ] + in + Env.free_local env value; + Env.free_local env top; + block + + | Prim (_, I_EXEC, _, _) -> + (* Layout: + 0x0 + 0x1 *) + let argument = Env.alloc_local env in + let lambda = Env.alloc_local env in + let pair = Env.alloc_local env in + let block = + Cblock + [ compile_pop argument + ; compile_pop lambda + ; Cwhile (Data.car (Cvar lambda), + Cblock + [ Cassign (pair, Data.alloc 2) + ; Cstore (0, Cvar pair, Cop (Cload 2, [ Cvar lambda ])) + ; Cstore (1, Cvar pair, Cvar argument) + ; Cassign (lambda, Data.cdr (Cvar lambda)) + ; Cassign (argument, Cvar pair) ]) + ; Cassign (-1, Cop (Capply "exec", [ Cvar lambda; Cvar argument ])) ] + in + Env.free_local env argument; + Env.free_local env lambda; + Env.free_local env pair; + block + | _ -> assert false let rec compile_value_decoder ~env typ var ptr = match typ with + | Prim (_, T_bool, _, _) | Prim (_, T_nat, _, _) | Prim (_, T_int, _, _) | Prim (_, T_unit, _, _) -> @@ -357,6 +517,41 @@ let rec compile_value_decoder ~env typ var ptr = Env.free_local env wrapped_value; block + | Prim (_, T_list, [ typ ], _) -> + let counter = Env.alloc_local env in + let value = Env.alloc_local env in + let tmp = Env.alloc_local env in + let block = + Cblock + [ Cassign (var, Cconst_i32 0l) + ; Cassign (counter, Cop (Cload 0, [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) + ; Cwhile (Cvar counter, + Cblock + [ compile_value_decoder ~env typ value ptr + (* TODO: I'm not sure if I need this tmp local *) + ; Data.cons tmp (Cvar value) (Cvar var) + ; Cassign (var, Cvar tmp) + ; Cassign (counter, Data.dec (Cvar counter)) ]) ] + in + Env.free_local env counter; + Env.free_local env value; + Env.free_local env tmp; + block + + | Prim (_, T_option, [ typ ], _) -> + let value = Env.alloc_local env in + Cblock + [ Cassign (value, Cop (Cload 0, [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) + ; Cifthenelse (Cvar value, + Cblock + [ Cassign (var, Data.alloc 2) + ; Cstore (0, Cvar var, Cvar value) + ; compile_value_decoder ~env typ value ptr + ; Cstore (1, Cvar var, Cvar value) ], + Cassign (var, Cvar value)) ] + | _ -> assert false let compile_value_encoder ~env:_ typ ptr size value = @@ -399,7 +594,7 @@ let compile_contract contract = let size = Env.alloc_local env in let value = Env.alloc_local env in let block = - [ Cassign (value, compile_cdr (compile_car (Cglobal "stack"))) + [ Cassign (value, Data.cdr (Data.car (Cglobal "stack"))) ; compile_value_encoder ~env storage_type ptr size value ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] in From b75311a624c55766c03c367cfca65fd87e8a0cce Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 28 Oct 2022 12:23:46 -0300 Subject: [PATCH 06/21] fix list serialization --- deku-c/tunac/lib/serialize.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deku-c/tunac/lib/serialize.ml b/deku-c/tunac/lib/serialize.ml index f40f1558b8..3a1550598c 100644 --- a/deku-c/tunac/lib/serialize.ml +++ b/deku-c/tunac/lib/serialize.ml @@ -35,7 +35,7 @@ let rec compile_value node = let len = Int32.of_int (List.length lst) in Bytes.(cat (int32_to_bytes len) - (concat empty (List.map compile_value lst))) + (concat empty (List.(map compile_value (rev lst))))) | String (_, s) -> let len = Int32.of_int (String.length s) in From 95a2fc2d965421faac60f21a397003fbba77ce63 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 28 Oct 2022 12:24:02 -0300 Subject: [PATCH 07/21] fine grained config --- deku-c/tunac/lib/tunac.ml | 14 ++++++++++++-- deku-c/tunac/lib/tunac.mli | 7 ++++++- deku-c/tunac/lib/wasm_of_ir.ml | 28 +++++++++++++++++++--------- 3 files changed, 37 insertions(+), 12 deletions(-) diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index d596d8e570..f69cf0413a 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -3,6 +3,11 @@ type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node type contract = node +type config = + { debug : bool + ; shared_memory : bool + ; optimize : bool } + let parse code = let open Tezos_micheline in let tokens, _ = Micheline_parser.tokenize code in @@ -12,8 +17,13 @@ let parse code = |> Micheline.map (fun prim -> Michelson_v1_primitives.prim_of_string prim |> Result.get_ok) |> Micheline.root -let compile_contract contract = +let compile_contract ~config contract = let ir, env = IR_of_michelson.compile_contract contract in - Wasm_of_ir.compile_ir ~env ir + Wasm_of_ir.compile_ir + ~optimize:config.optimize + ~debug:config.debug + ~shared_memory:config.shared_memory + ~env + ir let compile_value = Serialize.compile_value \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.mli b/deku-c/tunac/lib/tunac.mli index 8c7d4af920..fc9e16a9b0 100644 --- a/deku-c/tunac/lib/tunac.mli +++ b/deku-c/tunac/lib/tunac.mli @@ -3,8 +3,13 @@ type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node type contract = node +type config = + { debug : bool + ; shared_memory : bool + ; optimize : bool } + val parse : string -> contract -val compile_contract : contract -> Binaryen.Module.t +val compile_contract : config:config -> contract -> Binaryen.Module.t val compile_value : node -> bytes \ No newline at end of file diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index 5f9c2d29b3..bc495cd3f8 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -98,11 +98,16 @@ let rec compile_statement wasm_mod statement = loop_stack := List.tl !loop_stack; loop + | Cfailwith param -> + Expression.Block.make wasm_mod (gensym "failwith") + [ Expression.Call.make wasm_mod "failwith" [ compile_expression wasm_mod param ] Type.none + ; Expression.Unreachable.make wasm_mod ] + | Ccontinue -> (* WASM break on loops works more like a continue than a break *) Expression.Break.make wasm_mod (List.hd !loop_stack) (Expression.Null.make ()) (Expression.Null.make ()) -let compile_ir ~env ast = +let compile_ir ~optimize ~debug ~shared_memory ~env ast = let wasm_mod = Module.create () in let locals = Array.make (IR_of_michelson.Env.max env + 1) Type.int32 in @@ -115,26 +120,31 @@ let compile_ir ~env ast = ignore @@ Global.add_global wasm_mod "stack" Type.int32 true - (Expression.Const.make wasm_mod (Literal.int32 0l)); - ignore @@ Export.add_global_export wasm_mod "stack" "stack"; - + (Expression.Const.make wasm_mod (Literal.int32 0l)); ignore @@ Global.add_global wasm_mod "heap_top" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 512l)); - ignore @@ - Export.add_global_export wasm_mod "heap_top" "heap_top"; ignore @@ Global.add_global wasm_mod "dip_stack" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 256l)); + if debug then begin + ignore @@ Export.add_global_export wasm_mod "stack" "stack"; + ignore @@ Export.add_global_export wasm_mod "heap_top" "heap_top"; + end; + Import.add_function_import wasm_mod "parameter_size" "env" "parameter_size" Type.none Type.int32; Import.add_function_import wasm_mod "parameter_load" "env" "parameter_load" Type.int32 Type.int32; Import.add_function_import wasm_mod "save_storage" "env" "save_storage" Type.(create [| int32; int32 |]) Type.int32; + Import.add_function_import wasm_mod "failwith" "env" "failwith" Type.int32 Type.none; + + Memory.set_memory wasm_mod 1 10 "memory" [] shared_memory; - Memory.set_memory wasm_mod 1 10 "memory" [] true; + (* if Module.validate wasm_mod <> 0 then + failwith "Generated module is invalid"; *) - if Module.validate wasm_mod <> 0 then - failwith "Generated module is invalid"; + if optimize then + Module.optimize wasm_mod; wasm_mod \ No newline at end of file From 29073a75f6b634c6a5f2e0127059be2bdcee0585 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 28 Oct 2022 12:29:33 -0300 Subject: [PATCH 08/21] add cmdliner and customize options --- deku-c/tunac/tests/compile.ml | 58 ++++++++++++++++++----- deku-c/tunac/tests/dune | 2 +- deku-c/tunac/tests/tests.js | 87 ++++++++++++++++++++++++++++++----- 3 files changed, 124 insertions(+), 23 deletions(-) diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml index 7689f4a802..8a7cad11f4 100644 --- a/deku-c/tunac/tests/compile.ml +++ b/deku-c/tunac/tests/compile.ml @@ -12,19 +12,55 @@ let contract = let code = read_all () in Tunac.parse code -let save_module wasm_mod = - let output = open_out_bin "mod.wasm" in +let save_module wasm_mod filename = + let output = open_out_bin filename in let mod_, _ = Binaryen.Module.write wasm_mod None in output_bytes output mod_; close_out output -let _ = - match Sys.argv.(1) with - | "contract" -> - let wasm_mod = Tunac.compile_contract contract in +open Cmdliner + +let compile_contract print debug optimize shared_memory output = + let config = Tunac.{ debug; shared_memory; optimize } in + let wasm_mod = Tunac.compile_contract ~config contract in + if print then Binaryen.Module.print wasm_mod; - save_module wasm_mod - | "value" -> - let value = Tunac.compile_value contract in - print_bytes value - | _ -> assert false + save_module wasm_mod output + +let compile_value () = + let value = Tunac.compile_value contract in + print_bytes value + +let debug = + Arg.(value & flag & info [ "debug" ]) + +let optimize = + Arg.(value & flag & info [ "optimize" ]) + +let shared_memory = + Arg.(value & flag & info [ "shared-memory" ]) + +let print = + Arg.(value & flag & info [ "print" ]) + +let output = + Arg.(required & opt (some string) None & info [ "o"; "output" ]) + +let contract_cmd = + Cmd.v (Cmd.info "contract") + Term.( + const compile_contract + $ print + $ debug + $ optimize + $ shared_memory + $ output) + +let value_cmd = + Cmd.v (Cmd.info "value") Term.(const compile_value $ const ()) + +let compile_cmd = + Cmd.group (Cmd.info "compile") [ contract_cmd; value_cmd ] + +let () = + exit (Cmd.eval compile_cmd) \ No newline at end of file diff --git a/deku-c/tunac/tests/dune b/deku-c/tunac/tests/dune index 3366171bd8..4a2dddba1c 100644 --- a/deku-c/tunac/tests/dune +++ b/deku-c/tunac/tests/dune @@ -1,6 +1,6 @@ (executable (name compile) - (libraries tunac)) + (libraries tunac cmdliner)) (rule (alias runtest) diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index eb36d48370..b3b721f213 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -39,6 +39,10 @@ function michelsonValueToString(value) { ' ' + value.annots.join(' ') + ' ' + value.args.map(michelsonValueToString).join(' ') + ')' } + + if (Array.isArray(value)) { + return '{ ' + value.map(michelsonValueToString).join('; ') + ' }' + } } function encodeValue(value) { @@ -76,17 +80,18 @@ function inspect_all(exports) { } function compileMichelsonCode(code) { - const p = child_process.exec('./compile.exe contract') - - p.stdin.end(code) - p.stderr.pipe(process.stderr) + return new Promise((resolve, reject) => { + const p = child_process.exec( + './compile.exe contract --debug --output mod.wasm', + (err) => { + if (err) return reject(err) + resolve() + } + ) - return new Promise((resolve, _) => { - let buf = '' - p.stdout.on('data', chunk => buf += chunk) - p.stdout.on('end', () => { - resolve(Buffer.from(buf)) - }) + p.stdin.end(code) + p.stderr.pipe(process.stderr) + p.stdout.pipe(process.stdout) }) } @@ -106,6 +111,7 @@ async function eval(code, parameter, storage) { }) let storageBuffer + let failure = null const imports = { env: { @@ -128,6 +134,9 @@ async function eval(code, parameter, storage) { } return 0 + }, + failwith(arg) { + failure = arg } } } @@ -146,7 +155,7 @@ async function eval(code, parameter, storage) { instance.exports.main() - return { storage: storageBuffer, exports } + return { storage: storageBuffer, exports, failure } } function assertStorage(res, value) { @@ -260,6 +269,62 @@ async function main() { assert(stack_n(res.exports, 0) == 7) assert(stack_n(res.exports, 1) == 5) assert(stack_n(res.exports, 2) == 4) + + + // try { + // await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 42; FAILWITH } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(false) + // } catch (e) { + // console.log(e) + // } + + res = await eval(` + { parameter bool; storage int; code { CAR; IF { PUSH int 42 } { PUSH int 50 }; NIL operation; PAIR } } + `, { prim: 'True', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '2a000000') + + res = await eval(` + { parameter bool; storage int; code { CAR; IF { PUSH int 42 } { PUSH int 50 }; NIL operation; PAIR } } + `, { prim: 'False', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '32000000') + + res = await eval(` + { parameter (list int); storage int; code { CAR; IF_CONS { SWAP; DROP } { PUSH int 50 }; NIL operation; PAIR } } + `, [ { int: 42 } ], { int: 42 }) + assertStorage(res, '2a000000') + + res = await eval(` + { parameter (list int); storage int; code { CAR; IF_CONS { } { PUSH int 50 }; NIL operation; PAIR } } + `, [], { int: 42 }) + assertStorage(res, '32000000') + + res = await eval(` + { parameter (option int); storage int; code { CAR; IF_NONE { PUSH int 50 } { }; NIL operation; PAIR } } + `, { prim: 'Some', args: [ { int: 42 } ], annots: [] }, { int: 42 }) + assertStorage(res, '2a000000') + + res = await eval(` + { parameter (option int); storage int; code { CAR; IF_NONE { PUSH int 50 } { }; NIL operation; PAIR } } + `, { prim: 'None', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '32000000') + + res = await eval(` + { parameter (list int) ; + storage int ; + code { CAR ; PUSH int 0 ; SWAP ; ITER { ADD } ; NIL operation ; PAIR } } + `, [], { int: 42 }) + assertStorage(res, '00000000') + + res = await eval(` + { parameter (list int) ; + storage int ; + code { CAR ; PUSH int 0 ; SWAP ; ITER { ADD } ; NIL operation ; PAIR } } + `, [ { int: 1 }, { int: 2 }, { int: 3 }, { int: 4 }, { int: 5 } ], { int: 42 }) + assertStorage(res, '0f000000') } main() \ No newline at end of file From 3f900b9f18cea4e47f748a43d87ee233ddc1830c Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 28 Oct 2022 15:13:47 -0300 Subject: [PATCH 09/21] customize memory parameter and improve error reporting --- deku-c/tunac/lib/iR_of_michelson.ml | 52 ++++++++++++---- deku-c/tunac/lib/tunac.ml | 33 ++++++++-- deku-c/tunac/lib/tunac.mli | 3 +- deku-c/tunac/lib/wasm_of_ir.ml | 97 ++++++++++++++++++++++------- deku-c/tunac/tests/compile.ml | 10 ++- 5 files changed, 154 insertions(+), 41 deletions(-) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index cc45d61f94..e9e7443ea7 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -3,6 +3,24 @@ open Micheline open Michelson_v1_primitives open IR +type node = (int, Michelson_v1_primitives.prim) Micheline.node + +type error = + | Invalid_contract_format + | Unsupported_instruction of node + | Unsupported_parameter_type of node + | Unsupported_storage_type of node + +exception Compilation_error of error + +type function_ = + { body : statement + ; locals : int } + +type contract = + { main : function_ + ; lambdas : (int * function_) list } + module Env = struct module Set = Set.Make(Int) @@ -16,11 +34,8 @@ module Env = struct let rec aux reg = if Set.mem reg t.allocated then aux (reg + 1) - else if reg > t.max then ( - t.max <- reg; - t.allocated <- Set.add reg t.allocated; - reg - ) else ( + else ( + t.max <- Int.max reg t.max; t.allocated <- Set.add reg t.allocated; reg ) @@ -483,14 +498,15 @@ let rec compile_instruction ~env instr = ; Cstore (1, Cvar pair, Cvar argument) ; Cassign (lambda, Data.cdr (Cvar lambda)) ; Cassign (argument, Cvar pair) ]) - ; Cassign (-1, Cop (Capply "exec", [ Cvar lambda; Cvar argument ])) ] + ; compile_push ~env (Cvar argument) + ; Cassign (-1, Cop (Capply "exec", [ Cvar lambda ])) ] in Env.free_local env argument; Env.free_local env lambda; Env.free_local env pair; block - | _ -> assert false + | instr -> raise (Compilation_error (Unsupported_instruction instr)) let rec compile_value_decoder ~env typ var ptr = match typ with @@ -552,7 +568,7 @@ let rec compile_value_decoder ~env typ var ptr = ; Cstore (1, Cvar var, Cvar value) ], Cassign (var, Cvar value)) ] - | _ -> assert false + | typ -> raise (Compilation_error (Unsupported_parameter_type typ)) let compile_value_encoder ~env:_ typ ptr size value = match typ with @@ -562,7 +578,7 @@ let compile_value_encoder ~env:_ typ ptr size value = ; Cstore (0, Cvar ptr, Cvar value) ; Cassign (size, Cconst_i32 4l) ] - | _ -> assert false + | typ -> raise (Compilation_error (Unsupported_storage_type typ)) let compile_contract contract = let env = Env.make () in @@ -604,5 +620,19 @@ let compile_contract contract = block in - Cblock (param_block :: List.map (compile_instruction ~env) code @ store_block), env - | _ -> assert false \ No newline at end of file + let main = + { body = Cblock (param_block :: List.map (compile_instruction ~env) code @ store_block) + ; locals = Env.max env + 1 } + in + let lambdas = + !lambdas + |> List.rev + |> List.mapi (fun idx (body, env) -> (idx, { body; locals = Env.max env + 1 })) + in + { main; lambdas } + + | _ -> raise (Compilation_error Invalid_contract_format) + +let compile_contract contract = + try Ok (compile_contract contract) + with Compilation_error err -> Error err diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index f69cf0413a..1cb761c8fa 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -6,7 +6,8 @@ type contract = node type config = { debug : bool ; shared_memory : bool - ; optimize : bool } + ; optimize : bool + ; memory : int * int } let parse code = let open Tezos_micheline in @@ -17,13 +18,37 @@ let parse code = |> Micheline.map (fun prim -> Michelson_v1_primitives.prim_of_string prim |> Result.get_ok) |> Micheline.root +let print_node fmt node = + let open Tezos_micheline in + node + |> Micheline.strip_locations + |> Micheline_printer.printable Michelson_v1_primitives.string_of_prim + |> Micheline_printer.print_expr fmt + +let report error = + let open IR_of_michelson in + let open Format in + match error with + | Invalid_contract_format -> + print_endline "Invalid contract format" + | Unsupported_instruction instr -> + printf "Unsupported Michelson instruction: %a\n" print_node instr + | Unsupported_parameter_type typ -> + printf "Unsupported parameter type: %a\n" print_node typ + | Unsupported_storage_type typ -> + printf "Unsupported storage type: %a\n" print_node typ + +(* TODO: Return result instead of exit *) +let report_error = function + Ok c -> c | Error err -> report err; exit 1 + let compile_contract ~config contract = - let ir, env = IR_of_michelson.compile_contract contract in + let contract = report_error @@ IR_of_michelson.compile_contract contract in Wasm_of_ir.compile_ir + ~memory:config.memory ~optimize:config.optimize ~debug:config.debug ~shared_memory:config.shared_memory - ~env - ir + contract let compile_value = Serialize.compile_value \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.mli b/deku-c/tunac/lib/tunac.mli index fc9e16a9b0..b6821b91af 100644 --- a/deku-c/tunac/lib/tunac.mli +++ b/deku-c/tunac/lib/tunac.mli @@ -6,7 +6,8 @@ type contract = node type config = { debug : bool ; shared_memory : bool - ; optimize : bool } + ; optimize : bool + ; memory : int * int } val parse : string -> contract diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index bc495cd3f8..5c01a51235 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -13,7 +13,6 @@ let rec compile_expression wasm_mod expr = | Cconst_i32 value -> Expression.Const.make wasm_mod (Literal.int32 value) | Cop (op, params) -> compile_operation wasm_mod op params - and compile_operation wasm_mod op params = match op, params with | Capply name, params -> Expression.Call.make wasm_mod name (List.map (compile_expression wasm_mod) params) Type.int32 @@ -38,21 +37,43 @@ and compile_operation wasm_mod op params = ; Expression.Local_get.make wasm_mod 0 Type.int32 ] | Cwasm wasm_operation, params -> compile_wasm_operation wasm_mod wasm_operation params - | _ -> assert false + | _ -> failwith "Invalid operation format, check operation arguments." and compile_wasm_operation wasm_mod operation params = + let op2 op x y = + Expression.Binary.make wasm_mod op + (compile_expression wasm_mod x) + (compile_expression wasm_mod y) + in + let op1 op x = + Expression.Unary.make wasm_mod op (compile_expression wasm_mod x) + in match operation, params with - | Wasm_add, [ a; b ] -> - Expression.Binary.make wasm_mod Op.add_int32 - (compile_expression wasm_mod a) - (compile_expression wasm_mod b) - - | Wasm_sub, [ a; b ] -> - Expression.Binary.make wasm_mod Op.sub_int32 - (compile_expression wasm_mod a) - (compile_expression wasm_mod b) - - | _ -> assert false + | Wasm_add, [ a; b ] -> op2 Op.add_int32 a b + | Wasm_sub, [ a; b ] -> op2 Op.sub_int32 a b + | Wasm_mul, [ a; b ] -> op2 Op.mul_int32 a b + | Wasm_div, [ a; b ] -> op2 Op.div_s_int32 a b + | Wasm_rem, [ a; b ] -> op2 Op.rem_s_int32 a b + | Wasm_and, [ a; b ] -> op2 Op.and_int32 a b + | Wasm_or, [ a; b ] -> op2 Op.or_int32 a b + | Wasm_xor, [ a; b ] -> op2 Op.xor_int32 a b + | Wasm_eq, [ a; b ] -> op2 Op.eq_int32 a b + | Wasm_ne, [ a; b ] -> op2 Op.ne_int32 a b + | Wasm_lt, [ a; b ] -> op2 Op.lt_s_int32 a b + | Wasm_gt, [ a; b ] -> op2 Op.gt_s_int32 a b + | Wasm_le, [ a; b ] -> op2 Op.le_s_int32 a b + | Wasm_ge, [ a; b ] -> op2 Op.ge_s_int32 a b + | Wasm_shl, [ a; b ] -> op2 Op.shl_int32 a b + | Wasm_shr, [ a; b ] -> op2 Op.shr_s_int32 a b + | Wasm_rotl, [ a; b ] -> op2 Op.rot_l_int32 a b + | Wasm_rotr, [ a; b ] -> op2 Op.rot_r_int32 a b + + | Wasm_clz, [ a ] -> op1 Op.clz_int32 a + | Wasm_ctz, [ a ] -> op1 Op.ctz_int32 a + | Wasm_popcnt, [ a ] -> op1 Op.popcnt_int32 a + | Wasm_eqz, [ a ] -> op1 Op.eq_z_int32 a + + | _ -> failwith "Invalid WASM operation" let loop_stack = ref [] @@ -107,16 +128,47 @@ let rec compile_statement wasm_mod statement = (* WASM break on loops works more like a continue than a break *) Expression.Break.make wasm_mod (List.hd !loop_stack) (Expression.Null.make ()) (Expression.Null.make ()) -let compile_ir ~optimize ~debug ~shared_memory ~env ast = +let add_function wasm_mod name fn = + let IR_of_michelson.{ body; locals } = fn in + let locals = Array.make locals Type.int32 in + let expr = compile_statement wasm_mod body in + ignore @@ Function.add_function wasm_mod name Type.none Type.none locals expr; + ignore @@ Export.add_function_export wasm_mod name name + +let compile_exec_function wasm_mod lambdas = + let rec aux lambdas = + match lambdas with + | (idx, _) :: lambdas -> + Expression.If.make wasm_mod + (Expression.Binary.make wasm_mod Op.eq_int32 + (Expression.Local_get.make wasm_mod 0 Type.int32) + (Expression.Const.make wasm_mod (Literal.int32 (Int32.of_int idx)))) + (Expression.Call.make wasm_mod (Printf.sprintf "lambda_%d" idx) [] Type.none) + (aux lambdas) + | [] -> Expression.Nop.make wasm_mod + in + let body = aux lambdas in + ignore @@ + Function.add_function wasm_mod "exec" + Type.(create [| int32 |]) + Type.none + [||] + body + +let compile_ir ~memory ~optimize ~debug ~shared_memory contract = let wasm_mod = Module.create () in - let locals = Array.make (IR_of_michelson.Env.max env + 1) Type.int32 in - let expr = compile_statement wasm_mod ast in - - ignore @@ - Function.add_function wasm_mod "main" Type.none Type.none locals expr; - ignore @@ - Export.add_function_export wasm_mod "main" "main"; + let IR_of_michelson.{ main; lambdas } = contract in + add_function wasm_mod "main" main; + + if lambdas <> [] then + begin + List.iter + (fun (idx, fn) -> + add_function wasm_mod (Printf.sprintf "lambda_%d" idx) fn) + lambdas; + compile_exec_function wasm_mod lambdas; + end; ignore @@ Global.add_global wasm_mod "stack" Type.int32 true @@ -139,7 +191,8 @@ let compile_ir ~optimize ~debug ~shared_memory ~env ast = Import.add_function_import wasm_mod "save_storage" "env" "save_storage" Type.(create [| int32; int32 |]) Type.int32; Import.add_function_import wasm_mod "failwith" "env" "failwith" Type.int32 Type.none; - Memory.set_memory wasm_mod 1 10 "memory" [] shared_memory; + let (initial, max) = memory in + Memory.set_memory wasm_mod initial max "memory" [] shared_memory; (* if Module.validate wasm_mod <> 0 then failwith "Generated module is invalid"; *) diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml index 8a7cad11f4..66ce0553e8 100644 --- a/deku-c/tunac/tests/compile.ml +++ b/deku-c/tunac/tests/compile.ml @@ -20,8 +20,8 @@ let save_module wasm_mod filename = open Cmdliner -let compile_contract print debug optimize shared_memory output = - let config = Tunac.{ debug; shared_memory; optimize } in +let compile_contract print debug optimize shared_memory output memory = + let config = Tunac.{ debug; shared_memory; optimize; memory } in let wasm_mod = Tunac.compile_contract ~config contract in if print then Binaryen.Module.print wasm_mod; @@ -46,6 +46,9 @@ let print = let output = Arg.(required & opt (some string) None & info [ "o"; "output" ]) +let memory = + Arg.(value & opt (pair int int) (1, 10) & info [ "memory" ]) + let contract_cmd = Cmd.v (Cmd.info "contract") Term.( @@ -54,7 +57,8 @@ let contract_cmd = $ debug $ optimize $ shared_memory - $ output) + $ output + $ memory) let value_cmd = Cmd.v (Cmd.info "value") Term.(const compile_value $ const ()) From c313cc5b98ade61142788cd5ff8b82b63c9555fe Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 8 Nov 2022 10:10:27 -0300 Subject: [PATCH 10/21] Adding a few arithmetic instructions Still needing some tests --- deku-c/tunac/lib/iR_of_michelson.ml | 170 +++++++++++++++++++++++++++- 1 file changed, 169 insertions(+), 1 deletion(-) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index e9e7443ea7..df692ff87d 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -269,11 +269,180 @@ let rec compile_instruction ~env instr = Env.free_local env x; Env.free_local env y; block + + | Prim (_, I_MUL, _, _) -> + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let block = + Cblock [ compile_pop x + ; compile_pop y + ; compile_push ~env (Cop (Cwasm Wasm_mul, [ Cvar x; Cvar y ])) ] + in + Env.free_local env x; + Env.free_local env y; + block + + | Prim (_, I_NEG, _, _) -> + let x = Env.alloc_local env in + let block = + Cblock [ compile_pop x + ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cconst_i32 0l; Cvar x ])) ] + in + Env.free_local env x; + block + + | Prim (_, I_EQ, _, _) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cconst_i32 0l; Cop (Cwasm Wasm_eqz, [ Cvar p ]) ])) ] + in + Env.free_local env p; + block + + | Prim (_, I_ABS, _, _) -> + let p = Env.alloc_local env in + let q = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cassign (q, Cop (Cwasm Wasm_shr, [ Cvar p; Cconst_i32 31l ])) + ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cop (Cwasm Wasm_add, [ Cvar p; Cvar q ]); Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + block + + | Prim (_, I_EDIV, _, _) -> + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let r = Env.alloc_local env in + let block = + Cblock + [ compile_pop x + ; compile_pop y + ; Cifthenelse + (Cvar y + , Cblock + [ Cassign (r, Data.alloc 2) + ; Cstore (0, Cvar r, Cop (Cwasm Wasm_div, [ Cvar x; Cvar y ])) + ; Cstore (1, Cvar r, Cop (Cwasm Wasm_rem, [ Cvar x; Cvar y ])) + ; Cassign (x, Data.alloc 2) + ; Cstore (0, Cvar x, Cconst_i32 1l) + ; Cstore (1, Cvar x, Cvar r) ] + , Cassign (x, Cconst_i32 0l)) + ; compile_push ~env (Cvar x) ] + in + Env.free_local env x; + Env.free_local env y; + Env.free_local env r; + block + + (* Missing arithmetic instruction: COMPARE, GE, GT, INT, ISNAT, LE, LSL, LSR, LT, NEQ *) + | Prim (_, I_AND, _, _) -> + let p = Env.alloc_local env in + let q = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_pop q + ; compile_push ~env (Cop (Cwasm Wasm_and, [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + block + | Prim (_, I_NOT, _, _) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cvar p; Cconst_i32 0xffffffffl ]))] + in + Env.free_local env p; + block + + | Prim (_, I_OR, _, _) -> + let p = Env.alloc_local env in + let q = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_pop q + ; compile_push ~env (Cop (Cwasm Wasm_or, [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + block + + | Prim (_, I_XOR, _, _) -> + let p = Env.alloc_local env in + let q = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_pop q + ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + block + + | Prim (_, I_UNIT, _, _) + | Prim (_, I_NONE, _, _) | Prim (_, I_NIL, _, _) -> compile_push ~env (Cconst_i32 0l) + | Prim (_, I_CONS, _, _) -> + let value = Env.alloc_local env in + let list = Env.alloc_local env in + let new_list = Env.alloc_local env in + let block = + Cblock + [ compile_pop value + ; compile_pop list + ; Cassign (new_list, Data.alloc 2) + ; Cstore (0, Cvar new_list, Cvar value) + ; Cstore (1, Cvar new_list, Cvar list) + ; compile_push ~env (Cvar new_list) ] + in + Env.free_local env value; + Env.free_local env list; + Env.free_local env new_list; + block + + | Prim (_, I_LEFT, _, _) -> + let value = Env.alloc_local env in + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop value + ; Cassign (p, Data.alloc 2) + ; Cstore (0, Cvar p, Cconst_i32 1l) + ; Cstore (1, Cvar p, Cvar value) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env value; + Env.free_local env p; + block + + | Prim (_, I_RIGHT, _, _) -> + let value = Env.alloc_local env in + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop value + ; Cassign (p, Data.alloc 2) + ; Cstore (0, Cvar p, Cconst_i32 0l) + ; Cstore (1, Cvar p, Cvar value) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env value; + Env.free_local env p; + block + | Prim (_, I_PAIR, _, _) -> compile_pair ~env @@ -350,7 +519,6 @@ let rec compile_instruction ~env instr = Env.free_local env p; block - | Prim (_, I_SWAP, _, _) -> let fst = Env.alloc_local env in let snd = Env.alloc_local env in From a9efa7fda3d5b726938c2ef996c9a7f209c6c9c5 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 11 Nov 2022 18:59:59 -0300 Subject: [PATCH 11/21] Use Script_typed_ir instead of Micheline.node --- deku-c/tunac/lib/dune | 2 +- deku-c/tunac/lib/iR.ml | 19 +- deku-c/tunac/lib/iR_of_michelson.ml | 686 +++++++++++++++++++--------- deku-c/tunac/lib/serialize.ml | 20 +- deku-c/tunac/lib/tunac.ml | 33 +- deku-c/tunac/lib/tunac.mli | 4 +- deku-c/tunac/lib/wasm_of_ir.ml | 75 +-- deku-c/tunac/tests/compile.ml | 6 +- deku-c/tunac/tests/tests.js | 210 +++++---- deku-p/src/core/bin/api/handlers.ml | 25 +- 10 files changed, 686 insertions(+), 394 deletions(-) diff --git a/deku-c/tunac/lib/dune b/deku-c/tunac/lib/dune index 9cf1b0132a..5b01650935 100644 --- a/deku-c/tunac/lib/dune +++ b/deku-c/tunac/lib/dune @@ -1,3 +1,3 @@ (library (name tunac) - (libraries tezos-micheline binaryen)) + (libraries tezos-micheline binaryen proto-alpha-utils)) diff --git a/deku-c/tunac/lib/iR.ml b/deku-c/tunac/lib/iR.ml index 9402bc63a8..964ef2288a 100644 --- a/deku-c/tunac/lib/iR.ml +++ b/deku-c/tunac/lib/iR.ml @@ -29,11 +29,18 @@ type wasm_operation = | Wasm_ge [@@deriving show] +type wasm_type = + | I8 + | U8 + | I32 + | U32 +[@@deriving show] + type operation = | Capply of string - | Cload of int + | Cload of int * wasm_type | Calloc of int - | Cwasm of wasm_operation + | Cwasm of wasm_operation * wasm_type [@@deriving show] type expression = @@ -63,13 +70,13 @@ module Data = struct ; Cstore (0, Cvar var, hd) ; Cstore (1, Cvar var, tl) ] - let car expr = Cop (Cload 0, [ expr ]) + let car ?(typ = I32) expr = Cop (Cload (0, typ), [ expr ]) - let cdr expr = Cop (Cload 1, [ expr ]) + let cdr ?(typ = I32) expr = Cop (Cload (1, typ), [ expr ]) - let add a b = Cop (Cwasm Wasm_add, [ a; b ]) + let add ?(typ = I32) a b = Cop (Cwasm (Wasm_add, typ), [ a; b ]) - let sub a b = Cop (Cwasm Wasm_sub, [ a; b ]) + let sub ?(typ = I32) a b = Cop (Cwasm (Wasm_sub, typ), [ a; b ]) let inc x = add x (Cconst_i32 1l) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index df692ff87d..ca06ff0965 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -1,15 +1,18 @@ open Tezos_micheline -open Micheline -open Michelson_v1_primitives open IR +open Proto_alpha_utils.Memory_proto_alpha.Protocol +open Script_typed_ir + type node = (int, Michelson_v1_primitives.prim) Micheline.node +(* FIXME: Ignore the actual nodes for now *) + type error = | Invalid_contract_format - | Unsupported_instruction of node - | Unsupported_parameter_type of node - | Unsupported_storage_type of node + | Unsupported_instruction (* of node *) + | Unsupported_parameter_type (* of node *) + | Unsupported_storage_type (* of node *) exception Compilation_error of error @@ -19,7 +22,8 @@ type function_ = type contract = { main : function_ - ; lambdas : (int * function_) list } + ; lambdas : (int * function_) list + ; static_data : bytes } module Env = struct module Set = Set.Make(Int) @@ -195,7 +199,7 @@ let compile_dip ~env n block = [ Cassign (pair, Cop (Calloc 2, [])) ; Cstore (0, Cvar pair, Cglobal "stack") ; Cstore (1, Cvar pair, Cvar node) - ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_add, [ Cglobal "dip_stack"; Cconst_i32 4l ])) + ; Cglobal_assign ("dip_stack", Cop (Cwasm (Wasm_add, I32), [ Cglobal "dip_stack"; Cconst_i32 4l ])) ; Cstore (0, Cglobal "dip_stack", Cvar pair) ; Cglobal_assign ("stack", Data.cdr (Cvar node)) ] in @@ -206,37 +210,126 @@ let compile_dip ~env n block = let pair = Env.alloc_local env in let restore_stack = Cblock - [ Cassign (pair, Cop (Cload 0, [ Cglobal "dip_stack" ])) + [ Cassign (pair, Cop (Cload (0, I32), [ Cglobal "dip_stack" ])) ; Cstore (1, Data.cdr (Cvar pair), Cglobal "stack") ; Cglobal_assign ("stack", Data.car (Cvar pair)) - ; Cglobal_assign ("dip_stack", Cop (Cwasm Wasm_sub, [ Cglobal "dip_stack"; Cconst_i32 4l ] )) ] + ; Cglobal_assign ("dip_stack", Cop (Cwasm (Wasm_sub, I32), [ Cglobal "dip_stack"; Cconst_i32 4l ] )) ] in Cblock [ inner_loop; save_stack_block; block; restore_stack ] let lambdas = ref [] +let static_data = ref Bytes.empty + +let rec compile_compare: type a b. Env.t -> expression -> expression -> int -> (a, b) ty -> statement = fun env x y var typ -> + let compare_i32 typ var x y = + Cblock + [ Cassign (var, Cop (Cwasm (Wasm_sub, typ), [ x; y ])) + ; Cifthenelse + (Cop (Cwasm (Wasm_gt, typ), [ Cvar var; Cconst_i32 0l ]) + , Cassign (var, Cconst_i32 1l) + , Cifthenelse (Cop (Cwasm (Wasm_lt, typ), [ Cvar var; Cconst_i32 0l ]) + , Cassign (var, Cconst_i32 (-1l)) + , Cblock [])) ] + in + + match typ with + | Unit_t -> + Cassign (var, Cconst_i32 0l) + + | Int_t -> + compare_i32 I32 var x y + + | Pair_t (fst, snd, _, _) -> + let a = Env.alloc_local env in + let b = Env.alloc_local env in + let block = + Cblock + [ compile_compare env (Data.car x) (Data.car y) a fst + ; compile_compare env (Data.cdr x) (Data.cdr y) b snd + ; Cifthenelse + (Cop (Cwasm (Wasm_eqz, I32), [ Cvar a ]) + , Cassign (var, Cvar b) + , Cassign (var, Cvar a)) ] + in + block + + | Bool_t -> + compare_i32 I32 var x y + + | Address_t -> + (* We agreed at some point on using ints for addresses as an index on a contact book. *) + compare_i32 I32 var x y + + | Nat_t -> + compare_i32 U32 var x y + + | Mutez_t -> + compare_i32 U32 var x y + + | Timestamp_t -> + compare_i32 U32 var x y + + | _ -> assert false + +let compile_map_get env key_type map key value = + let compare = Env.alloc_local env in + let block = + Cblock + [ Cwhile + (Cvar map + , Cblock + [ compile_compare env (Cvar key) (Data.car (Data.car (Cvar map))) compare key_type ]) + ; Cifthenelse + (Cop (Cwasm (Wasm_eqz, I32), [ Cvar compare ]) + , Cblock + [ Cassign (value, Cop (Calloc 2, [])) + ; Cstore (0, Cvar value, Cconst_i32 1l) + ; Cstore (1, Cvar value, Data.cdr (Data.car (Cvar map))) + ; Cassign (map, Cconst_i32 0l) ] + , Cassign (value, Cconst_i32 0l)) ] + in + Env.free_local env compare; + block -let rec compile_instruction ~env instr = +let compile_update env map key value = + let head = Env.alloc_local env in + let entry = Env.alloc_local env in + let block = + Cblock + [ Cassign (entry, Cop (Calloc 2, [])) + ; Cstore (0, Cvar entry, Cvar key) + ; Cstore (1, Cvar entry, Cvar value) + ; Cassign (head, Cop (Calloc 2, [])) + ; Cstore (0, Cvar head, Cvar entry) + ; Cstore (1, Cvar head, Cvar map) + ; Cassign (map, Cvar head) ] + in + Env.free_local env head; + Env.free_local env entry; + block + +let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> statement = fun env instr -> match instr with - | Prim (_, I_CAR, _, _) -> + | ICar (_, k) -> let top = Env.alloc_local env in let block = Cblock [ compile_pop top ; compile_push ~env (Data.car (Cvar top)) ] in Env.free_local env top; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_CDR, _, _) -> + | ICdr (_, k) -> let top = Env.alloc_local env in let block = Cblock [ compile_pop top ; compile_push ~env (Data.cdr (Cvar top)) ] in Env.free_local env top; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_UNPAIR, _, _) -> + | IUnpair (_, k) -> let top = Env.alloc_local env in let block = Cblock [ compile_pop top @@ -244,77 +337,91 @@ let rec compile_instruction ~env instr = ; compile_push ~env (Data.car (Cvar top)) ] in Env.free_local env top; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_ADD, _, _) -> + | IAdd_int (_, k) -> let x = Env.alloc_local env in let y = Env.alloc_local env in let block = Cblock [ compile_pop x ; compile_pop y - ; compile_push ~env (Cop (Cwasm Wasm_add, [ Cvar x; Cvar y ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_add, I32), [ Cvar x; Cvar y ])) ] in Env.free_local env x; - Env.free_local env y; - block + Env.free_local env x; + Cblock [ block; compile_instruction env k ] - | Prim (_, I_SUB, _, _) -> + | ISub_int (_, k) -> let x = Env.alloc_local env in let y = Env.alloc_local env in let block = Cblock [ compile_pop x ; compile_pop y - ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cvar x; Cvar y ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cvar x; Cvar y ])) ] in Env.free_local env x; Env.free_local env y; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_MUL, _, _) -> + | IMul_int (_, k) -> let x = Env.alloc_local env in let y = Env.alloc_local env in let block = Cblock [ compile_pop x ; compile_pop y - ; compile_push ~env (Cop (Cwasm Wasm_mul, [ Cvar x; Cvar y ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_mul, I32), [ Cvar x; Cvar y ])) ] in Env.free_local env x; Env.free_local env y; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_NEG, _, _) -> + | INeg (_, k) -> let x = Env.alloc_local env in let block = Cblock [ compile_pop x - ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cconst_i32 0l; Cvar x ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cconst_i32 0l; Cvar x ])) ] in Env.free_local env x; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_EQ, _, _) -> + | IEq (_, k) -> let p = Env.alloc_local env in let block = Cblock [ compile_pop p - ; compile_push ~env (Cop (Cwasm Wasm_sub, [ Cconst_i32 0l; Cop (Cwasm Wasm_eqz, [ Cvar p ]) ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cconst_i32 0l; Cop (Cwasm (Wasm_eqz, I32), [ Cvar p ]) ])) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_ABS, _, _) -> + | INeq (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cop (Cwasm (Wasm_eqz, I32), [ Cvar p ]) + , Cassign (p, Cconst_i32 0l) + , Cassign (p, Cconst_i32 (-1l))) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | IAbs_int (_, k) -> let p = Env.alloc_local env in let q = Env.alloc_local env in let block = Cblock [ compile_pop p - ; Cassign (q, Cop (Cwasm Wasm_shr, [ Cvar p; Cconst_i32 31l ])) - ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cop (Cwasm Wasm_add, [ Cvar p; Cvar q ]); Cvar q ])) ] + ; Cassign (q, Cop (Cwasm (Wasm_shr, I32), [ Cvar p; Cconst_i32 31l ])) + ; compile_push ~env (Cop (Cwasm (Wasm_xor, I32), [ Cop (Cwasm (Wasm_add, I32), [ Cvar p; Cvar q ]); Cvar q ])) ] in Env.free_local env p; Env.free_local env q; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_EDIV, _, _) -> + | IEdiv_int (_, k) -> let x = Env.alloc_local env in let y = Env.alloc_local env in let r = Env.alloc_local env in @@ -326,8 +433,8 @@ let rec compile_instruction ~env instr = (Cvar y , Cblock [ Cassign (r, Data.alloc 2) - ; Cstore (0, Cvar r, Cop (Cwasm Wasm_div, [ Cvar x; Cvar y ])) - ; Cstore (1, Cvar r, Cop (Cwasm Wasm_rem, [ Cvar x; Cvar y ])) + ; Cstore (0, Cvar r, Cop (Cwasm (Wasm_div, I32), [ Cvar x; Cvar y ])) + ; Cstore (1, Cvar r, Cop (Cwasm (Wasm_rem, I32), [ Cvar x; Cvar y ])) ; Cassign (x, Data.alloc 2) ; Cstore (0, Cvar x, Cconst_i32 1l) ; Cstore (1, Cvar x, Cvar r) ] @@ -337,65 +444,69 @@ let rec compile_instruction ~env instr = Env.free_local env x; Env.free_local env y; Env.free_local env r; - block + Cblock [ block; compile_instruction env k ] - (* Missing arithmetic instruction: COMPARE, GE, GT, INT, ISNAT, LE, LSL, LSR, LT, NEQ *) + (* Missing arithmetic instruction: INT, ISNAT, LSL, LSR *) - | Prim (_, I_AND, _, _) -> + | IAnd (_, k) -> let p = Env.alloc_local env in let q = Env.alloc_local env in let block = Cblock [ compile_pop p ; compile_pop q - ; compile_push ~env (Cop (Cwasm Wasm_and, [ Cvar p; Cvar q ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_and, I32), [ Cvar p; Cvar q ])) ] in Env.free_local env p; Env.free_local env q; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_NOT, _, _) -> + | INot (_, k) -> let p = Env.alloc_local env in let block = Cblock [ compile_pop p - ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cvar p; Cconst_i32 0xffffffffl ]))] + ; compile_push ~env (Cop (Cwasm (Wasm_xor, I32), [ Cvar p; Cconst_i32 0xffffffffl ])) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_OR, _, _) -> + | IOr (_, k) -> let p = Env.alloc_local env in let q = Env.alloc_local env in let block = Cblock [ compile_pop p ; compile_pop q - ; compile_push ~env (Cop (Cwasm Wasm_or, [ Cvar p; Cvar q ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_or, I32), [ Cvar p; Cvar q ])) ] in Env.free_local env p; Env.free_local env q; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_XOR, _, _) -> + | IXor (_, k) -> let p = Env.alloc_local env in let q = Env.alloc_local env in let block = Cblock [ compile_pop p ; compile_pop q - ; compile_push ~env (Cop (Cwasm Wasm_xor, [ Cvar p; Cvar q ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_xor, I32), [ Cvar p; Cvar q ])) ] in Env.free_local env p; Env.free_local env q; - block + Cblock [ block; compile_instruction env k ] + + | IConst (_, Unit_t, (), k) -> + Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] - | Prim (_, I_UNIT, _, _) - | Prim (_, I_NONE, _, _) - | Prim (_, I_NIL, _, _) -> - compile_push ~env (Cconst_i32 0l) + | ICons_none (_, _, k) -> + Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] - | Prim (_, I_CONS, _, _) -> + | INil (_, _, k) -> + Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + + | ICons_list (_, k) -> let value = Env.alloc_local env in let list = Env.alloc_local env in let new_list = Env.alloc_local env in @@ -411,9 +522,9 @@ let rec compile_instruction ~env instr = Env.free_local env value; Env.free_local env list; Env.free_local env new_list; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_LEFT, _, _) -> + | ICons_left (_, _, k) -> let value = Env.alloc_local env in let p = Env.alloc_local env in let block = @@ -426,9 +537,9 @@ let rec compile_instruction ~env instr = in Env.free_local env value; Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_RIGHT, _, _) -> + | ICons_right (_, _, k) -> let value = Env.alloc_local env in let p = Env.alloc_local env in let block = @@ -441,12 +552,13 @@ let rec compile_instruction ~env instr = in Env.free_local env value; Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_PAIR, _, _) -> - compile_pair ~env + | ICons_pair (_, k) -> + (* TODO: Support IComb *) + Cblock [ compile_pair ~env; compile_instruction env k ] - | Prim (_, I_SOME, _, _) -> + | ICons_some (_, k) -> (* TODO: I actually think that optionals may have only one cell allocated *) let p = Env.alloc_local env in let value = Env.alloc_local env in @@ -460,35 +572,37 @@ let rec compile_instruction ~env instr = in Env.free_local env p; Env.free_local env value; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_IF_LEFT, [ Seq (_, left_branch); Seq (_, right_branch) ], _) -> + | IIf_left { loc = _; branch_if_left; branch_if_right; k } -> let p = Env.alloc_local env in let block = - Cblock [ compile_pop p - ; compile_push ~env (Cop (Cload 1, [ Cvar p ])) - ; Cifthenelse - (Cop (Cload 0, [ Cvar p ]) - , Cblock (List.map (compile_instruction ~env) left_branch) - , Cblock (List.map (compile_instruction ~env) right_branch)) ] + [ compile_pop p + ; compile_push ~env (Cop (Cload (1, I32), [ Cvar p ])) ] in Env.free_local env p; - block + let if_body = + Cifthenelse + (Cop (Cload (0, I32), [ Cvar p ]) + , compile_instruction env branch_if_left + , compile_instruction env branch_if_right) + in + Cblock (block @ [ if_body; compile_instruction env k ]) - | Prim (_, I_IF, [ Seq (_, branch_if); Seq (_, branch_else) ], _) -> + | IIf { loc = _; branch_if_true; branch_if_false; k } -> let p = Env.alloc_local env in let block = Cblock [ compile_pop p ; Cifthenelse (Cvar p - , Cblock (List.map (compile_instruction ~env) branch_if) - , Cblock (List.map (compile_instruction ~env) branch_else)) ] + , compile_instruction env branch_if_true + , compile_instruction env branch_if_false) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_IF_CONS, [ Seq (_, branch_cons); Seq (_, branch_nil) ], _) -> + | IIf_cons { loc = _; branch_if_cons; branch_if_nil; k } -> let p = Env.alloc_local env in let block = Cblock @@ -496,15 +610,15 @@ let rec compile_instruction ~env instr = ; Cifthenelse (Cvar p , Cblock - ([ compile_push ~env (Data.cdr (Cvar p)) - ; compile_push ~env (Data.car (Cvar p)) ] - @ List.map (compile_instruction ~env) branch_cons) - , Cblock (List.map (compile_instruction ~env) branch_nil)) ] + [ compile_push ~env (Data.cdr (Cvar p)) + ; compile_push ~env (Data.car (Cvar p)) + ; compile_instruction env branch_if_cons ] + , compile_instruction env branch_if_nil) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_IF_NONE, [ Seq (_, branch_none); Seq (_, branch_some) ], _) -> + | IIf_none { loc = _; branch_if_some; branch_if_none; k } -> let p = Env.alloc_local env in let block = Cblock @@ -512,14 +626,14 @@ let rec compile_instruction ~env instr = ; Cifthenelse (Cvar p , Cblock - (compile_push ~env (Data.cdr (Cvar p)) - :: List.map (compile_instruction ~env) branch_some) - , Cblock (List.map (compile_instruction ~env) branch_none)) ] + [ compile_push ~env (Data.cdr (Cvar p)) + ; compile_instruction env branch_if_some ] + , compile_instruction env branch_if_none) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_SWAP, _, _) -> + | ISwap (_, k) -> let fst = Env.alloc_local env in let snd = Env.alloc_local env in let block = @@ -530,49 +644,57 @@ let rec compile_instruction ~env instr = in Env.free_local env fst; Env.free_local env snd; - block + Cblock [ block; compile_instruction env k ] + + | IConst (_, Int_t, z, k) -> + let value = Int64.to_int32 @@ Option.get @@ Script_int.to_int64 z in + Cblock [ compile_push ~env (Cconst_i32 value); compile_instruction env k ] - | Prim (_, I_PUSH, [ _; Int (_, z) ], _) -> - let value = Z.to_int32 z in - compile_push ~env (Cconst_i32 value) + | IConst (_, String_t, v, k) -> + let addr = Int32.of_int @@ Bytes.length !static_data in + (* C strings will do it for now *) + static_data := Bytes.cat !static_data (Bytes.of_string @@ Script_string.to_string v ^ "\000"); + Cblock [ compile_push ~env (Cconst_i32 addr); compile_instruction env k ] - | Prim (_, I_DIG, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - compile_dig ~env n + | IEmpty_map (_, _, _, k) -> + Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] - | Prim (_, I_DUG, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - compile_dug ~env n + | IEmpty_set (_, _, k) -> + Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + + | IDig (_, n, _, k) -> + Cblock [ compile_dig ~env (Int32.of_int n); compile_instruction env k ] - | Prim (_, I_DROP, [], _) -> - compile_drop ~env 1l + | IDug (_, n, _, k) -> + Cblock [ compile_dug ~env (Int32.of_int n); compile_instruction env k ] - | Prim (_, I_DROP, [ Int (_, n) ], _) -> - let n = Z.to_int32 n in - compile_drop ~env n + | IDrop (_, k) -> + Cblock [ compile_drop ~env 1l; compile_instruction env k ] - | Prim (_, I_DUP, [], _) -> - compile_dup ~env 1l + | IDropn (_, n, _, k) -> + Cblock [ compile_drop ~env (Int32.of_int n); compile_instruction env k ] - | Prim (_, I_DUP, [ Int (_, n) ], _) -> - compile_dup ~env (Z.to_int32 n) + | IDup (_, k) -> + Cblock [ compile_dup ~env 1l; compile_instruction env k ] - | Prim (_, I_DIP, [ Int (_, n); Seq (_, instr) ], _) -> - let n = Z.to_int32 n in - let block = Cblock (List.map (compile_instruction ~env) instr) in - if n = 0l then block - else compile_dip ~env n block + | IDup_n (_, n, _, k) -> + Cblock [ compile_dup ~env (Int32.of_int n); compile_instruction env k ] - | Prim (_, I_DIP, [ Seq (_, instr) ], _) -> - compile_dip ~env 1l (Cblock (List.map (compile_instruction ~env) instr)) + | IDipn (_, n, _, b, k) -> + let block = compile_instruction env b in + if n = 0 then block + else Cblock [ compile_dip ~env (Int32.of_int n) block; compile_instruction env k ] - | Prim (_, I_FAILWITH, _, _) -> + | IDip (_, b, _, k) -> + Cblock [ compile_dip ~env 1l (compile_instruction env b); compile_instruction env k ] + + | IFailwith (_, _) -> let param = Env.alloc_local env in Cblock [ compile_pop param; Cfailwith (Cvar param) ] - | Prim (_, I_ITER, [ Seq (_, body) ], _) -> + | IList_iter (_, _, b, k) -> let iter = Env.alloc_local env in - let iter_body = Cblock (List.map (compile_instruction ~env) body) in + let iter_body = compile_instruction env b in let block = Cblock [ compile_pop iter @@ -583,12 +705,12 @@ let rec compile_instruction ~env instr = ; Cassign (iter, (Data.cdr (Cvar iter))) ]) ] in Env.free_local env iter; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_LOOP, [ Seq (_, body) ], _) -> + | ILoop (_, b, k) -> (* TODO: Test it *) let p = Env.alloc_local env in - let body = Cblock (List.map (compile_instruction ~env) body) in + let body = compile_instruction env b in let block = Cblock [ Cassign (p, Cconst_i32 1l) @@ -598,27 +720,31 @@ let rec compile_instruction ~env instr = ; body ]) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_LOOP_LEFT, [ Seq (_, body) ], _) -> + | ILoop_left (_, b, k) -> (* TODO: Test it *) let p = Env.alloc_local env in - let body = Cblock (List.map (compile_instruction ~env) body) in - Cblock - [ Cassign (p, Cconst_i32 1l) - ; Cwhile (Cvar p, - Cblock - [ compile_pop p - ; compile_push ~env (Data.cdr (Cvar p)) - ; Cifthenelse - (Cop (Cload 0, [ Cvar p ]) - , Cblock [ body ] - , Cblock []) ]) - ; Cassign (p, Data.car (Cvar p)) ] - - | Prim (_, I_LAMBDA, [ _; _; Seq (_, body) ], _) -> + let body = compile_instruction env b in + let block = + Cblock + [ Cassign (p, Cconst_i32 1l) + ; Cwhile (Cvar p, + Cblock + [ compile_pop p + ; compile_push ~env (Data.cdr (Cvar p)) + ; Cifthenelse + (Cop (Cload (0, I32), [ Cvar p ]) + , Cblock [ body ] + , Cblock []) ]) + ; Cassign (p, Data.car (Cvar p)) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ILambda (_, Lam ({ kinstr = body; _ }, _), k) -> let lenv = Env.make () in - let body = Cblock (List.map (compile_instruction ~env:lenv) body) in + let body = compile_instruction lenv body in let lambda_n = Int32.of_int (List.length !lambdas) in lambdas := (body, env) :: !lambdas; let p = Env.alloc_local env in @@ -630,9 +756,9 @@ let rec compile_instruction ~env instr = ; compile_push ~env (Cvar p) ] in Env.free_local env p; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_APPLY, _, _) -> + | IApply (_, _, k) -> let top = Env.alloc_local env in let value = Env.alloc_local env in let block = @@ -646,9 +772,9 @@ let rec compile_instruction ~env instr = in Env.free_local env value; Env.free_local env top; - block + Cblock [ block; compile_instruction env k ] - | Prim (_, I_EXEC, _, _) -> + | IExec (_, _, k) -> (* Layout: 0x0 0x1 *) @@ -662,7 +788,7 @@ let rec compile_instruction ~env instr = ; Cwhile (Data.car (Cvar lambda), Cblock [ Cassign (pair, Data.alloc 2) - ; Cstore (0, Cvar pair, Cop (Cload 2, [ Cvar lambda ])) + ; Cstore (0, Cvar pair, Cop (Cload (2, I32), [ Cvar lambda ])) ; Cstore (1, Cvar pair, Cvar argument) ; Cassign (lambda, Data.cdr (Cvar lambda)) ; Cassign (argument, Cvar pair) ]) @@ -672,47 +798,164 @@ let rec compile_instruction ~env instr = Env.free_local env argument; Env.free_local env lambda; Env.free_local env pair; - block + Cblock [ block; compile_instruction env k ] - | instr -> raise (Compilation_error (Unsupported_instruction instr)) + | ICompare (_, typ, k) -> + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let v = Env.alloc_local env in + let block = + Cblock + [ compile_pop x + ; compile_pop y + ; compile_compare env (Cvar x) (Cvar y) v typ + ; compile_push ~env (Cvar v) ] + in + Env.free_local env v; + Env.free_local env x; + Env.free_local env y; + Cblock [ block; compile_instruction env k ] -let rec compile_value_decoder ~env typ var ptr = - match typ with - | Prim (_, T_bool, _, _) - | Prim (_, T_nat, _, _) - | Prim (_, T_int, _, _) - | Prim (_, T_unit, _, _) -> + | IGt (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cop (Cwasm (Wasm_eq, I32), [ Cvar p; Cconst_i32 1l ]) + , Cassign (p, Cconst_i32 (-1l)) + , Cassign (p, Cconst_i32 0l)) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | IGe (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cop (Cwasm (Wasm_lt, I32), [ Cvar p; Cconst_i32 0l ]) + , Cassign (p, Cconst_i32 0l) + , Cassign (p, Cconst_i32 (-1l))) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ILt (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cop (Cwasm (Wasm_lt, I32), [ Cvar p; Cconst_i32 (-1l) ]) + , Cassign (p, Cconst_i32 (-1l)) + , Cassign (p, Cconst_i32 0l)) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ILe (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; Cifthenelse + (Cop (Cwasm (Wasm_gt, I32), [ Cvar p; Cconst_i32 0l ]) + , Cassign (p, Cconst_i32 0l) + , Cassign (p, Cconst_i32 (-1l))) + ; compile_push ~env (Cvar p) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ISender (_, k) -> + Cblock [ compile_push ~env (Cop (Capply "sender", [])); compile_instruction env k ] + + | IAmount (_, k) -> + Cblock [ compile_push ~env (Cop (Capply "amount", [])); compile_instruction env k ] + + | ITicket (_, typ, k) -> + let content = Env.alloc_local env in + let amount = Env.alloc_local env in + let ptr = Env.alloc_local env in + let size = Env.alloc_local env in + let block = + Cblock + [ compile_pop content + ; compile_value_encoder env typ ptr size content + ; compile_pop amount + ; compile_push ~env (Cop (Capply "ticket", [ Cvar content; Cvar amount ])) ] + in + Env.free_local env content; + Env.free_local env amount; + Env.free_local env ptr; + Env.free_local env size; + Cblock [ block; compile_instruction env k ] + + | IMap_get (_, k) -> + let map = Env.alloc_local env in + let key = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + Cblock + [ compile_pop key + ; compile_pop map + ; compile_map_get env Int_t map key value + ; compile_push ~env (Cvar value) ] + in + Env.free_local env map; + Env.free_local env key; + Env.free_local env value; + Cblock [ block; compile_instruction env k ] + + | IHalt _ -> Cblock [] + + | _instr -> raise (Compilation_error (Unsupported_instruction)) + +and compile_value_decoder: type a b. Env.t -> (a, b) ty -> int -> int -> statement = fun env typ var ptr -> + let decode_i32 () = Cblock - [ Cassign (var, Cop (Cload 0, [ Cvar ptr ])) - ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) ] + [ Cassign (var, Cop (Cload (0, I32), [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) ] + in + + match typ with + | Bool_t -> decode_i32 () + | Nat_t -> decode_i32 () + | Int_t -> decode_i32 () + | Unit_t -> decode_i32 () - | Prim (_, T_or, [ left; right ], _) -> + | Union_t (left, right, _, _) -> let wrapped_value = Env.alloc_local env in let block = Cblock [ Cassign (var, Cop (Calloc 2, [])) - ; Cstore (0, Cvar var, Cop (Cload 0, [ Cvar ptr ])) - ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) - ; Cifthenelse (Cop (Cload 0, [ Cvar var ]) - , compile_value_decoder ~env left wrapped_value ptr - , compile_value_decoder ~env right wrapped_value ptr ) + ; Cstore (0, Cvar var, Cop (Cload (0, I32), [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) + ; Cifthenelse (Cop (Cload (0, I32), [ Cvar var ]) + , compile_value_decoder env left wrapped_value ptr + , compile_value_decoder env right wrapped_value ptr ) ; Cstore (1, Cvar var, Cvar wrapped_value) ] in Env.free_local env wrapped_value; block - | Prim (_, T_list, [ typ ], _) -> + | List_t (typ, _) -> let counter = Env.alloc_local env in let value = Env.alloc_local env in let tmp = Env.alloc_local env in let block = Cblock [ Cassign (var, Cconst_i32 0l) - ; Cassign (counter, Cop (Cload 0, [ Cvar ptr ])) - ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) + ; Cassign (counter, Cop (Cload (0, I32), [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) ; Cwhile (Cvar counter, Cblock - [ compile_value_decoder ~env typ value ptr + [ compile_value_decoder env typ value ptr (* TODO: I'm not sure if I need this tmp local *) ; Data.cons tmp (Cvar value) (Cvar var) ; Cassign (var, Cvar tmp) @@ -723,83 +966,80 @@ let rec compile_value_decoder ~env typ var ptr = Env.free_local env tmp; block - | Prim (_, T_option, [ typ ], _) -> + | Option_t (typ, _, _) -> let value = Env.alloc_local env in Cblock - [ Cassign (value, Cop (Cload 0, [ Cvar ptr ])) - ; Cassign (ptr, Cop (Cwasm Wasm_add, [ Cvar ptr; Cconst_i32 4l ])) + [ Cassign (value, Cop (Cload (0, I32), [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) ; Cifthenelse (Cvar value, Cblock [ Cassign (var, Data.alloc 2) ; Cstore (0, Cvar var, Cvar value) - ; compile_value_decoder ~env typ value ptr + ; compile_value_decoder env typ value ptr ; Cstore (1, Cvar var, Cvar value) ], Cassign (var, Cvar value)) ] - | typ -> raise (Compilation_error (Unsupported_parameter_type typ)) + | _typ -> raise (Compilation_error (Unsupported_parameter_type)) -let compile_value_encoder ~env:_ typ ptr size value = +and compile_value_encoder: type a b. Env.t -> (a, b) ty -> int -> int -> int -> statement = fun _ typ ptr size value -> match typ with - | Prim (_, T_int, _, _) -> + | Int_t -> Cblock [ Cassign (ptr, Cop (Calloc 1, [])) ; Cstore (0, Cvar ptr, Cvar value) ; Cassign (size, Cconst_i32 4l) ] - | typ -> raise (Compilation_error (Unsupported_storage_type typ)) + | _typ -> raise (Compilation_error Unsupported_storage_type) let compile_contract contract = + + let open Script_ir_translator in + let Ex_code (Code { code = Lam ({ kinstr = code ; _ }, _); arg_type; storage_type; _ }) = contract in + let env = Env.make () in - match contract with - | Seq (_ - , [ Prim (_, K_parameter, [ parameter_type ], _) - ; Prim (_, K_storage, [ storage_type ], _) - ; Prim (_, K_code, [ Seq (_, code) ], _) ]) -> - let parameter = Env.alloc_local env in - let q = Env.alloc_local env in - let parameter_var = Env.alloc_local env in - let param_block = - Cblock - [ Cassign (parameter, Cop (Calloc 0, [ Cop (Capply "parameter_size", []) ])) - ; Cassign (q, Cop (Capply "parameter_load", [ Cvar parameter ])) - ; Cassign (parameter_var, Cop (Calloc 2, [])) - ; compile_value_decoder ~env parameter_type q parameter - ; Cstore (0, Cvar parameter_var, Cvar q) - ; compile_value_decoder ~env storage_type q parameter - ; Cstore (1, Cvar parameter_var, Cvar q) - ; compile_push ~env (Cvar parameter_var) ] - in - Env.free_local env parameter; - Env.free_local env q; - Env.free_local env parameter_var; - - let store_block = - let ptr = Env.alloc_local env in - let size = Env.alloc_local env in - let value = Env.alloc_local env in - let block = - [ Cassign (value, Data.cdr (Data.car (Cglobal "stack"))) - ; compile_value_encoder ~env storage_type ptr size value - ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] - in - Env.free_local env ptr; - Env.free_local env size; - Env.free_local env value; - block - in - - let main = - { body = Cblock (param_block :: List.map (compile_instruction ~env) code @ store_block) - ; locals = Env.max env + 1 } - in - let lambdas = - !lambdas - |> List.rev - |> List.mapi (fun idx (body, env) -> (idx, { body; locals = Env.max env + 1 })) - in - { main; lambdas } - - | _ -> raise (Compilation_error Invalid_contract_format) + let parameter = Env.alloc_local env in + let q = Env.alloc_local env in + let parameter_var = Env.alloc_local env in + let param_block = + Cblock + [ Cassign (parameter, Cop (Calloc 0, [ Cop (Capply "parameter_size", []) ])) + ; Cassign (q, Cop (Capply "parameter_load", [ Cvar parameter ])) + ; Cassign (parameter_var, Cop (Calloc 2, [])) + ; compile_value_decoder env arg_type q parameter + ; Cstore (0, Cvar parameter_var, Cvar q) + ; compile_value_decoder env storage_type q parameter + ; Cstore (1, Cvar parameter_var, Cvar q) + ; compile_push ~env (Cvar parameter_var) ] + in + Env.free_local env parameter; + Env.free_local env q; + Env.free_local env parameter_var; + + let store_block = + let ptr = Env.alloc_local env in + let size = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + [ Cassign (value, Data.cdr (Data.car (Cglobal "stack"))) + ; compile_value_encoder env storage_type ptr size value + ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] + in + Env.free_local env ptr; + Env.free_local env size; + Env.free_local env value; + block + in + + let main = + { body = Cblock (param_block :: compile_instruction env code :: store_block) + ; locals = Env.max env + 1 } + in + let lambdas = + !lambdas + |> List.rev + |> List.mapi (fun idx (body, env) -> (idx, { body; locals = Env.max env + 1 })) + in + { main; lambdas; static_data = !static_data } let compile_contract contract = try Ok (compile_contract contract) diff --git a/deku-c/tunac/lib/serialize.ml b/deku-c/tunac/lib/serialize.ml index 3a1550598c..7c6e4170b1 100644 --- a/deku-c/tunac/lib/serialize.ml +++ b/deku-c/tunac/lib/serialize.ml @@ -1,6 +1,6 @@ open Tezos_micheline open Micheline -open Michelson_v1_primitives +(* open Michelson_v1_primitives *) let int32_to_bytes n = let buffer = Bytes.create 4 in @@ -12,23 +12,23 @@ let rec compile_value node = | Int (_, n) -> int32_to_bytes (Z.to_int32 n) - | Prim (_, D_Elt, args, _) - | Prim (_, D_Pair, args, _) -> + | Prim (_, "Elt", args, _) + | Prim (_, "Pair", args, _) -> Bytes.concat Bytes.empty (List.map compile_value args) - | Prim (_, D_Some, [ arg ], _) - | Prim (_, D_Left, [ arg ], _) -> + | Prim (_, "Some", [ arg ], _) + | Prim (_, "Left", [ arg ], _) -> Bytes.(cat (int32_to_bytes 1l) (compile_value arg)) - | Prim (_, D_Right, [ arg ], _) -> + | Prim (_, "Right", [ arg ], _) -> Bytes.(cat (int32_to_bytes 0l) (compile_value arg)) - | Prim (_, D_None, _, _) - | Prim (_, D_False, [], []) - | Prim (_, D_Unit, [], _) -> + | Prim (_, "None", _, _) + | Prim (_, "False", [], []) + | Prim (_, "Unit", [], _) -> int32_to_bytes 0l - | Prim (_, D_True, [], []) -> + | Prim (_, "True", [], []) -> int32_to_bytes 0xffffffffl | Seq (_, lst) -> diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index 1cb761c8fa..5f4269d77e 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -1,5 +1,5 @@ -type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node +type node = (int, string) Tezos_micheline.Micheline.node type contract = node @@ -15,10 +15,9 @@ let parse code = let code, _ = Micheline_parser.parse_expression tokens in code |> Micheline.strip_locations - |> Micheline.map (fun prim -> Michelson_v1_primitives.prim_of_string prim |> Result.get_ok) |> Micheline.root -let print_node fmt node = +let _print_node fmt node = let open Tezos_micheline in node |> Micheline.strip_locations @@ -31,19 +30,29 @@ let report error = match error with | Invalid_contract_format -> print_endline "Invalid contract format" - | Unsupported_instruction instr -> - printf "Unsupported Michelson instruction: %a\n" print_node instr - | Unsupported_parameter_type typ -> - printf "Unsupported parameter type: %a\n" print_node typ - | Unsupported_storage_type typ -> - printf "Unsupported storage type: %a\n" print_node typ + | Unsupported_instruction -> + printf "Unsupported Michelson instruction: \n" + | Unsupported_parameter_type -> + printf "Unsupported parameter type: \n" + | Unsupported_storage_type -> + printf "Unsupported storage type: \n" (* TODO: Return result instead of exit *) let report_error = function Ok c -> c | Error err -> report err; exit 1 let compile_contract ~config contract = - let contract = report_error @@ IR_of_michelson.compile_contract contract in + let open Lwt_result.Syntax in + let open Proto_alpha_utils.Memory_proto_alpha in + let canonical_contract = Result.get_ok @@ Protocol.Michelson_v1_primitives.prims_of_strings contract in + let+ typed_contract, _ = + let code = lazy_expr canonical_contract in + Protocol.Script_ir_translator.parse_code + (dummy_environment ()).tezos_context + ~legacy:false + ~code:code + in + let contract = report_error @@ IR_of_michelson.compile_contract typed_contract in Wasm_of_ir.compile_ir ~memory:config.memory ~optimize:config.optimize @@ -51,4 +60,8 @@ let compile_contract ~config contract = ~shared_memory:config.shared_memory contract +let compile_contract ~config contract = + let contract = Tezos_micheline.Micheline.strip_locations contract in + Lwt_result.map_error (fun _ -> "Error") @@ compile_contract ~config contract + let compile_value = Serialize.compile_value \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.mli b/deku-c/tunac/lib/tunac.mli index b6821b91af..460b545131 100644 --- a/deku-c/tunac/lib/tunac.mli +++ b/deku-c/tunac/lib/tunac.mli @@ -1,5 +1,5 @@ -type node = (int, Michelson_v1_primitives.prim) Tezos_micheline.Micheline.node +type node = (int, string) Tezos_micheline.Micheline.node type contract = node @@ -11,6 +11,6 @@ type config = val parse : string -> contract -val compile_contract : config:config -> contract -> Binaryen.Module.t +val compile_contract : config:config -> contract -> (Binaryen.Module.t, string) Lwt_result.t val compile_value : node -> bytes \ No newline at end of file diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index 5c01a51235..7c222578a6 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -14,9 +14,18 @@ let rec compile_expression wasm_mod expr = | Cop (op, params) -> compile_operation wasm_mod op params and compile_operation wasm_mod op params = + let compile_load cell typ ptr = + (* TODO: How know if its signed or not? *) + match typ with + | I8 -> Expression.Load.make wasm_mod 1 (cell * 4) 0 Type.int32 ptr + | U8 -> Expression.Load.make wasm_mod 1 (cell * 4) 0 Type.int32 ptr + | I32 -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 ptr + | U32 -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 ptr + in + match op, params with | Capply name, params -> Expression.Call.make wasm_mod name (List.map (compile_expression wasm_mod) params) Type.int32 - | Cload cell, [ ptr ] -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 (compile_expression wasm_mod ptr) + | Cload (cell, typ), [ ptr ] -> compile_load cell typ (compile_expression wasm_mod ptr) | Calloc size, params -> let final_size = match size, params with @@ -35,11 +44,11 @@ and compile_operation wasm_mod op params = (Expression.Global_get.make wasm_mod "heap_top" Type.int32) final_size) ; Expression.Local_get.make wasm_mod 0 Type.int32 ] - | Cwasm wasm_operation, params -> compile_wasm_operation wasm_mod wasm_operation params + | Cwasm (wasm_operation, typ), params -> compile_wasm_operation wasm_mod typ wasm_operation params | _ -> failwith "Invalid operation format, check operation arguments." -and compile_wasm_operation wasm_mod operation params = +and compile_wasm_operation wasm_mod typ operation params = let op2 op x y = Expression.Binary.make wasm_mod op (compile_expression wasm_mod x) @@ -48,30 +57,37 @@ and compile_wasm_operation wasm_mod operation params = let op1 op x = Expression.Unary.make wasm_mod op (compile_expression wasm_mod x) in - match operation, params with - | Wasm_add, [ a; b ] -> op2 Op.add_int32 a b - | Wasm_sub, [ a; b ] -> op2 Op.sub_int32 a b - | Wasm_mul, [ a; b ] -> op2 Op.mul_int32 a b - | Wasm_div, [ a; b ] -> op2 Op.div_s_int32 a b - | Wasm_rem, [ a; b ] -> op2 Op.rem_s_int32 a b - | Wasm_and, [ a; b ] -> op2 Op.and_int32 a b - | Wasm_or, [ a; b ] -> op2 Op.or_int32 a b - | Wasm_xor, [ a; b ] -> op2 Op.xor_int32 a b - | Wasm_eq, [ a; b ] -> op2 Op.eq_int32 a b - | Wasm_ne, [ a; b ] -> op2 Op.ne_int32 a b - | Wasm_lt, [ a; b ] -> op2 Op.lt_s_int32 a b - | Wasm_gt, [ a; b ] -> op2 Op.gt_s_int32 a b - | Wasm_le, [ a; b ] -> op2 Op.le_s_int32 a b - | Wasm_ge, [ a; b ] -> op2 Op.ge_s_int32 a b - | Wasm_shl, [ a; b ] -> op2 Op.shl_int32 a b - | Wasm_shr, [ a; b ] -> op2 Op.shr_s_int32 a b - | Wasm_rotl, [ a; b ] -> op2 Op.rot_l_int32 a b - | Wasm_rotr, [ a; b ] -> op2 Op.rot_r_int32 a b - - | Wasm_clz, [ a ] -> op1 Op.clz_int32 a - | Wasm_ctz, [ a ] -> op1 Op.ctz_int32 a - | Wasm_popcnt, [ a ] -> op1 Op.popcnt_int32 a - | Wasm_eqz, [ a ] -> op1 Op.eq_z_int32 a + match operation, typ, params with + | Wasm_add, _, [ a; b ] -> op2 Op.add_int32 a b + | Wasm_sub, _, [ a; b ] -> op2 Op.sub_int32 a b + | Wasm_mul, _, [ a; b ] -> op2 Op.mul_int32 a b + | Wasm_div, (I32 | I8), [ a; b ] -> op2 Op.div_s_int32 a b + | Wasm_div, (U32 | U8), [ a; b ] -> op2 Op.div_u_int32 a b + | Wasm_rem, (I32 | I8), [ a; b ] -> op2 Op.rem_s_int32 a b + | Wasm_rem, (U32 | U8), [ a; b ] -> op2 Op.rem_u_int32 a b + | Wasm_and, _, [ a; b ] -> op2 Op.and_int32 a b + | Wasm_or, _, [ a; b ] -> op2 Op.or_int32 a b + | Wasm_xor, _, [ a; b ] -> op2 Op.xor_int32 a b + | Wasm_eq, _, [ a; b ] -> op2 Op.eq_int32 a b + | Wasm_ne, _, [ a; b ] -> op2 Op.ne_int32 a b + | Wasm_lt, (I32 | I8), [ a; b ] -> op2 Op.lt_s_int32 a b + | Wasm_lt, (U32 | U8), [ a; b ] -> op2 Op.lt_u_int32 a b + | Wasm_gt, (I32 | I8), [ a; b ] -> op2 Op.gt_s_int32 a b + | Wasm_gt, (U32 | U8), [ a; b ] -> op2 Op.gt_u_int32 a b + | Wasm_le, (I32 | I8), [ a; b ] -> op2 Op.le_s_int32 a b + | Wasm_le, (U32 | U8), [ a; b ] -> op2 Op.le_u_int32 a b + | Wasm_ge, (I32 | I8), [ a; b ] -> op2 Op.ge_s_int32 a b + | Wasm_ge, (U32 | U8), [ a; b ] -> op2 Op.ge_u_int32 a b + | Wasm_shl, _, [ a; b ] -> op2 Op.shl_int32 a b + | Wasm_shr, (I32 | I8), [ a; b ] -> op2 Op.shr_s_int32 a b + | Wasm_shr, (U32 | U8), [ a; b ] -> op2 Op.shr_u_int32 a b + | Wasm_rotl, _, [ a; b ] -> op2 Op.rot_l_int32 a b + | Wasm_rotr, _, [ a; b ] -> op2 Op.rot_r_int32 a b + + | Wasm_clz, _, [ a ] -> op1 Op.clz_int32 a + | Wasm_ctz, _, [ a ] -> op1 Op.ctz_int32 a + | Wasm_popcnt, _, [ a ] -> op1 Op.popcnt_int32 a + | Wasm_eqz, _, [ a ] -> op1 Op.eq_z_int32 a | _ -> failwith "Invalid WASM operation" @@ -158,7 +174,7 @@ let compile_exec_function wasm_mod lambdas = let compile_ir ~memory ~optimize ~debug ~shared_memory contract = let wasm_mod = Module.create () in - let IR_of_michelson.{ main; lambdas } = contract in + let IR_of_michelson.{ main; lambdas; static_data } = contract in add_function wasm_mod "main" main; if lambdas <> [] then @@ -192,7 +208,8 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = Import.add_function_import wasm_mod "failwith" "env" "failwith" Type.int32 Type.none; let (initial, max) = memory in - Memory.set_memory wasm_mod initial max "memory" [] shared_memory; + let segments = [ Memory.{ data = static_data; kind = Passive; size = Bytes.length static_data } ] in + Memory.set_memory wasm_mod initial max "memory" segments shared_memory; (* if Module.validate wasm_mod <> 0 then failwith "Generated module is invalid"; *) diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml index 66ce0553e8..70fd1ddb47 100644 --- a/deku-c/tunac/tests/compile.ml +++ b/deku-c/tunac/tests/compile.ml @@ -21,12 +21,16 @@ let save_module wasm_mod filename = open Cmdliner let compile_contract print debug optimize shared_memory output memory = + let open Lwt_result.Syntax in let config = Tunac.{ debug; shared_memory; optimize; memory } in - let wasm_mod = Tunac.compile_contract ~config contract in + let+ wasm_mod = Tunac.compile_contract ~config contract in if print then Binaryen.Module.print wasm_mod; save_module wasm_mod output +let compile_contract print debug optimize shared_memory output memory = + Result.get_ok @@ Lwt_main.run @@ compile_contract print debug optimize shared_memory output memory + let compile_value () = let value = Tunac.compile_value contract in print_bytes value diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index b3b721f213..07edd40ece 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -176,111 +176,111 @@ async function main() { res = await eval(` { parameter (or (or int int) unit); storage int; - code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { DROP 2; PUSH int 0 }; NIL operation; PAIR } } `, { prim: 'Left', args: [ { prim: 'Right', args: [ { int: 13 } ], annots: [] } ], annots: [] }, { int: 42 }) assertStorage(res, '37000000') res = await eval(` { parameter (or (or int int) unit); storage int; - code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { DROP 2; PUSH int 0 }; NIL operation; PAIR } } `, { prim: 'Left', args: [ { prim: 'Left', args: [ { int: 13 } ], annots: [] } ], annots: [] }, { int: 42 }) assertStorage(res, '1d000000') res = await eval(` { parameter (or (or int int) unit); storage int; - code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { PUSH int 0 }; NIL operation; PAIR } } + code { UNPAIR; IF_LEFT { IF_LEFT { SWAP; SUB } { ADD } } { DROP 2; PUSH int 0 }; NIL operation; PAIR } } `, { prim: 'Right', args: [ { prim: 'Unit', args: [], annots: [] } ], annots: [] }, { int: 42 }) assertStorage(res, '00000000') - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIG 2 } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - // inspect_all(res.exports) - assert(stack_n(res.exports, 0) === 3) - assert(stack_n(res.exports, 2) === 4) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUG 2 } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) === 4) - assert(stack_n(res.exports, 1) === 3) - assert(stack_n(res.exports, 2) === 5) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 4; PUSH int 5; DROP } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) === 4) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 3; PUSH int 4; PUSH int 5; DROP 2 } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) === 3) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 4; PUSH int 5; DUP } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) === 5) - assert(stack_n(res.exports, 1) === 5) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUP 3 } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) === 3) - assert(stack_n(res.exports, 1) === 5) - - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 2 { PUSH int 7 } } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) == 5) - assert(stack_n(res.exports, 1) == 4) - assert(stack_n(res.exports, 2) == 7) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP { PUSH int 7 } } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) == 5) - assert(stack_n(res.exports, 1) == 7) - assert(stack_n(res.exports, 2) == 4) - - res = await eval(` - { parameter unit; - storage int; - code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 0 { PUSH int 7 } } } - `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - assert(stack_n(res.exports, 0) == 7) - assert(stack_n(res.exports, 1) == 5) - assert(stack_n(res.exports, 2) == 4) - - - // try { - // await eval(` - // { parameter unit; - // storage int; - // code { PUSH int 42; FAILWITH } - // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - // assert(false) - // } catch (e) { - // console.log(e) - // } + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIG 2 } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // // inspect_all(res.exports) + // assert(stack_n(res.exports, 0) === 3) + // assert(stack_n(res.exports, 2) === 4) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUG 2 } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) === 4) + // assert(stack_n(res.exports, 1) === 3) + // assert(stack_n(res.exports, 2) === 5) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 4; PUSH int 5; DROP } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) === 4) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 3; PUSH int 4; PUSH int 5; DROP 2 } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) === 3) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 4; PUSH int 5; DUP } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) === 5) + // assert(stack_n(res.exports, 1) === 5) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DUP 3 } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) === 3) + // assert(stack_n(res.exports, 1) === 5) + + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 2 { PUSH int 7 } } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) == 5) + // assert(stack_n(res.exports, 1) == 4) + // assert(stack_n(res.exports, 2) == 7) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP { PUSH int 7 } } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) == 5) + // assert(stack_n(res.exports, 1) == 7) + // assert(stack_n(res.exports, 2) == 4) + + // res = await eval(` + // { parameter unit; + // storage int; + // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIP 0 { PUSH int 7 } } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assert(stack_n(res.exports, 0) == 7) + // assert(stack_n(res.exports, 1) == 5) + // assert(stack_n(res.exports, 2) == 4) + + + // // try { + // // await eval(` + // // { parameter unit; + // // storage int; + // // code { PUSH int 42; FAILWITH } + // // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // // assert(false) + // // } catch (e) { + // // console.log(e) + // // } res = await eval(` { parameter bool; storage int; code { CAR; IF { PUSH int 42 } { PUSH int 50 }; NIL operation; PAIR } } @@ -298,7 +298,7 @@ async function main() { assertStorage(res, '2a000000') res = await eval(` - { parameter (list int); storage int; code { CAR; IF_CONS { } { PUSH int 50 }; NIL operation; PAIR } } + { parameter (list int); storage int; code { CAR; IF_CONS { SWAP; DROP } { PUSH int 50 }; NIL operation; PAIR } } `, [], { int: 42 }) assertStorage(res, '32000000') @@ -325,6 +325,34 @@ async function main() { code { CAR ; PUSH int 0 ; SWAP ; ITER { ADD } ; NIL operation ; PAIR } } `, [ { int: 1 }, { int: 2 }, { int: 3 }, { int: 4 }, { int: 5 } ], { int: 42 }) assertStorage(res, '0f000000') + + res = await eval(` + { parameter unit ; + storage int ; + code { DROP ; UNIT ; UNIT ; COMPARE ; NIL operation ; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '00000000') + + res = await eval(` + { parameter unit ; + storage int ; + code { DROP ; PUSH int 42 ; PUSH int 42 ; COMPARE ; NIL operation ; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '00000000') + + res = await eval(` + { parameter unit ; + storage int ; + code { DROP ; PUSH int 10 ; PUSH int 42 ; COMPARE ; NIL operation ; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '01000000') + + res = await eval(` + { parameter unit ; + storage int ; + code { DROP ; PUSH int 42 ; PUSH int 10 ; COMPARE ; NIL operation ; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, 'ffffffff') } main() \ No newline at end of file diff --git a/deku-p/src/core/bin/api/handlers.ml b/deku-p/src/core/bin/api/handlers.ml index e83010e39c..c69b45c855 100644 --- a/deku-p/src/core/bin/api/handlers.ml +++ b/deku-p/src/core/bin/api/handlers.ml @@ -379,25 +379,8 @@ module Helper_compile_origination : HANDLERS = struct let path = Routes.(version / s "helpers" / s "compile-contract" /? nil) let route = Routes.(path @--> ()) - let handler ~path:() ~body:{ source; storage } ~state:_ = - let tickets, init = Tunac.Compiler.compile_value storage |> Result.get_ok in - let inputs = source in - let wat, constants, entrypoints = - inputs |> Tunac.Compiler.compile |> Result.get_ok - in - let out = Tunac.Output.make wat constants |> Result.get_ok in - let entrypoints = entrypoints |> Option.value ~default:[] in - Operation_payload. - { - tickets; - operation = - Operation.Originate - { - module_ = out.module_; - entrypoints = Entrypoints.of_assoc entrypoints; - constants; - initial_storage = init; - }; - } - |> Result.ok + let handler ~path:() ~body:{ source = _; storage = _ } ~state:_ = + (* TODO: Rebuild it *) + assert false + end From 7f95d716d6d847eba5922141a28059f0378040a4 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Fri, 11 Nov 2022 19:26:33 -0300 Subject: [PATCH 12/21] Add Ligo's proto-alpha-utils and other Tezos libs --- flake.lock | 34 +++++++------- flake.nix | 18 +------- nix/deku-c/tuna.nix | 2 + nix/deku-p/default.nix | 1 - nix/overlay.nix | 102 +++++++++++++++++++++++++++++++++++------ 5 files changed, 108 insertions(+), 49 deletions(-) diff --git a/flake.lock b/flake.lock index 522666df7d..fca1a8a3b5 100644 --- a/flake.lock +++ b/flake.lock @@ -344,11 +344,11 @@ "nixpkgs": "nixpkgs_4" }, "locked": { - "lastModified": 1666385520, - "narHash": "sha256-8CxheRKzn6EsGPb1lEN5sEQTid9Mu7CCXv6l81rRf/k=", + "lastModified": 1667918602, + "narHash": "sha256-xuaLYdpSQhb6MbLm+n18BfBvremnriumpgtew2KfyJE=", "owner": "ligolang", "repo": "ligo", - "rev": "88f20b57b9ff67df84763e4cf9c25d776b0bccbd", + "rev": "0875c3efbd093e8571d6dfe8e6a5dab167e38734", "type": "gitlab" }, "original": { @@ -624,11 +624,11 @@ "tezos_trunk": "tezos_trunk" }, "locked": { - "lastModified": 1666034281, - "narHash": "sha256-l6cQLvxdn/0oey0sb/Z6H45VUOc4ircG3UCckBvlXXI=", + "lastModified": 1667990127, + "narHash": "sha256-bI7GaRS43aU3Fvuj8UOUKaxrS9H+x+kyLYTEfQ7n95o=", "owner": "marigold-dev", "repo": "tezos-nix", - "rev": "7ae62c648880b55a2900e2f923d1334b7014fe18", + "rev": "3f08e555f1f4e879e69345ab639b850d8d4995eb", "type": "github" }, "original": { @@ -640,28 +640,28 @@ "tezos_release": { "flake": false, "locked": { - "lastModified": 1664977956, - "narHash": "sha256-H/ZQRIukMlGxF1cCe4A2tYB3nteBpjcqRI+aDmsmGgg=", - "owner": "tezos", + "lastModified": 1668205438, + "narHash": "sha256-g2RICpo7SOo+tCETMBha7D59pWEJ4WL6iDM32pAlqTk=", + "owner": "renatoalencar", "repo": "tezos", - "rev": "073ae295ea293693f35cfe6613f2b1bb1fefb3aa", - "type": "gitlab" + "rev": "ee48822e91d8d71b5d4e390061facb02dbb4affe", + "type": "github" }, "original": { - "owner": "tezos", - "ref": "v14.1", + "owner": "renatoalencar", "repo": "tezos", - "type": "gitlab" + "rev": "ee48822e91d8d71b5d4e390061facb02dbb4affe", + "type": "github" } }, "tezos_trunk": { "flake": false, "locked": { - "lastModified": 1665996621, - "narHash": "sha256-nYg2gVRcuC/ogPWXAVErR+HDsxwXIbnHkkik9AkoYIM=", + "lastModified": 1667824574, + "narHash": "sha256-7ub0OCki0aaPQSvGBmv8DPoFTqvJDNEoSAywPbhJft8=", "owner": "tezos", "repo": "tezos", - "rev": "52d97a7da45a467cb722b494eebcc562aff75525", + "rev": "4a3cd1b1c8ad44445192475fdde5073ebae2ccde", "type": "gitlab" }, "original": { diff --git a/flake.nix b/flake.nix index 9b2af902b6..43b69c0abb 100644 --- a/flake.nix +++ b/flake.nix @@ -20,6 +20,7 @@ tezos.inputs = { nixpkgs.follows = "nixpkgs"; flake-parts.follows = "flake-parts"; + tezos_release.url = "github:renatoalencar/tezos/ee48822e91d8d71b5d4e390061facb02dbb4affe"; }; deploy-rs.url = "github:serokell/deploy-rs"; }; @@ -59,23 +60,6 @@ inherit system; extraOverlays = [ tezos.overlays.default - (final: prev: { - ocaml-ng = - prev.ocaml-ng - // { - ocamlPackages_5_00 = - prev.ocaml-ng.ocamlPackages_5_00.overrideScope' - (oself: osuper: { - ringo = osuper.ringo.overrideAttrs (_: { - src = builtins.fetchurl { - url = - https://gitlab.com/nomadic-labs/ringo/-/archive/5514a34ccafdea498e4b018fb141217c1bf43da9/ringo-5514a34ccafdea498e4b018fb141217c1bf43da9.tar.gz; - sha256 = "1qadbvmqirn1scc4r4lwzqs4rrwmp1vnzhczy9pipfnf9bb9c0j7"; - }; - }); - }); - }; - }) (import ./nix/overlay.nix) (final: prev: { ocamlPackages = prev.ocaml-ng.ocamlPackages_5_00; diff --git a/nix/deku-c/tuna.nix b/nix/deku-c/tuna.nix index 4dd8394eca..2a321d5b74 100644 --- a/nix/deku-c/tuna.nix +++ b/nix/deku-c/tuna.nix @@ -5,6 +5,7 @@ tezos-micheline, alcotest, binaryen, + proto-alpha-utils, }: buildDunePackage rec { pname = "deku"; @@ -23,6 +24,7 @@ buildDunePackage rec { propagatedBuildInputs = [ tezos-micheline binaryen + proto-alpha-utils ]; buildInputs = [ diff --git a/nix/deku-p/default.nix b/nix/deku-p/default.nix index 080bf2709e..976feef1af 100644 --- a/nix/deku-p/default.nix +++ b/nix/deku-p/default.nix @@ -46,7 +46,6 @@ packages = { default = deku; inherit deku deku-static docker; - ligo-utils = pkgs.ocamlPackages.proto-alpha-utils; }; apps = { node = { diff --git a/nix/overlay.nix b/nix/overlay.nix index e3078770c6..94c541a4a0 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -45,19 +45,68 @@ with super; { }; }); - tezos-stdlib = super.tezos-stdlib.overrideAttrs (_: { - postPatch = '' - substituteInPlace "src/lib_stdlib/hash_queue.mli" --replace \ - "val filter : t -> (K.t -> V.t -> bool) -> unit" \ - "" - ''; + ringo = oself.buildDunePackage rec { + pname = "ringo"; + version = "1.0.0"; + + src = fetchFromGitLab { + owner = "nomadic-labs"; + repo = "ringo"; + rev = "v${version}"; + sha256 = "9HW3M27BxrEPbF8cMHwzP8FmJduUInpQQAE2672LOuU="; + }; + }; + + aches = oself.buildDunePackage rec { + pname = "aches"; + inherit (super.ringo) src version; + propagatedBuildInputs = [super.ringo]; + }; + + aches-lwt = oself.buildDunePackage rec { + pname = "aches-lwt"; + inherit (super.ringo) src version; + + propagatedBuildInputs = [ + super.aches + lwt + ]; + }; + + resto = super.resto.overrideAttrs (_: rec { + version = "1.0"; + src = fetchFromGitLab { + owner = "nomadic-labs"; + repo = "resto"; + rev = "v${version}"; + sha256 = "sha256-DIm7fmISsCgRDi4p3NsUk7Cvs/dHpIKMdAOVdYLX2mc="; + }; + }); + + tezos-proxy = super.tezos-proxy.overrideAttrs (self: { + propagatedBuildInputs = with super; with lib.lists; + [aches aches-lwt] ++ (remove ringo-lwt (remove ringo self.propagatedBuildInputs)); + }); + + tezos-store = super.tezos-store.overrideAttrs (self: { + propagatedBuildInputs = with super; with lib.lists; + [aches aches-lwt] ++ (remove ringo-lwt (remove ringo self.propagatedBuildInputs)); + }); + + tezos-stdlib = super.tezos-stdlib.overrideAttrs (self: { + propagatedBuildInputs = with super; with lib.lists; + [aches] ++ (remove ringo-lwt (remove ringo self.propagatedBuildInputs)); + }); + + tezos-protocol-environment = super.tezos-protocol-environment.overrideAttrs (self: { + propagatedBuildInputs = with super; with lib.lists; + [aches aches-lwt] ++ (remove ringo-lwt (remove ringo self.propagatedBuildInputs)); }); + tezos-micheline = super.tezos-micheline.overrideAttrs (_: { doCheck = false; }); - tezos-crypto = super.tezos-crypto.overrideAttrs (_: { - patches = [./deku-p/patches/tezos-crypto.patch]; - }); + routes = super.routes.overrideAttrs (_: { src = fetchFromGitHub { owner = "anuragsoni"; @@ -105,6 +154,33 @@ with super; { ]; }; + ligo-tezos-utils = oself.buildDunePackage rec { + pname = "tezos-utils"; + inherit (self.ligo) version; + src = "${self.ligo.src}/vendors/ligo-utils/tezos-utils"; + + propagatedBuildInputs = with oself; [ + tezos-error-monad + tezos-stdlib-unix + tezos-micheline + tezos-base + data-encoding + ligo-simple-utils + base + ]; + }; + + ligo-memory-proto-alpha = oself.buildDunePackage rec { + pname = "tezos-memory-proto-alpha"; + inherit (self.ligo) version; + src = "${self.ligo.src}/vendors/ligo-utils/memory-proto-alpha"; + + propagatedBuildInputs = with oself; [ + tezos-protocol-environment + tezos-014-PtKathma.protocol + ]; + }; + proto-alpha-utils = oself.buildDunePackage rec { pname = "proto-alpha-utils"; inherit (self.ligo) version; @@ -139,12 +215,10 @@ with super; { tezos-crypto tezos-error-monad tezos-stdlib-unix - tezos-protocol-environment - tezos-011-PtHangz2.protocol - tezos-011-PtHangz2.client - # tezos-memory-proto-alpha + tezos-014-PtKathma.client + ligo-memory-proto-alpha ligo-simple-utils - # tezos-utils + ligo-tezos-utils ]; }; }); From 1d839487d815fe53e06f2c1076ed12caddad82ee Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 15 Nov 2022 11:49:43 -0300 Subject: [PATCH 13/21] Support for get and update on maps --- deku-c/tunac/lib/iR_of_michelson.ml | 30 +++++++++--- deku-c/tunac/lib/wasm_of_ir.ml | 2 +- deku-c/tunac/tests/tests.js | 76 +++++++++++++++++++++++++++++ 3 files changed, 100 insertions(+), 8 deletions(-) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index ca06ff0965..cd78a3db89 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -276,23 +276,22 @@ let compile_map_get env key_type map key value = let compare = Env.alloc_local env in let block = Cblock - [ Cwhile + [ Cassign (value, Cconst_i32 0l) + ; Cwhile (Cvar map , Cblock - [ compile_compare env (Cvar key) (Data.car (Data.car (Cvar map))) compare key_type ]) + [ compile_compare env (Cvar key) (Data.car (Data.car (Cvar map))) compare key_type ; Cifthenelse (Cop (Cwasm (Wasm_eqz, I32), [ Cvar compare ]) , Cblock - [ Cassign (value, Cop (Calloc 2, [])) - ; Cstore (0, Cvar value, Cconst_i32 1l) - ; Cstore (1, Cvar value, Data.cdr (Data.car (Cvar map))) + [ Cassign (value, Data.cdr (Data.car (Cvar map))) ; Cassign (map, Cconst_i32 0l) ] - , Cassign (value, Cconst_i32 0l)) ] + , Cassign (map, Data.cdr (Cvar map))) ]) ] in Env.free_local env compare; block -let compile_update env map key value = +let compile_update_map env map key value = let head = Env.alloc_local env in let entry = Env.alloc_local env in let block = @@ -912,6 +911,23 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Env.free_local env value; Cblock [ block; compile_instruction env k ] + | IMap_update (_, k) -> + let map = Env.alloc_local env in + let key = Env.alloc_local env in + let value = Env.alloc_local env in + let block = + Cblock + [ compile_pop key + ; compile_pop value + ; compile_pop map + ; compile_update_map env map key value + ; compile_push ~env (Cvar map) ] + in + Env.free_local env map; + Env.free_local env key; + Env.free_local env value; + Cblock [ block; compile_instruction env k ] + | IHalt _ -> Cblock [] | _instr -> raise (Compilation_error (Unsupported_instruction)) diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index 7c222578a6..4b2fe8db61 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -146,7 +146,7 @@ let rec compile_statement wasm_mod statement = let add_function wasm_mod name fn = let IR_of_michelson.{ body; locals } = fn in - let locals = Array.make locals Type.int32 in + let locals = Array.make (locals + 1) Type.int32 in let expr = compile_statement wasm_mod body in ignore @@ Function.add_function wasm_mod name Type.none Type.none locals expr; ignore @@ Export.add_function_export wasm_mod name name diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index 07edd40ece..e5c7e39a58 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -353,6 +353,82 @@ async function main() { code { DROP ; PUSH int 42 ; PUSH int 10 ; COMPARE ; NIL operation ; PAIR } } `, { prim: 'Unit', args: [], annots: [] }, { int: 42 }) assertStorage(res, 'ffffffff') + + res = await eval(` + { parameter unit; + storage int; + code { + DROP; + EMPTY_MAP int int; + PUSH int 33; + SOME; + PUSH int 42; + UPDATE; + PUSH int 42; + GET; + IF_NONE { PUSH int 0 } { }; + NIL operation; + PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assertStorage(res, '21000000') + + res = await eval(` + { parameter unit; + storage int; + code { + DROP; + EMPTY_MAP int int; + PUSH int 42; + GET; + IF_NONE { PUSH int 50 } { }; + NIL operation; + PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assertStorage(res, '32000000') + + res = await eval(` + { parameter unit; + storage int; + code { + DROP; + EMPTY_MAP int int; + PUSH int 33; + SOME; + PUSH int 42; + UPDATE; + PUSH int 50; + SOME; + PUSH int 43; + UPDATE; + PUSH int 42; + GET; + IF_NONE { PUSH int 0 } { }; + NIL operation; + PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assertStorage(res, '21000000') + + res = await eval(` + { parameter unit; + storage int; + code { + DROP; + EMPTY_MAP int int; + PUSH int 33; + SOME; + PUSH int 42; + UPDATE; + PUSH int 50; + SOME; + PUSH int 43; + UPDATE; + PUSH int 43; + GET; + IF_NONE { PUSH int 0 } { }; + NIL operation; + PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assertStorage(res, '32000000') } main() \ No newline at end of file From 630cf21c0bfb9e05c2001814d712bdccb4fd8e94 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Mon, 21 Nov 2022 18:14:34 -0300 Subject: [PATCH 14/21] Fix encoding so FA1.2 can run --- deku-c/tunac/lib/dune | 3 +- deku-c/tunac/lib/iR_of_michelson.ml | 540 +++++++++++++++++++++++----- deku-c/tunac/lib/wasm_of_ir.ml | 33 +- deku-c/tunac/tests/dune | 2 +- deku-c/tunac/tests/fa12.tz | 235 ++++++++++++ deku-c/tunac/tests/tests.js | 286 ++++++++++++++- 6 files changed, 996 insertions(+), 103 deletions(-) create mode 100644 deku-c/tunac/tests/fa12.tz diff --git a/deku-c/tunac/lib/dune b/deku-c/tunac/lib/dune index 5b01650935..e7548f7c03 100644 --- a/deku-c/tunac/lib/dune +++ b/deku-c/tunac/lib/dune @@ -1,3 +1,4 @@ (library (name tunac) - (libraries tezos-micheline binaryen proto-alpha-utils)) + (libraries tezos-micheline binaryen proto-alpha-utils) + (preprocess (pps ppx_deriving.show))) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index cd78a3db89..df3a1e9099 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -309,6 +309,19 @@ let compile_update_map env map key value = block let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> statement = fun env instr -> + let int_operation typ op = + let x = Env.alloc_local env in + let y = Env.alloc_local env in + let block = + Cblock [ compile_pop x + ; compile_pop y + ; compile_push ~env (Cop (Cwasm (op, typ), [ Cvar x; Cvar y ])) ] + in + Env.free_local env x; + Env.free_local env x; + block + in + match instr with | ICar (_, k) -> let top = Env.alloc_local env in @@ -338,47 +351,35 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Env.free_local env top; Cblock [ block; compile_instruction env k ] + | IAdd_tez (_, k) -> + let block = int_operation I32 Wasm_add in + Cblock [ block; compile_instruction env k ] + + | ISub_tez (_, k) -> + let block = int_operation I32 Wasm_sub in + Cblock [ block; compile_instruction env k ] + + | IAdd_nat (_, k) -> + let block = int_operation U32 Wasm_add in + Cblock [ block; compile_instruction env k ] + | IAdd_int (_, k) -> - let x = Env.alloc_local env in - let y = Env.alloc_local env in - let block = - Cblock [ compile_pop x - ; compile_pop y - ; compile_push ~env (Cop (Cwasm (Wasm_add, I32), [ Cvar x; Cvar y ])) ] - in - Env.free_local env x; - Env.free_local env x; + let block = int_operation I32 Wasm_add in Cblock [ block; compile_instruction env k ] | ISub_int (_, k) -> - let x = Env.alloc_local env in - let y = Env.alloc_local env in - let block = - Cblock [ compile_pop x - ; compile_pop y - ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cvar x; Cvar y ])) ] - in - Env.free_local env x; - Env.free_local env y; + let block = int_operation I32 Wasm_sub in Cblock [ block; compile_instruction env k ] | IMul_int (_, k) -> - let x = Env.alloc_local env in - let y = Env.alloc_local env in - let block = - Cblock [ compile_pop x - ; compile_pop y - ; compile_push ~env (Cop (Cwasm (Wasm_mul, I32), [ Cvar x; Cvar y ])) ] - in - Env.free_local env x; - Env.free_local env y; + let block = int_operation I32 Wasm_mul in Cblock [ block; compile_instruction env k ] | INeg (_, k) -> let x = Env.alloc_local env in let block = Cblock [ compile_pop x - ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cconst_i32 0l; Cvar x ])) ] + ; compile_push ~env (Cop (Cwasm (Wasm_sub, I32), [ Cconst_i32 0l; Cvar x ])) ] in Env.free_local env x; Cblock [ block; compile_instruction env k ] @@ -497,13 +498,16 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Cblock [ block; compile_instruction env k ] | IConst (_, Unit_t, (), k) -> - Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + let p = compile_push ~env (Cconst_i32 0l) in + Cblock [ p; compile_instruction env k ] | ICons_none (_, _, k) -> - Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + let p = compile_push ~env (Cconst_i32 0l) in + Cblock [ p; compile_instruction env k ] | INil (_, _, k) -> - Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + let statement = compile_push ~env (Cconst_i32 0l) in + Cblock [ statement; compile_instruction env k ] | ICons_list (_, k) -> let value = Env.alloc_local env in @@ -555,7 +559,8 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state | ICons_pair (_, k) -> (* TODO: Support IComb *) - Cblock [ compile_pair ~env; compile_instruction env k ] + let statement = compile_pair ~env in + Cblock [ statement; compile_instruction env k ] | ICons_some (_, k) -> (* TODO: I actually think that optionals may have only one cell allocated *) @@ -647,45 +652,74 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state | IConst (_, Int_t, z, k) -> let value = Int64.to_int32 @@ Option.get @@ Script_int.to_int64 z in - Cblock [ compile_push ~env (Cconst_i32 value); compile_instruction env k ] + let statement = compile_push ~env (Cconst_i32 value) in + Cblock [ statement; compile_instruction env k ] + + | IConst (_, Nat_t, z, k) -> + let value = Int64.to_int32 @@ Option.get @@ Script_int.to_int64 z in + let statement = compile_push ~env (Cconst_i32 value) in + Cblock [ statement; compile_instruction env k ] + + | IConst (_, Mutez_t, tz, k) -> + let value = Int64.to_int32 @@ Alpha_context.Tez.to_mutez tz in + let statement = compile_push ~env (Cconst_i32 value) in + Cblock [ statement; compile_instruction env k ] | IConst (_, String_t, v, k) -> let addr = Int32.of_int @@ Bytes.length !static_data in (* C strings will do it for now *) - static_data := Bytes.cat !static_data (Bytes.of_string @@ Script_string.to_string v ^ "\000"); - Cblock [ compile_push ~env (Cconst_i32 addr); compile_instruction env k ] + let len = + let b = Bytes.create 4 in + Bytes.set_int32_le b 0 (Int32.of_int (Script_string.length v)); + b + in + static_data := + Bytes.(cat !static_data (cat len (of_string @@ Script_string.to_string v ^ "\000"))); + let statement = compile_push ~env (Cconst_i32 addr) in + Cblock [ statement; compile_instruction env k ] | IEmpty_map (_, _, _, k) -> - Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + let statement = compile_push ~env (Cconst_i32 0l) in + Cblock [ statement; compile_instruction env k ] | IEmpty_set (_, _, k) -> - Cblock [ compile_push ~env (Cconst_i32 0l); compile_instruction env k ] + let statement = compile_push ~env (Cconst_i32 0l) in + Cblock [ statement; compile_instruction env k ] | IDig (_, n, _, k) -> - Cblock [ compile_dig ~env (Int32.of_int n); compile_instruction env k ] + let statement = compile_dig ~env (Int32.of_int n) in + Cblock [ statement; compile_instruction env k ] | IDug (_, n, _, k) -> - Cblock [ compile_dug ~env (Int32.of_int n); compile_instruction env k ] + let statement = compile_dug ~env (Int32.of_int n) in + Cblock [ statement; compile_instruction env k ] | IDrop (_, k) -> - Cblock [ compile_drop ~env 1l; compile_instruction env k ] + let statement = compile_drop ~env 1l in + Cblock [ statement; compile_instruction env k ] | IDropn (_, n, _, k) -> - Cblock [ compile_drop ~env (Int32.of_int n); compile_instruction env k ] + let statement = compile_drop ~env (Int32.of_int n) in + Cblock [ statement; compile_instruction env k ] | IDup (_, k) -> - Cblock [ compile_dup ~env 1l; compile_instruction env k ] + let statement = compile_dup ~env 1l in + Cblock [ statement; compile_instruction env k ] | IDup_n (_, n, _, k) -> - Cblock [ compile_dup ~env (Int32.of_int n); compile_instruction env k ] + let statement = compile_dup ~env (Int32.of_int n) in + Cblock [ statement; compile_instruction env k ] | IDipn (_, n, _, b, k) -> let block = compile_instruction env b in if n = 0 then block - else Cblock [ compile_dip ~env (Int32.of_int n) block; compile_instruction env k ] + else + let statement = compile_dip ~env (Int32.of_int n) block in + Cblock [ statement; compile_instruction env k ] | IDip (_, b, _, k) -> - Cblock [ compile_dip ~env 1l (compile_instruction env b); compile_instruction env k ] + let statement = compile_dip ~env 1l (compile_instruction env b) in + Cblock [ statement; compile_instruction env k ] | IFailwith (_, _) -> let param = Env.alloc_local env in @@ -745,7 +779,7 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let lenv = Env.make () in let body = compile_instruction lenv body in let lambda_n = Int32.of_int (List.length !lambdas) in - lambdas := (body, env) :: !lambdas; + lambdas := (body, lenv) :: !lambdas; let p = Env.alloc_local env in let block = Cblock @@ -792,7 +826,9 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state ; Cassign (lambda, Data.cdr (Cvar lambda)) ; Cassign (argument, Cvar pair) ]) ; compile_push ~env (Cvar argument) - ; Cassign (-1, Cop (Capply "exec", [ Cvar lambda ])) ] + ; Cassign (lambda, Data.cdr (Cvar lambda)) + ; (* Just ignore the result *) + Cassign (argument, Cop (Capply "exec", [ Cvar lambda ])) ] in Env.free_local env argument; Env.free_local env lambda; @@ -872,12 +908,14 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Cblock [ block; compile_instruction env k ] | ISender (_, k) -> - Cblock [ compile_push ~env (Cop (Capply "sender", [])); compile_instruction env k ] + let statement = compile_push ~env (Cop (Capply "sender", [])) in + Cblock [ statement; compile_instruction env k ] | IAmount (_, k) -> - Cblock [ compile_push ~env (Cop (Capply "amount", [])); compile_instruction env k ] + let statement = compile_push ~env (Cop (Capply "amount", [])) in + Cblock [ statement; compile_instruction env k ] - | ITicket (_, typ, k) -> + | ITicket (_, _typ, k) -> let content = Env.alloc_local env in let amount = Env.alloc_local env in let ptr = Env.alloc_local env in @@ -885,7 +923,7 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let block = Cblock [ compile_pop content - ; compile_value_encoder env typ ptr size content + (* TODO encode ticket content *) ; compile_pop amount ; compile_push ~env (Cop (Capply "ticket", [ Cvar content; Cvar amount ])) ] in @@ -899,12 +937,14 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let map = Env.alloc_local env in let key = Env.alloc_local env in let value = Env.alloc_local env in + let map_get = compile_map_get env Int_t map key value in + let push = compile_push ~env (Cvar value) in let block = Cblock [ compile_pop key ; compile_pop map - ; compile_map_get env Int_t map key value - ; compile_push ~env (Cvar value) ] + ; map_get + ; push ] in Env.free_local env map; Env.free_local env key; @@ -915,19 +955,37 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let map = Env.alloc_local env in let key = Env.alloc_local env in let value = Env.alloc_local env in + let update = compile_update_map env map key value in + let push = compile_push ~env (Cvar map) in let block = Cblock [ compile_pop key ; compile_pop value ; compile_pop map - ; compile_update_map env map key value - ; compile_push ~env (Cvar map) ] + ; update + ; push ] in Env.free_local env map; Env.free_local env key; Env.free_local env value; Cblock [ block; compile_instruction env k ] + | ITransfer_tokens (_, k) -> + let arg = Env.alloc_local env in + let amount = Env.alloc_local env in + let contract = Env.alloc_local env in + let block = + Cblock + [ compile_pop arg + ; compile_pop amount + ; compile_pop contract + ; compile_push ~env (Cop (Capply "transfer_tokens", [ Cvar arg; Cvar amount; Cvar contract ])) ] + in + Env.free_local env arg; + Env.free_local env amount; + Env.free_local env contract; + Cblock [ block; compile_instruction env k ] + | IHalt _ -> Cblock [] | _instr -> raise (Compilation_error (Unsupported_instruction)) @@ -939,12 +997,45 @@ and compile_value_decoder: type a b. Env.t -> (a, b) ty -> int -> int -> stateme ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) ] in + let decode_list f = + let counter = Env.alloc_local env in + let value = Env.alloc_local env in + let tmp = Env.alloc_local env in + let block = + Cblock + [ Cassign (var, Cconst_i32 0l) + ; Cassign (counter, Cop (Cload (0, I32), [ Cvar ptr ])) + ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) + ; Cwhile (Cvar counter, + Cblock + [ f value ptr + (* TODO: I'm not sure if I need this tmp local *) + ; Data.cons tmp (Cvar value) (Cvar var) + ; Cassign (var, Cvar tmp) + ; Cassign (counter, Data.dec (Cvar counter)) ]) ] + in + Env.free_local env counter; + Env.free_local env value; + Env.free_local env tmp; + block + in + match typ with | Bool_t -> decode_i32 () | Nat_t -> decode_i32 () | Int_t -> decode_i32 () | Unit_t -> decode_i32 () + (* Let's assume contract and address are ints for now, + they should eventually be used as strings but converted + to integers using a contact list. *) + | Address_t -> + Cblock + [ Cassign (var, Cop (Capply "lookup_address", [ Cvar ptr ])) + ; Cassign (ptr, Data.add (Cvar ptr) (Data.add (Cconst_i32 4l) (Data.car (Cvar ptr)))) ] + + | Contract_t (_, _) -> decode_i32 () + | Union_t (left, right, _, _) -> let wrapped_value = Env.alloc_local env in let block = @@ -961,50 +1052,329 @@ and compile_value_decoder: type a b. Env.t -> (a, b) ty -> int -> int -> stateme block | List_t (typ, _) -> - let counter = Env.alloc_local env in + decode_list (fun value ptr -> compile_value_decoder env typ value ptr) + + | Map_t (key_type, value_type, _) -> + decode_list + (fun value ptr -> + let tmp = Env.alloc_local env in + let opt = Env.alloc_local env in + let block = + Cblock + [ Cassign (tmp, Data.alloc 2) + ; compile_value_decoder env key_type value ptr + ; Cstore (0, Cvar tmp, Cvar value) + ; compile_value_decoder env value_type value ptr + ; Cassign (opt, Data.alloc 2) + ; Cstore (0, Cvar opt, Cconst_i32 1l) + ; Cstore (1, Cvar opt, Cvar value) + ; Cstore (1, Cvar tmp, Cvar opt) + ; Cassign (value, Cvar tmp) ] + in + Env.free_local env tmp; + Env.free_local env opt; + block) + + | Option_t (typ, _, _) -> let value = Env.alloc_local env in - let tmp = Env.alloc_local env in let block = Cblock - [ Cassign (var, Cconst_i32 0l) - ; Cassign (counter, Cop (Cload (0, I32), [ Cvar ptr ])) + [ Cassign (value, Cop (Cload (0, I32), [ Cvar ptr ])) ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) - ; Cwhile (Cvar counter, + ; Cifthenelse (Cvar value, Cblock - [ compile_value_decoder env typ value ptr - (* TODO: I'm not sure if I need this tmp local *) - ; Data.cons tmp (Cvar value) (Cvar var) - ; Cassign (var, Cvar tmp) - ; Cassign (counter, Data.dec (Cvar counter)) ]) ] + [ Cassign (var, Data.alloc 2) + ; Cstore (0, Cvar var, Cvar value) + ; compile_value_decoder env typ value ptr + ; Cstore (1, Cvar var, Cvar value) ], + Cassign (var, Cvar value)) ] in - Env.free_local env counter; Env.free_local env value; - Env.free_local env tmp; block - | Option_t (typ, _, _) -> + | Pair_t (a, b, _, _) -> let value = Env.alloc_local env in + let block = + Cblock + [ Cassign (var, Data.alloc 2) + ; compile_value_decoder env a value ptr + ; Cstore (0, Cvar var, Cvar value) + ; compile_value_decoder env b value ptr + ; Cstore (1, Cvar var, Cvar value) ] + in + Env.free_local env value; + block + + | String_t -> Cblock - [ Cassign (value, Cop (Cload (0, I32), [ Cvar ptr ])) - ; Cassign (ptr, Cop (Cwasm (Wasm_add, I32), [ Cvar ptr; Cconst_i32 4l ])) - ; Cifthenelse (Cvar value, - Cblock - [ Cassign (var, Data.alloc 2) - ; Cstore (0, Cvar var, Cvar value) - ; compile_value_decoder env typ value ptr - ; Cstore (1, Cvar var, Cvar value) ], - Cassign (var, Cvar value)) ] + [ Cassign (var, Cvar ptr) + ; Cassign (ptr, Data.add (Cvar ptr) (Data.add (Cconst_i32 4l) (Data.car (Cvar ptr)))) ] | _typ -> raise (Compilation_error (Unsupported_parameter_type)) -and compile_value_encoder: type a b. Env.t -> (a, b) ty -> int -> int -> int -> statement = fun _ typ ptr size value -> +let rec value_size: type a b. Env.t -> (a, b) ty -> expression -> int -> statement = fun env typ value size -> + let i32 size = Cassign (size, Cconst_i32 4l) in + let byte_seq size = Cassign (size, Data.add (Cconst_i32 4l) (Data.car value)) in match typ with - | Int_t -> + | Int_t -> i32 size + | Nat_t -> i32 size + | Unit_t -> i32 size + | Mutez_t -> i32 size + | Timestamp_t -> i32 size + | Bool_t -> i32 size + | Operation_t -> i32 size + | Signature_t -> byte_seq size + | String_t -> byte_seq size + | Bytes_t -> byte_seq size + | Key_hash_t -> byte_seq size + | Key_t -> byte_seq size + | Address_t -> + let t = Env.alloc_local env in + Cblock + [ Cassign (t, Cop (Capply "reverse_lookup_address", [ value ])) + ; value_size env String_t (Cvar t) size ] + + | Tx_rollup_l2_address_t -> byte_seq size + | Chain_id_t -> byte_seq size + | Bls12_381_fr_t -> byte_seq size + | Bls12_381_g1_t -> byte_seq size + | Bls12_381_g2_t -> byte_seq size + | Chest_key_t -> byte_seq size + | Chest_t -> byte_seq size (* ?? *) + + | Pair_t (a, b, _, _) -> + let tmp = Env.alloc_local env in + Cblock + [ value_size env a (Data.car value) size + ; value_size env b (Data.cdr value) tmp + ; Cassign (size, Data.add (Cvar size) (Cvar tmp)) ] + + | Union_t (left, right, _, _) -> + Cblock + [ Cifthenelse + (Data.car value + , value_size env left (Data.cdr value) size + , value_size env right (Data.cdr value) size) + ; Cassign (size, Data.add (Cvar size) (Cconst_i32 4l)) ] + + | Option_t (typ, _, _) -> + Cifthenelse + (value + , Cblock + [ value_size env typ (Data.cdr value) size + ; Cassign (size, Data.add (Cvar size) (Cconst_i32 4l)) ] + , i32 size) + + | List_t (typ, _) -> + let node = Env.alloc_local env in + let tmp = Env.alloc_local env in + Cblock + [ Cassign (size, Cconst_i32 4l) + ; Cassign (node, value) + ; Cwhile + (Cvar node + , Cblock + [ value_size env typ (Cvar node) tmp + ; Cassign (size, Data.add (Cvar size) (Cvar tmp)) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] + + | Set_t (typ, _) -> + let node = Env.alloc_local env in + let tmp = Env.alloc_local env in Cblock - [ Cassign (ptr, Cop (Calloc 1, [])) - ; Cstore (0, Cvar ptr, Cvar value) - ; Cassign (size, Cconst_i32 4l) ] + [ Cassign (size, Cconst_i32 0l) + ; Cassign (node, value) + ; Cwhile + (Cvar node + , Cblock + [ value_size env typ (Cvar node) tmp + ; Cassign (size, Data.add (Cvar size) (Cvar tmp)) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] + | Map_t (key_type, value_type, _) -> + let node = Env.alloc_local env in + let tmp = Env.alloc_local env in + Cblock + [ Cassign (size, Cconst_i32 4l) + ; Cassign (node, value) + ; Cwhile + (Cvar node + , Cblock + [ Cifthenelse + (Data.cdr (Data.car (Cvar node)) + , Cblock + [ value_size env key_type (Data.car (Data.car (Cvar node))) tmp + ; Cassign (size, Data.add (Cvar size) (Cvar tmp)) + ; value_size env value_type (Data.cdr (Data.cdr (Data.car (Cvar node)))) tmp + ; Cassign (size, Data.add (Cvar size) (Cvar tmp)) ] + , Cblock []) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] + + | Ticket_t _ -> i32 size + + | Sapling_transaction_t _ -> failwith "Cannot be serialized" + | Sapling_transaction_deprecated_t _ -> failwith "Cannot be serialized" + | Sapling_state_t _ -> failwith "Cannot be serialized" + | Contract_t _ -> failwith "Cannot be serialized" + | Big_map_t _ -> failwith "Cannot be serialized" + | Lambda_t _ -> failwith "Lambdas cannot be serialized" + | Never_t -> failwith "Cannot serialize never" + +and compile_value_encoder: type a b. bool -> Env.t -> (a, b) ty -> int -> int -> int -> statement = fun alloc env typ ptr size value -> + let encode_i32 () = + Cblock + [ if alloc then Cassign (ptr, Cop (Calloc 1, [])) else Cblock [] + ; Cstore (0, Cvar ptr, Cvar value) + ; Cassign (size, Cconst_i32 4l) ] + in + + let encode_bytestream typ value = + let size_statement = value_size env typ (Cvar value) size in + let counter = Env.alloc_local env in + let block = + Cblock + [ size_statement + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cassign (counter, Cconst_i32 0l) + ; Cwhile + (Cop (Cwasm (Wasm_lt, I32), [ Cvar counter; Cvar size ]) + , Cblock + [ Cstore (0, Data.add (Cvar ptr) (Cvar counter), Data.car (Data.add (Cvar value) (Cvar counter))) + ; Cassign (counter, Data.inc (Cvar counter)) ]) ] + in + Env.free_local env counter; + block + in + + match typ with + | Int_t -> encode_i32 () + | Nat_t -> encode_i32 () + | Unit_t -> encode_i32 () + | Mutez_t -> encode_i32 () + | Timestamp_t -> encode_i32 () + | Bool_t -> encode_i32 () + | Operation_t -> encode_i32 () + + | Signature_t -> encode_bytestream typ value + | String_t -> encode_bytestream typ value + | Bytes_t -> encode_bytestream typ value + | Key_hash_t -> encode_bytestream typ value + | Key_t -> encode_bytestream typ value + | Address_t -> + let value' = Env.alloc_local env in + Cblock + [ Cassign (value', Cop (Capply "reverse_lookup_address", [ Cvar value ])) + ; encode_bytestream String_t value' ] + + | Tx_rollup_l2_address_t -> encode_bytestream typ value + | Chain_id_t -> encode_bytestream typ value + | Bls12_381_fr_t -> encode_bytestream typ value + | Bls12_381_g1_t -> encode_bytestream typ value + | Bls12_381_g2_t -> encode_bytestream typ value + | Chest_key_t -> encode_bytestream typ value + | Chest_t -> encode_bytestream typ value + + | Pair_t (a, b, _, _) -> + let value' = Env.alloc_local env in + let size' = Env.alloc_local env in + let ptr' = Env.alloc_local env in + let block = + Cblock + [ value_size env typ (Cvar value) size + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cassign (value', Data.car (Cvar value)) + ; compile_value_encoder false env a ptr size' value' + ; Cassign (value', Data.cdr (Cvar value)) + ; Cassign (ptr', Data.add (Cvar ptr) (Cvar size')) + ; compile_value_encoder false env b ptr' size' value' ] + in + Env.free_local env value'; + Env.free_local env size'; + Env.free_local env ptr'; + block + + | Union_t (left, right, _, _) -> + let ptr' = Env.alloc_local env in + let size' = Env.alloc_local env in + let value' = Env.alloc_local env in + Cblock + [ value_size env typ (Cvar value) size + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cassign (ptr', Data.add (Cvar ptr) (Cconst_i32 4l)) + ; Cassign (value', Data.cdr (Cvar value)) + ; Cifthenelse + (Data.car (Cvar value) + , Cblock + [ Cstore (0, Cvar ptr, Cconst_i32 1l) + ; compile_value_encoder false env left ptr' size' value' ] + , Cblock + [ Cstore (0, Cvar ptr, Cconst_i32 0l) ]) + ; compile_value_encoder false env right ptr' size' value' ] + + | List_t (item_typ, _) -> + let node = Env.alloc_local env in + let ptr' = Env.alloc_local env in + let size' = Env.alloc_local env in + let value' = Env.alloc_local env in + Cblock + [ value_size env typ (Cvar value) size + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cassign (node, Cvar value) + ; Cassign (ptr', Data.add (Cvar ptr) (Cconst_i32 4l)) + ; Cstore (0, Cvar ptr, Cconst_i32 0l) + ; Cwhile + (Cvar node + , Cblock + [ Cassign (value', Data.car (Cvar node)) + ; compile_value_encoder false env item_typ ptr' size' value' + ; Cassign (ptr', Data.add (Cvar ptr') (Cvar size')) + ; Cstore (0, Cvar ptr, Data.inc (Data.car (Cvar ptr))) + ; Cassign (node, Data.cdr (Cvar node)) ])] + + | Option_t (typ', _, _) -> + let ptr' = Env.alloc_local env in + let size' = Env.alloc_local env in + let value' = Env.alloc_local env in + Cblock + [ value_size env typ (Cvar value) size + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cifthenelse + (Cvar value + , Cblock + [ Cstore (0, Cvar ptr, Cconst_i32 1l) + ; Cassign (ptr', Data.add (Cvar ptr) (Cconst_i32 4l)) + ; Cassign (value', Data.cdr (Cvar value)) + ; compile_value_encoder false env typ' ptr' size' value' ] + , Cstore (0, Cvar ptr, Cconst_i32 0l)) ] + + (* TODO *) + | Map_t (key_type, value_type, _) -> + let node = Env.alloc_local env in + let ptr' = Env.alloc_local env in + let size' = Env.alloc_local env in + let value' = Env.alloc_local env in + Cblock + [ value_size env typ (Cvar value) size + ; if alloc then Cassign (ptr, Cop (Calloc 0, [ Cvar size ])) else Cblock [] + ; Cstore (0, Cvar ptr, Cconst_i32 0l) + ; Cassign (node, Cvar value) + ; Cassign (ptr', Data.add (Cvar ptr) (Cconst_i32 4l)) + ; Cwhile + (Cvar node + , Cblock + [ Cifthenelse + (Data.cdr (Data.car (Cvar node)) + , Cblock + [ Cassign (value', Data.car (Data.car (Cvar node))) + ; compile_value_encoder false env key_type ptr' size' value' + ; Cassign (ptr', Data.add (Cvar ptr') (Cvar size')) + ; Cassign (value', Data.cdr (Data.cdr (Data.car (Cvar node)))) + ; compile_value_encoder false env value_type ptr' size' value' + ; Cassign (ptr', Data.add (Cvar ptr') (Cvar size')) + ; Cstore (0, Cvar ptr, Data.inc (Data.car (Cvar ptr))) ] + , Cblock []) + ; Cassign (node, Data.cdr (Cvar node)) ] ) ] + | _typ -> raise (Compilation_error Unsupported_storage_type) let compile_contract contract = @@ -1037,7 +1407,7 @@ let compile_contract contract = let value = Env.alloc_local env in let block = [ Cassign (value, Data.cdr (Data.car (Cglobal "stack"))) - ; compile_value_encoder env storage_type ptr size value + ; compile_value_encoder true env storage_type ptr size value ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] in Env.free_local env ptr; @@ -1047,8 +1417,8 @@ let compile_contract contract = in let main = - { body = Cblock (param_block :: compile_instruction env code :: store_block) - ; locals = Env.max env + 1 } + let body = Cblock (param_block :: compile_instruction env code :: store_block) in + { body ; locals = env.max + 1 } in let lambdas = !lambdas diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index 4b2fe8db61..a02d783075 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -161,15 +161,27 @@ let compile_exec_function wasm_mod lambdas = (Expression.Const.make wasm_mod (Literal.int32 (Int32.of_int idx)))) (Expression.Call.make wasm_mod (Printf.sprintf "lambda_%d" idx) [] Type.none) (aux lambdas) - | [] -> Expression.Nop.make wasm_mod + | [] -> Expression.Unreachable.make wasm_mod in let body = aux lambdas in ignore @@ Function.add_function wasm_mod "exec" Type.(create [| int32 |]) - Type.none + Type.int32 [||] - body + (Expression.Block.make wasm_mod "exec_func_body" [ body; Expression.Const.make wasm_mod (Literal.int32 0l) ]) + +let compile_malloc wasm_mod = + let body = + Expression.Block.make wasm_mod "malloc_func_body" + [ Expression.Global_set.make wasm_mod "stack" + (Expression.Binary.make wasm_mod Op.add_int32 + (Expression.Local_tee.make wasm_mod 1 (Expression.Global_get.make wasm_mod "heap_top" Type.int32) Type.int32) + (Expression.Local_get.make wasm_mod 0 Type.int32)) + ; Expression.Local_get.make wasm_mod 1 Type.int32 ] + in + ignore @@ + Function.add_function wasm_mod "malloc" Type.int32 Type.int32 [| Type.int32 |] body let compile_ir ~memory ~optimize ~debug ~shared_memory contract = let wasm_mod = Module.create () in @@ -186,6 +198,9 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = compile_exec_function wasm_mod lambdas; end; + compile_malloc wasm_mod; + ignore @@ Export.add_function_export wasm_mod "malloc" "malloc"; + ignore @@ Global.add_global wasm_mod "stack" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 0l)); @@ -207,8 +222,18 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = Import.add_function_import wasm_mod "save_storage" "env" "save_storage" Type.(create [| int32; int32 |]) Type.int32; Import.add_function_import wasm_mod "failwith" "env" "failwith" Type.int32 Type.none; + Import.add_function_import wasm_mod "sender" "env" "sender" Type.none Type.int32; + Import.add_function_import wasm_mod "amount" "env" "amount" Type.none Type.int32; + Import.add_function_import wasm_mod "transfer_tokens" "env" "transfer_tokens" Type.(create [| int32; int32; int32|]) Type.int32; + + Import.add_function_import wasm_mod "lookup_address" "env" "lookup_address" Type.int32 Type.int32; + Import.add_function_import wasm_mod "reverse_lookup_address" "env" "reverse_lookup_address" Type.int32 Type.int32; + let (initial, max) = memory in - let segments = [ Memory.{ data = static_data; kind = Passive; size = Bytes.length static_data } ] in + let segments = + [ Memory.{ data = static_data + ; kind = Active { offset = Expression.Const.make wasm_mod (Literal.int32 0l) } + ; size = Bytes.length static_data } ] in Memory.set_memory wasm_mod initial max "memory" segments shared_memory; (* if Module.validate wasm_mod <> 0 then diff --git a/deku-c/tunac/tests/dune b/deku-c/tunac/tests/dune index 4a2dddba1c..bf9dff3c5d 100644 --- a/deku-c/tunac/tests/dune +++ b/deku-c/tunac/tests/dune @@ -5,4 +5,4 @@ (rule (alias runtest) (action (run node tests.js)) - (deps tests.js compile.exe)) \ No newline at end of file + (deps fa12.tz tests.js compile.exe)) \ No newline at end of file diff --git a/deku-c/tunac/tests/fa12.tz b/deku-c/tunac/tests/fa12.tz new file mode 100644 index 0000000000..b3ab5191a5 --- /dev/null +++ b/deku-c/tunac/tests/fa12.tz @@ -0,0 +1,235 @@ +{ parameter + (or (or (or (pair %approve (address %spender) (nat %value)) + (pair %getAllowance (pair (address %owner) (address %spender)) (contract nat))) + (or (pair %getBalance (address %owner) (contract nat)) + (pair %getTotalSupply unit (contract nat)))) + (pair %transfer (address %from) (address %to) (nat %value))) ; + storage + (pair (map %ledger address (pair (map %allowances address nat) (nat %balance))) + (nat %totalSupply)) ; + code { NIL operation ; + LAMBDA + (pair address (map address (pair (map address nat) nat)) nat) + (pair (map address nat) nat) + { UNPAIR ; + SWAP ; + CAR ; + SWAP ; + GET ; + IF_NONE + { UNIT ; PUSH nat 0 ; EMPTY_MAP address nat ; PAIR } + { UNIT ; SWAP } ; + SWAP ; + DROP } ; + LAMBDA + (pair (pair (pair (map address nat) nat) address) + (map address (pair (map address nat) nat)) + nat) + nat + { CAR ; UNPAIR ; CAR ; SWAP ; GET ; IF_NONE { PUSH nat 0 } {} } ; + DIG 3 ; + UNPAIR ; + IF_LEFT + { IF_LEFT + { IF_LEFT + { UNPAIR ; + DUP 3 ; + SENDER ; + PAIR ; + DIG 5 ; + SWAP ; + EXEC ; + DUP 4 ; + DUP 3 ; + DUP 3 ; + PAIR ; + PAIR ; + DIG 5 ; + SWAP ; + EXEC ; + PUSH nat 0 ; + DUP 5 ; + COMPARE ; + GT ; + PUSH nat 0 ; + DIG 2 ; + COMPARE ; + GT ; + AND ; + IF { PUSH string "UnsafeAllowanceChange" ; FAILWITH } {} ; + DUP 4 ; + CDR ; + DIG 4 ; + CAR ; + DUP 3 ; + CDR ; + DIG 3 ; + CAR ; + DIG 5 ; + DIG 5 ; + SWAP ; + SOME ; + SWAP ; + UPDATE ; + PAIR ; + SENDER ; + SWAP ; + SOME ; + SWAP ; + UPDATE ; + PAIR ; + SWAP } + { DIG 4 ; + DROP ; + DUP 2 ; + DUP 2 ; + CAR ; + CAR ; + PAIR ; + DIG 4 ; + SWAP ; + EXEC ; + DUP 3 ; + DUP 3 ; + CAR ; + CDR ; + DIG 2 ; + PAIR ; + PAIR ; + DIG 3 ; + SWAP ; + EXEC ; + DIG 2 ; + NIL operation ; + DIG 3 ; + CDR ; + PUSH mutez 0 ; + DIG 4 ; + TRANSFER_TOKENS ; + CONS } } + { DIG 2 ; + DIG 4 ; + DROP 2 ; + IF_LEFT + { UNPAIR ; + DUP 3 ; + SWAP ; + PAIR ; + DIG 3 ; + SWAP ; + EXEC ; + DIG 2 ; + NIL operation ; + DIG 3 ; + PUSH mutez 0 ; + DIG 4 ; + CDR ; + TRANSFER_TOKENS } + { DIG 2 ; + DROP ; + DUP 2 ; + NIL operation ; + DIG 2 ; + CDR ; + PUSH mutez 0 ; + DIG 4 ; + CDR ; + TRANSFER_TOKENS } ; + CONS } } + { DUP ; + CDR ; + CAR ; + DUP 2 ; + CAR ; + DIG 2 ; + CDR ; + CDR ; + DUP 4 ; + DUP 3 ; + PAIR ; + DUP 7 ; + SWAP ; + EXEC ; + DUP 2 ; + DUP 2 ; + CDR ; + COMPARE ; + LT ; + IF { PUSH string "NotEnoughBalance" ; FAILWITH } {} ; + SENDER ; + DUP 4 ; + COMPARE ; + NEQ ; + IF { DUP 5 ; + SENDER ; + DUP 3 ; + PAIR ; + PAIR ; + DIG 6 ; + SWAP ; + EXEC ; + DUP 3 ; + DUP 2 ; + COMPARE ; + LT ; + IF { PUSH string "NotEnoughAllowance" ; FAILWITH } {} ; + DUP 2 ; + CDR ; + DIG 2 ; + CAR ; + DUP 4 ; + DIG 3 ; + SUB ; + ABS ; + SENDER ; + SWAP ; + SOME ; + SWAP ; + UPDATE ; + PAIR } + { DIG 5 ; DROP } ; + DUP 2 ; + DUP 2 ; + CDR ; + SUB ; + ABS ; + SWAP ; + CAR ; + PAIR ; + DUP 5 ; + CDR ; + DIG 5 ; + CAR ; + DIG 2 ; + DIG 4 ; + SWAP ; + SOME ; + SWAP ; + UPDATE ; + PAIR ; + DUP ; + DUP 4 ; + PAIR ; + DIG 4 ; + SWAP ; + EXEC ; + DIG 2 ; + DUP 2 ; + CDR ; + ADD ; + SWAP ; + CAR ; + PAIR ; + DUP 2 ; + CDR ; + DIG 2 ; + CAR ; + DIG 2 ; + DIG 3 ; + SWAP ; + SOME ; + SWAP ; + UPDATE ; + PAIR ; + SWAP } ; + PAIR } } diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index e5c7e39a58..1c35cd3846 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -34,6 +34,10 @@ function michelsonValueToString(value) { return value.int.toString() } + if (value.string !== undefined) { + return '"' + value.string + '"' + } + if (value.prim) { return '(' + value.prim + ' ' + value.annots.join(' ') + ' ' + @@ -49,10 +53,11 @@ function encodeValue(value) { return new Promise((resolve, reject) => { const process = child_process.exec('./compile.exe value', (err, stdout) => { if (err) return reject(err) - resolve(Buffer.from(stdout)) + resolve(Buffer.from(stdout, 'binary')) }) process.stdin.end(michelsonValueToString(value)) + process.stderr.pipe(global.process.stderr) }) } @@ -101,17 +106,28 @@ async function wasmModuleOfMichelson(code) { return WebAssembly.compile(wasm) } -async function eval(code, parameter, storage) { +async function eval(code, parameter, storage, context = {}) { const module = await wasmModuleOfMichelson(code) + console.log((await encodeValue(storage)).toString('hex')) + const parameterBuffer = await encodeValue({ prim: 'Pair', args: [ parameter, storage ], annots: [] }) + // console.log(parameterBuffer.toString('hex')) let storageBuffer let failure = null + let addressCounter = 0 + const contactBook = {} + const addrLookup = {} + + if (context.sender !== undefined) { + contactBook[addressCounter] = context.sender + contactBook[context.sender] = addressCounter++ + } const imports = { env: { @@ -137,6 +153,58 @@ async function eval(code, parameter, storage) { }, failwith(arg) { failure = arg + }, + sender() { + return 0 + }, + amount() { + return 33 + }, + transfer_tokens(arg, amount, contract) { + return 0 + }, + lookup_address(addr) { + const size = bytes[addr] | bytes[addr + 1] << 8 | bytes[addr + 2] << 16 | bytes[addr + 3] << 24 + const buffer = Buffer.alloc(size) + + for (let i = 0; i < size; i++) { + buffer[i] = bytes[addr + i + 4] + } + + const address = buffer.toString() + + if (contactBook[address] !== undefined) { + return contactBook[address] + } + + contactBook[address] = addressCounter + contactBook[addressCounter] = address + + addrLookup[addressCounter] = addr + + // console.log(address, addressCounter, addr) + + return addressCounter++ + }, + reverse_lookup_address(descriptor) { + if (addrLookup[descriptor] === undefined) { + const address = Buffer.from(contactBook[descriptor]) + const ptr = instance.exports.malloc(address.length + 4) + + bytes[ptr] = address.length & 0xff + bytes[ptr + 1] = (address.length >> 8) & 0xff + bytes[ptr + 2] = (address.length >> 16) & 0xff + bytes[ptr + 3] = (address.length >> 24) & 0xff + + + for (let i = 0; i < address.length; i++) { + bytes[ptr + 4 + i] = address[i] + } + + addrLookup[descriptor] = ptr + } + + return addrLookup[descriptor] } } } @@ -153,7 +221,16 @@ async function eval(code, parameter, storage) { stack: instance.exports.stack } - instance.exports.main() + try { + instance.exports.main() + } catch (e) { + if (failure === null) { + throw e + } else { + let message = Buffer.from(bytes.slice(failure + 4, failure + 4 + words[failure / 4])).toString() + console.log('Failure: ', message) + } + } return { storage: storageBuffer, exports, failure } } @@ -194,14 +271,29 @@ async function main() { `, { prim: 'Right', args: [ { prim: 'Unit', args: [], annots: [] } ], annots: [] }, { int: 42 }) assertStorage(res, '00000000') - // res = await eval(` - // { parameter unit; - // storage int; - // code { PUSH int 1; PUSH int 2; PUSH int 3; PUSH int 4; PUSH int 5; DIG 2 } } - // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) - // // inspect_all(res.exports) - // assert(stack_n(res.exports, 0) === 3) - // assert(stack_n(res.exports, 2) === 4) + res = await eval(` + { parameter unit; + storage unit; + code { PUSH int 4; PUSH int 3; PUSH int 4; DIG 2; COMPARE; NEQ; IF { PUSH string "Not equal"; FAILWITH } { }; + DROP 2; UNIT; NIL operation; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert.equal(res.failure, null) + + res = await eval(` + { parameter unit; + storage unit; + code { PUSH int 4; DUP; COMPARE; NEQ; IF { PUSH string "Not equal"; FAILWITH } { }; + DROP; UNIT; NIL operation; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert.equal(res.failure, null) + + res = await eval(` + { parameter unit; + storage unit; + code { PUSH int 4; PUSH int 3; PUSH int 4; DUP 3; COMPARE; NEQ; IF { PUSH string "Not equal"; FAILWITH } { }; + DROP 3; UNIT; NIL operation; PAIR } } + `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + assert.equal(res.failure, null) // res = await eval(` // { parameter unit; @@ -429,6 +521,176 @@ async function main() { PAIR } } `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) assertStorage(res, '32000000') + + // res = await eval(` + // { parameter unit; + // storage (or int string); + // code { + // DROP; + // PUSH string "Hello world"; + // RIGHT int; + // NIL operation; + // PAIR } } + // `, { prim: 'Unit', args: [], annots: [] }, { int: 0 }) + // assertStorage(res, '') + + res = await eval(` + { parameter (map int string); + storage (map int string); + code { + CAR; + PUSH string "Hello world" ; + SOME; + PUSH int 1; + UPDATE; + NIL operation; + PAIR } } + `, [ { prim: 'Elt', args: [ { int: 3 }, { string: 'Fuba' } ], annots: [] } ], [ { prim: 'Elt', args: [ { int: 3 }, { string: 'Fuba' } ], annots: [] } ]) + // assertStorage(res, '') + + res = await eval( + ` + { parameter address; + storage (map address (pair (map address nat) nat)); + code { + DROP; + EMPTY_MAP address (pair (map address nat) nat); + NIL operation; + PAIR } } + `, + { string: 'tz1LaN1QJGrmPcuAfLvncTLJ3iRzphHpjugu' }, + [ + { + prim: 'Elt', + args: [ + { string: 'tz1LaN1QJGrmPcuAfLvncTLJ3iRzphHpjugu' }, + { + prim: 'Pair', + args: [ + [], + { int: 1000000000 } + ], + annots: [] + } + ], + annots: [] + } + ] + ) + assertStorage(res, '00000000') +} + +main() + +function left(value) { + return { prim: 'Left', args: [ value ], annots: [] } +} + +function right(value) { + return { prim: 'Right', args: [ value ], annots: [] } +} + +function pair(...args) { + return { prim: 'Pair', args, annots: [] } +} + +function string(string) { + return { string } +} + +function int(int) { + return { int } +} + +function elt(key, value) { + return { prim: 'Elt', args: [ key, value ], annots: [] } +} + +const unit = { prim: 'Unit', args: [], annots: [] } + +async function test_fa12() { + const contract = fs.readFileSync('fa12.tz') + function run(parameter, storage) { + // console.log(JSON.stringify(storage, undefined, 2)) + return eval( + contract, + parameter, + storage, + { + sender: 'tz1aSNVC5oNxYtQcEdUQuGx9DW7gkBzM3Ct3' + } + ) + } + + // Interface: + // + // parameter + // (or (or (or (pair %approve (address %spender) (nat %value)) + // (pair %getAllowance (pair (address %owner) (address %spender)) (contract nat))) + // (or (pair %getBalance (address %owner) (contract nat)) + // (pair %getTotalSupply unit (contract nat)))) + // (pair %transfer (address %from) (address %to) (nat %value))) ; + // storage + // (pair (map %ledger address (pair (map %allowances address nat) (nat %balance))) + // (nat %totalSupply)) ; + + function approve(address, value) { + return left(left(left(pair(string(address), int(value))))) + } + + function getAllowance(owner, spender, callback) { + return left(left(right(pair(pair(string(owner), string(spender)), string(callback))))) + } + + function getBalance(owner, callback) { + return left(right(left(pair(string(owner), string(callback))))) + } + + function getTotalSupply(callback) { + return left(right(right(pair(unit, string(callback))))) + } + + function transfer(from, to, value) { + return right(pair(string(from), string(to), int(value))) + } + + function storage({ ledger, totalSupply }) { + const ledger_ = [] + + for (let owner in ledger) { + let allowances = [] + + for (let addr in ledger[owner].allowances) { + allowances.push(elt(string(addr), ledger[owner].allowances[addr])) + } + + ledger_.push(elt( + string(owner), + pair( + allowances, + int(ledger[owner].balance) + ) + )) + } + + return pair(ledger_, int(totalSupply)) + } + + const res = await run( + transfer('tz1aSNVC5oNxYtQcEdUQuGx9DW7gkBzM3Ct3', 'tz1edHdUromXCjoZ2kU9uVSEjwu7EC9ypHgn', 1000), + storage({ + ledger: { + 'tz1aSNVC5oNxYtQcEdUQuGx9DW7gkBzM3Ct3': { + allowances: { + 'tz1edHdUromXCjoZ2kU9uVSEjwu7EC9ypHgn': 0 + }, + balance: 1_000_000_000 + } + }, + totalSupply: 1_000_000_000 + }) + ) + // assertStorage(res, '') } -main() \ No newline at end of file +test_fa12() \ No newline at end of file From 44964e1ffeb72ccc0d0038d80fd59c3495acb579 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 13 Dec 2022 21:22:24 -0300 Subject: [PATCH 15/21] wip: use llvm and external runtime functions --- compile.sh | 7 ++ deku-c/tunac/lib/iR_of_michelson.ml | 69 +++++---------- deku-c/tunac/lib/llvm_of_ir.ml | 131 ++++++++++++++++++++++++++++ deku-c/tunac/lib/tunac.ml | 20 +++++ deku-c/tunac/lib/wasm_of_ir.ml | 38 +++++--- nix/deku-c/tuna.nix | 7 ++ nix/deku-p/deku.nix | 4 + nix/overlay.nix | 29 ++++++ run.js | 93 ++++++++++++++++++++ runtime.c | 22 +++++ trivial.tz | 3 + 11 files changed, 365 insertions(+), 58 deletions(-) create mode 100644 compile.sh create mode 100644 deku-c/tunac/lib/llvm_of_ir.ml create mode 100644 run.js create mode 100644 runtime.c create mode 100644 trivial.tz diff --git a/compile.sh b/compile.sh new file mode 100644 index 0000000000..eccd4219c9 --- /dev/null +++ b/compile.sh @@ -0,0 +1,7 @@ + +dune exec ./deku-c/tunac/tests/compile.exe -- contract --output mod.wasm < trivial.tz > trivial.ll +llc -o trivial.wasm --march=wasm32 --filetype=obj -opaque-pointers trivial.ll + +clang -c -o runtime.wasm --target=wasm32-unknown-unknown runtime.c + +wasm-ld -o contract.wasm --export=__michelson_stack --import-undefined runtime.wasm trivial.wasm diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index df3a1e9099..b2677cabba 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -52,15 +52,15 @@ module Env = struct end let compile_pop var = Cblock - [ Cassign (var, Data.car (Cglobal "stack")) - ; Cglobal_assign ("stack", Data.cdr (Cglobal "stack")) ] + [ Cassign (var, Data.car (Cglobal "__michelson_stack")) + ; Cglobal_assign ("__michelson_stack", Data.cdr (Cglobal "__michelson_stack")) ] let compile_push ~env expr = let cell = Env.alloc_local env in let block = Cblock - [ Data.cons cell expr (Cglobal "stack") - ; Cglobal_assign ("stack", Cvar cell) ] + [ Data.cons cell expr (Cglobal "__michelson_stack") + ; Cglobal_assign ("__michelson_stack", Cvar cell) ] in Env.free_local env cell; block @@ -81,32 +81,8 @@ let compile_pair ~env = Env.free_local env item; block -let compile_dig ~env n = - let n = Int32.sub n 1l in - let counter = Env.alloc_local env in - let node = Env.alloc_local env in - let loop = - Cblock - [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "stack") - ; Cwhile (Cvar counter, - Cblock - [ Cassign (counter, Data.dec (Cvar counter)) - ; Cassign (node, Data.cdr (Cvar node)) ]) ] - in - Env.free_local env counter; - let a = Env.alloc_local env in - let block = - Cblock - [ loop - ; Cassign (a, Data.cdr (Cvar node)) - ; Cstore (1, Cvar node, Data.cdr (Cvar a)) - ; Cstore (1, Cvar a, Cglobal "stack") - ; Cglobal_assign ("stack", Cvar a) ] - in - Env.free_local env a; - Env.free_local env node; - block +let compile_dig ~env:_ n = + Cassign (0, Cop (Capply "michelson_dig", [ Cconst_i32 n ])) let compile_dug ~env n = let n = Int32.sub n 1l in @@ -115,7 +91,7 @@ let compile_dug ~env n = let inner_loop = Cblock [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Data.cdr (Cglobal "stack")) + ; Cassign (node, Data.cdr (Cglobal "__michelson_stack")) ; Cwhile (Cvar counter, Cblock [ Cassign (counter, Data.dec (Cvar counter)) @@ -126,8 +102,8 @@ let compile_dug ~env n = let block = Cblock [ inner_loop - ; Cassign (head, Cglobal "stack") - ; Cglobal_assign ("stack", Data.cdr (Cvar head)) + ; Cassign (head, Cglobal "__michelson_stack") + ; Cglobal_assign ("__michelson_stack", Data.cdr (Cvar head)) ; Cstore (1, Cvar head, Data.cdr (Cvar node)) ; Cstore (1, Cvar node, Cvar head) ] in @@ -141,7 +117,7 @@ let compile_drop ~env n = let inner_loop = Cblock [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "stack") + ; Cassign (node, Cglobal "__michelson_stack") ; Cwhile (Cvar counter, Cblock [ Cassign (counter, Data.dec (Cvar counter)) @@ -151,7 +127,7 @@ let compile_drop ~env n = let block = Cblock [ inner_loop - ; Cglobal_assign ("stack", Cvar node) ] + ; Cglobal_assign ("__michelson_stack", Cvar node) ] in Env.free_local env node; block @@ -163,7 +139,7 @@ let compile_dup ~env n = let inner_loop = Cblock [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "stack") + ; Cassign (node, Cglobal "__michelson_stack") ; Cwhile (Cvar counter , Cblock [ Cassign (counter, Data.dec (Cvar counter)) @@ -185,7 +161,7 @@ let compile_dip ~env n block = let inner_loop = Cblock [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "stack") + ; Cassign (node, Cglobal "__michelson_stack") ; Cwhile (Cvar counter , Cblock [ Cassign (counter, Data.dec (Cvar counter)) @@ -197,11 +173,11 @@ let compile_dip ~env n block = let save_stack_block = Cblock [ Cassign (pair, Cop (Calloc 2, [])) - ; Cstore (0, Cvar pair, Cglobal "stack") + ; Cstore (0, Cvar pair, Cglobal "__michelson_stack") ; Cstore (1, Cvar pair, Cvar node) - ; Cglobal_assign ("dip_stack", Cop (Cwasm (Wasm_add, I32), [ Cglobal "dip_stack"; Cconst_i32 4l ])) - ; Cstore (0, Cglobal "dip_stack", Cvar pair) - ; Cglobal_assign ("stack", Data.cdr (Cvar node)) ] + ; Cglobal_assign ("__michelson_dip_stack", Cop (Cwasm (Wasm_add, I32), [ Cglobal "__michelson_dip_stack"; Cconst_i32 4l ])) + ; Cstore (0, Cglobal "__michelson_dip_stack", Cvar pair) + ; Cglobal_assign ("__michelson_stack", Data.cdr (Cvar node)) ] in Env.free_local env pair; Env.free_local env node; @@ -210,10 +186,10 @@ let compile_dip ~env n block = let pair = Env.alloc_local env in let restore_stack = Cblock - [ Cassign (pair, Cop (Cload (0, I32), [ Cglobal "dip_stack" ])) - ; Cstore (1, Data.cdr (Cvar pair), Cglobal "stack") - ; Cglobal_assign ("stack", Data.car (Cvar pair)) - ; Cglobal_assign ("dip_stack", Cop (Cwasm (Wasm_sub, I32), [ Cglobal "dip_stack"; Cconst_i32 4l ] )) ] + [ Cassign (pair, Cop (Cload (0, I32), [ Cglobal "__michelson_dip_stack" ])) + ; Cstore (1, Data.cdr (Cvar pair), Cglobal "__michelson_stack") + ; Cglobal_assign ("__michelson_stack", Data.car (Cvar pair)) + ; Cglobal_assign ("__michelson_dip_stack", Cop (Cwasm (Wasm_sub, I32), [ Cglobal "__michelson_dip_stack"; Cconst_i32 4l ] )) ] in Cblock [ inner_loop; save_stack_block; block; restore_stack ] @@ -1406,7 +1382,7 @@ let compile_contract contract = let size = Env.alloc_local env in let value = Env.alloc_local env in let block = - [ Cassign (value, Data.cdr (Data.car (Cglobal "stack"))) + [ Cassign (value, Data.cdr (Data.car (Cglobal "__michelson_stack"))) ; compile_value_encoder true env storage_type ptr size value ; Cassign (value, Cop (Capply "save_storage", [ Cvar ptr; Cvar size ])) ] in @@ -1418,6 +1394,7 @@ let compile_contract contract = let main = let body = Cblock (param_block :: compile_instruction env code :: store_block) in + (* let body = compile_instruction env code in *) { body ; locals = env.max + 1 } in let lambdas = diff --git a/deku-c/tunac/lib/llvm_of_ir.ml b/deku-c/tunac/lib/llvm_of_ir.ml new file mode 100644 index 0000000000..841e21925d --- /dev/null +++ b/deku-c/tunac/lib/llvm_of_ir.ml @@ -0,0 +1,131 @@ +open IR + +let reg_count = ref 0 +let new_reg () = + incr reg_count; + Printf.sprintf "%%%d" !reg_count + +let compile_wasm_operation op args = + match op, args with + | Wasm_add, [ a; b ] -> + let a' = new_reg () in + let b' = new_reg () in + let c' = new_reg () in + let c'' = new_reg () in + Format.printf "\t%s = ptrtoint ptr %s to i32\n" a' a; + Format.printf "\t%s = ptrtoint ptr %s to i32\n" b' b; + Format.printf "\t%s = add i32 %s, %s\n" c' a' b'; + Format.printf "\t%s = inttoptr i32 %s to ptr\n" c'' c'; + c'' + + | _ -> assert false + +let rec compile_expression expr = + match expr with + | Cvar local -> + let r = new_reg () in + Format.printf "\t%s = load ptr, ptr %%local_%d\n" r local; + r + + | Cglobal name -> + let r = new_reg () in + Format.printf "\t%s = load ptr, ptr @%s\n" r name; + r + + | Cconst_i32 value -> + let reg = new_reg () in + Format.printf "\t%s = inttoptr i32 %ld to ptr\n" reg value; + reg + + | Cop (Cload (cell, _), [ ptr ]) -> + let ptr = compile_expression ptr in + let tmp = new_reg () in + let value = new_reg () in + Format.printf "\t%s = getelementptr ptr, ptr %s, i32 %d\n" tmp ptr cell; + Format.printf "\t%s = load ptr, ptr %s\n" value tmp; + value + + | Cop (Calloc 0, [ size ]) -> + let size = compile_expression size in + let size' = new_reg () in + let ptr = new_reg () in + Format.printf "\t%s = ptrtoint ptr %s to i32\n" size' size; + Format.printf "\t%s = call ptr @malloc(i32 %s)\n" ptr size'; + ptr + + | Cop (Calloc cells, []) -> + let ptr = new_reg () in + Format.printf "\t%s = call ptr @malloc(i32 %d)\n" ptr (cells * 4); + ptr + + | Cop (Capply name, args) -> + let args = + args + |> List.map (fun expr -> Printf.sprintf "ptr %s" (compile_expression expr)) + |> String.concat ", " + in + let reg = new_reg () in + Format.printf "\t%s = call ptr @%s(%s)\n" reg name args; + reg + + | Cop (Cwasm (op, _), args) -> + let args = List.map compile_expression args in + compile_wasm_operation op args + + | _ -> + Format.printf "%a\n" IR.pp_expression expr; + assert false + +let is_block = function Cblock _ -> true | _ -> false + +let rec compile_statement statement = + Format.print_newline (); + + (* if (not (is_block statement)) then + Format.printf "%a\n" pp_statement statement; *) + + match statement with + | Cassign (local, value) -> + let ptr = compile_expression value in + Format.printf "\tstore ptr %s, ptr %%local_%d\n" ptr local + + | Cglobal_assign (global, expr) -> + let value = compile_expression expr in + Format.printf "\tstore ptr %s, ptr @%s\n" value global + + | Cstore (cell, ptr, value) -> + let value = compile_expression value in + let ptr = compile_expression ptr in + let reg = new_reg () in + Format.printf "\t%s = getelementptr ptr, ptr %s, i32 %d\n" reg ptr cell; + Format.printf "\tstore ptr %s, ptr %s\n" value reg + + | Cblock statements -> List.iter compile_statement statements + + | _ -> + Format.printf "%a\n" IR.pp_statement statement; + assert false + +let compile_function name fn = + Format.printf "\ndefine void @%s() {\n" name; + + let IR_of_michelson.{ body; locals } = fn in + + for i = 0 to locals do + Format.printf "\t%%local_%d = alloca ptr\n" i; + done; + + compile_statement body; + + Format.printf "\tret void\n}" + +let compile_ir contract = + let IR_of_michelson.{ main; _ } = contract in + + Format.printf "@__michelson_stack = global ptr null\n"; + Format.printf "declare ptr @malloc(i32)\n"; + Format.printf "declare ptr @parameter_load(ptr)\n"; + Format.printf "declare ptr @parameter_size()\n"; + Format.printf "declare ptr @save_storage(ptr, ptr)\n"; + + compile_function "main" main; \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index 5f4269d77e..dc9896a925 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -53,11 +53,31 @@ let compile_contract ~config contract = ~code:code in let contract = report_error @@ IR_of_michelson.compile_contract typed_contract in + + let () = + Llvm_all_backends.initialize (); + let llvm_mod = Llvm_of_ir.compile_ir contract in + ignore llvm_mod + (* let target = Llvm_target.Target.by_triple "wasm32-unknown-unknown" in + let target_machine = + Llvm_target.TargetMachine.create + ~triple:"wasm32-unknown-unknown" + target + in + Llvm_target.TargetMachine.emit_to_file + llvm_mod + Llvm_target.CodeGenFileType.ObjectFile + "michelson_contract_from_llvm.wasm" + target_machine *) + in + + let wasm_mod = Binaryen.Module.create () in Wasm_of_ir.compile_ir ~memory:config.memory ~optimize:config.optimize ~debug:config.debug ~shared_memory:config.shared_memory + wasm_mod contract let compile_contract ~config contract = diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index a02d783075..efe1923a89 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -16,11 +16,12 @@ let rec compile_expression wasm_mod expr = and compile_operation wasm_mod op params = let compile_load cell typ ptr = (* TODO: How know if its signed or not? *) - match typ with - | I8 -> Expression.Load.make wasm_mod 1 (cell * 4) 0 Type.int32 ptr - | U8 -> Expression.Load.make wasm_mod 1 (cell * 4) 0 Type.int32 ptr - | I32 -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 ptr - | U32 -> Expression.Load.make wasm_mod 4 (cell * 4) 0 Type.int32 ptr + let bytes = + match typ with + | I8 | U8 -> 1 + | I32 | U32 -> 4 + in + Expression.Load.make wasm_mod bytes (cell * 4) 0 Type.int32 ptr in match op, params with @@ -174,7 +175,7 @@ let compile_exec_function wasm_mod lambdas = let compile_malloc wasm_mod = let body = Expression.Block.make wasm_mod "malloc_func_body" - [ Expression.Global_set.make wasm_mod "stack" + [ Expression.Global_set.make wasm_mod "heap_top" (Expression.Binary.make wasm_mod Op.add_int32 (Expression.Local_tee.make wasm_mod 1 (Expression.Global_get.make wasm_mod "heap_top" Type.int32) Type.int32) (Expression.Local_get.make wasm_mod 0 Type.int32)) @@ -183,9 +184,7 @@ let compile_malloc wasm_mod = ignore @@ Function.add_function wasm_mod "malloc" Type.int32 Type.int32 [| Type.int32 |] body -let compile_ir ~memory ~optimize ~debug ~shared_memory contract = - let wasm_mod = Module.create () in - +let compile_ir ~memory ~optimize ~debug ~shared_memory wasm_mod contract = let IR_of_michelson.{ main; lambdas; static_data } = contract in add_function wasm_mod "main" main; @@ -202,18 +201,18 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = ignore @@ Export.add_function_export wasm_mod "malloc" "malloc"; ignore @@ - Global.add_global wasm_mod "stack" Type.int32 true + Global.add_global wasm_mod "__michelson_stack" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 0l)); ignore @@ Global.add_global wasm_mod "heap_top" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 512l)); ignore @@ - Global.add_global wasm_mod "dip_stack" Type.int32 true + Global.add_global wasm_mod "__michelson_dip_stack" Type.int32 true (Expression.Const.make wasm_mod (Literal.int32 256l)); if debug then begin - ignore @@ Export.add_global_export wasm_mod "stack" "stack"; + ignore @@ Export.add_global_export wasm_mod "__michelson_stack" "__michelson_stack"; ignore @@ Export.add_global_export wasm_mod "heap_top" "heap_top"; end; @@ -229,6 +228,8 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = Import.add_function_import wasm_mod "lookup_address" "env" "lookup_address" Type.int32 Type.int32; Import.add_function_import wasm_mod "reverse_lookup_address" "env" "reverse_lookup_address" Type.int32 Type.int32; + Import.add_function_import wasm_mod "michelson_dig" "env" "michelson_dig" Type.int32 Type.int32; + let (initial, max) = memory in let segments = [ Memory.{ data = static_data @@ -242,4 +243,17 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory contract = if optimize then Module.optimize wasm_mod; + let linking = + let open Linking in + [ Symbol_table [ { kind = Symtab_function + ; flags = [ Sym_exported ] + ; index = 10l + ; name = Some "main" } + ; { kind = Symtab_function + ; flags = [ Sym_undefined ] + ; index = 9l + ; name = None } ] ] + in + Linking.add_linking_metadata wasm_mod linking; + wasm_mod \ No newline at end of file diff --git a/nix/deku-c/tuna.nix b/nix/deku-c/tuna.nix index 2a321d5b74..81e81e14ca 100644 --- a/nix/deku-c/tuna.nix +++ b/nix/deku-c/tuna.nix @@ -6,6 +6,10 @@ alcotest, binaryen, proto-alpha-utils, + emscripten, + ppx_blob, + llvm, + pkgs }: buildDunePackage rec { pname = "deku"; @@ -25,6 +29,9 @@ buildDunePackage rec { tezos-micheline binaryen proto-alpha-utils + llvm + pkgs.gdb + # llvmPackages_14.lldb ]; buildInputs = [ diff --git a/nix/deku-p/deku.nix b/nix/deku-p/deku.nix index 2f8a02777c..2455d59163 100644 --- a/nix/deku-p/deku.nix +++ b/nix/deku-p/deku.nix @@ -3,6 +3,7 @@ doCheck ? true, nodejs, npmPackages, + llvmPackages_14, static ? false, removeReferencesTo, nix-filter, @@ -95,6 +96,9 @@ in ezgzip ppx_jane # TODO: do we need this? core + llvmPackages_14.clang-unwrapped + llvmPackages_14.llvm + llvmPackages_14.lld ] # checkInputs are here because when cross compiling dune needs test dependencies # but they are not available for the build phase. The issue can be seen by adding strictDeps = true;. diff --git a/nix/overlay.nix b/nix/overlay.nix index 94c541a4a0..3da3954dd4 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -221,6 +221,35 @@ with super; { ligo-tezos-utils ]; }; + + llvm = (super.llvm.override { + libllvm = llvmPackages_14.libllvm; + }).overrideAttrs (self: { + cmakeFlags = self.cmakeFlags ++ [ "-S ../llvm" ]; + postPatch = '' + substituteInPlace "llvm/bindings/ocaml/llvm/llvm_ocaml.c" --replace \ + " alloc_custom(" \ + " caml_alloc_custom(" + substituteInPlace "llvm/bindings/ocaml/llvm/llvm_ocaml.c" --replace \ + " string_length(" \ + " caml_string_length(" + substituteInPlace "llvm/bindings/ocaml/llvm/llvm_ocaml.c" --replace \ + " callback(" \ + " caml_callback(" + substituteInPlace "llvm/bindings/ocaml/llvm/llvm_ocaml.c" --replace \ + " failwith(" \ + " caml_failwith(" + substituteInPlace "llvm/bindings/ocaml/llvm/llvm_ocaml.c" --replace \ + " remove_global_root(" \ + " caml_remove_global_root(" + substituteInPlace "llvm/bindings/ocaml/target/target_ocaml.c" --replace \ + " alloc_custom(" \ + " caml_alloc_custom(" + substituteInPlace "llvm/bindings/ocaml/target/target_ocaml.c" --replace \ + " copy_string(" \ + " caml_copy_string(" + ''; + }); }); }); } diff --git a/run.js b/run.js new file mode 100644 index 0000000000..056c9c1eff --- /dev/null +++ b/run.js @@ -0,0 +1,93 @@ +const fs = require('fs') +const child_process = require('child_process') +const assert = require('assert') + +function michelsonValueToString(value) { + if (value.int !== undefined) { + return value.int.toString() + } + + if (value.string !== undefined) { + return '"' + value.string + '"' + } + + if (value.prim) { + return '(' + value.prim + + ' ' + value.annots.join(' ') + ' ' + + value.args.map(michelsonValueToString).join(' ') + ')' + } + + if (Array.isArray(value)) { + return '{ ' + value.map(michelsonValueToString).join('; ') + ' }' + } +} + +function encodeValue(value) { + return new Promise((resolve, reject) => { + const process = child_process.exec('dune exec ./deku-c/tunac/tests/compile.exe -- value', (err, stdout) => { + if (err) return reject(err) + resolve(Buffer.from(stdout, 'binary')) + }) + + process.stdin.end(michelsonValueToString(value)) + process.stderr.pipe(global.process.stderr) + }) +} + +async function eval(code, parameter, storage) { + const module = await WebAssembly.compile(fs.readFileSync(code)) + console.log((await encodeValue(storage)).toString('hex')) + + const parameterBuffer = await encodeValue({ + prim: 'Pair', + args: [ parameter, storage ], + annots: [] + }) + let storageBuffer + + const imports = { + env: { + parameter_size() { + console.log('parameter_size: Parameter length: %d', parameterBuffer.length) + return parameterBuffer.length + }, + parameter_load(ptr) { + console.log('parameter_load: Pointer location: %d', ptr) + for (let i = 0; i < parameterBuffer.length; i++) { + bytes[i + ptr] = parameterBuffer[i] + } + + return 0 + }, + save_storage(ptr, size) { + console.log('save_storage: Pointer location: %d, size: %d.', ptr, size) + storageBuffer = Buffer.alloc(size) + + for (let i = 0; i < size; i++) { + storageBuffer[i] = bytes[ptr + i] + } + + return 0 + }, + } + } + const instance = new WebAssembly.Instance(module, imports) + + const memory = instance.exports.memory.buffer + const bytes = new Uint8Array(memory) + + instance.exports._start() + + return { storage: storageBuffer } +} + +function assertStorage(res, value) { + assert.equal(res.storage.toString('hex'), value) +} + +async function main() { + let res = await eval('contract.wasm', { prim: 'Unit', args: [], annots: [] }, { int: 42 }) + assertStorage(res, '2a000000') +} + +main() diff --git a/runtime.c b/runtime.c new file mode 100644 index 0000000000..36418c8bb1 --- /dev/null +++ b/runtime.c @@ -0,0 +1,22 @@ +struct stack_node { + void* value; + struct stack_node* next; +}; + +extern struct stack_node* stack; + +// TODO: Change this to be after static data and uninitialized data +void* __heap_start = 0; + +void* malloc(unsigned long size) { + // TODO: Move this to a proper malloc implementation and build a gc + void* ptr = __heap_start; + __heap_start += size; + return ptr; +} + +extern void main(); + +void _start() { + main(); +} \ No newline at end of file diff --git a/trivial.tz b/trivial.tz new file mode 100644 index 0000000000..b7a16aee2d --- /dev/null +++ b/trivial.tz @@ -0,0 +1,3 @@ +{ parameter unit ; + storage unit ; + code { CDR; NIL operation; PAIR } } \ No newline at end of file From e1a0c25d11b81190706a0ca57eee48a12f7036bd Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 20 Dec 2022 20:48:41 -0300 Subject: [PATCH 16/21] wip(tunac): make current tests work on the new llvm output --- deku-c/tunac/lib/dune | 10 ++ deku-c/tunac/lib/iR_of_michelson.ml | 37 ++++- deku-c/tunac/lib/linking.ml | 7 + deku-c/tunac/lib/llvm_of_ir.ml | 206 +++++++++++++++++++++------- deku-c/tunac/lib/runtime.c | 55 ++++++++ deku-c/tunac/lib/tunac.ml | 40 ++---- deku-c/tunac/lib/tunac.mli | 6 +- deku-c/tunac/lib/wasm_of_ir.ml | 13 -- deku-c/tunac/tests/compile.ml | 11 +- deku-c/tunac/tests/tests.js | 18 ++- 10 files changed, 296 insertions(+), 107 deletions(-) create mode 100644 deku-c/tunac/lib/linking.ml create mode 100644 deku-c/tunac/lib/runtime.c diff --git a/deku-c/tunac/lib/dune b/deku-c/tunac/lib/dune index e7548f7c03..8aeae7504e 100644 --- a/deku-c/tunac/lib/dune +++ b/deku-c/tunac/lib/dune @@ -2,3 +2,13 @@ (name tunac) (libraries tezos-micheline binaryen proto-alpha-utils) (preprocess (pps ppx_deriving.show))) + +(install + (files runtime.wasm) + (section share) + (package deku)) + +(rule + (targets runtime.wasm) + (action (run clang --target=wasm32 -c -o %{targets} %{deps})) + (deps runtime.c)) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index b2677cabba..54ee93204a 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -81,8 +81,32 @@ let compile_pair ~env = Env.free_local env item; block -let compile_dig ~env:_ n = - Cassign (0, Cop (Capply "michelson_dig", [ Cconst_i32 n ])) +let compile_dig ~env n = + let n = Int32.sub n 1l in + let counter = Env.alloc_local env in + let node = Env.alloc_local env in + let loop = + Cblock + [ Cassign (counter, Cconst_i32 n) + ; Cassign (node, Cglobal "__michelson_stack") + ; Cwhile (Cvar counter, + Cblock + [ Cassign (counter, Data.dec (Cvar counter)) + ; Cassign (node, Data.cdr (Cvar node)) ]) ] + in + Env.free_local env counter; + let a = Env.alloc_local env in + let block = + Cblock + [ loop + ; Cassign (a, Data.cdr (Cvar node)) + ; Cstore (1, Cvar node, Data.cdr (Cvar a)) + ; Cstore (1, Cvar a, Cglobal "__michelson_stack") + ; Cglobal_assign ("__michelson_stack", Cvar a) ] + in + Env.free_local env a; + Env.free_local env node; + block let compile_dug ~env n = let n = Int32.sub n 1l in @@ -133,7 +157,6 @@ let compile_drop ~env n = block let compile_dup ~env n = - let n = Int32.sub n 1l in let counter = Env.alloc_local env in let node = Env.alloc_local env in let inner_loop = @@ -654,6 +677,10 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let statement = compile_push ~env (Cconst_i32 addr) in Cblock [ statement; compile_instruction env k ] + | IConst (_, Bool_t, v, k) -> + let statement = compile_push ~env (Cconst_i32 (if v then -1l else 0l)) in + Cblock [ statement; compile_instruction env k ] + | IEmpty_map (_, _, _, k) -> let statement = compile_push ~env (Cconst_i32 0l) in Cblock [ statement; compile_instruction env k ] @@ -679,11 +706,11 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Cblock [ statement; compile_instruction env k ] | IDup (_, k) -> - let statement = compile_dup ~env 1l in + let statement = compile_dup ~env 0l in Cblock [ statement; compile_instruction env k ] | IDup_n (_, n, _, k) -> - let statement = compile_dup ~env (Int32.of_int n) in + let statement = compile_dup ~env (Int32.of_int (n - 1)) in Cblock [ statement; compile_instruction env k ] | IDipn (_, n, _, b, k) -> diff --git a/deku-c/tunac/lib/linking.ml b/deku-c/tunac/lib/linking.ml new file mode 100644 index 0000000000..40060c24b2 --- /dev/null +++ b/deku-c/tunac/lib/linking.ml @@ -0,0 +1,7 @@ + +let link_contract objfiles output = + let objfiles = String.concat " " objfiles in + let ret = Sys.command ("wasm-ld -o " ^ output ^ " --export=__michelson_stack --import-undefined " ^ objfiles) in + match ret with + | 0 -> () + | _ -> failwith "Couldn't run linker" \ No newline at end of file diff --git a/deku-c/tunac/lib/llvm_of_ir.ml b/deku-c/tunac/lib/llvm_of_ir.ml index 841e21925d..a907966b95 100644 --- a/deku-c/tunac/lib/llvm_of_ir.ml +++ b/deku-c/tunac/lib/llvm_of_ir.ml @@ -3,129 +3,231 @@ open IR let reg_count = ref 0 let new_reg () = incr reg_count; - Printf.sprintf "%%%d" !reg_count + Printf.sprintf "%%r%d" !reg_count -let compile_wasm_operation op args = - match op, args with - | Wasm_add, [ a; b ] -> +let label_count = ref 0 +let new_label () = + incr label_count; + Printf.sprintf "L%d" !label_count + +let compile_wasm_operation output op args = + let op2 op a b = let a' = new_reg () in let b' = new_reg () in let c' = new_reg () in let c'' = new_reg () in - Format.printf "\t%s = ptrtoint ptr %s to i32\n" a' a; - Format.printf "\t%s = ptrtoint ptr %s to i32\n" b' b; - Format.printf "\t%s = add i32 %s, %s\n" c' a' b'; - Format.printf "\t%s = inttoptr i32 %s to ptr\n" c'' c'; + Format.fprintf output "\t%s = ptrtoint ptr %s to i32\n" a' a; + Format.fprintf output "\t%s = ptrtoint ptr %s to i32\n" b' b; + Format.fprintf output "\t%s = %s i32 %s, %s\n" c' op a' b'; + Format.fprintf output "\t%s = inttoptr i32 %s to ptr\n" c'' c'; c'' + in - | _ -> assert false + let cmp op a b = + let reg = new_reg () in + let reg' = new_reg () in + let reg'' = new_reg () in + Format.fprintf output "\t%s = icmp %s ptr %s, %s\n" reg op a b; + Format.fprintf output "\t%s = select i1 %s, i32 1, i32 0\n" reg' reg; + Format.fprintf output "\t%s = inttoptr i32 %s to ptr\n" reg'' reg'; + reg'' + in -let rec compile_expression expr = + match op, args with + | Wasm_add, [ a; b ] -> op2 "add" a b + | Wasm_sub, [ a; b ] -> op2 "sub" a b + | Wasm_mul, [ a; b ] -> op2 "mul" a b + | Wasm_div, [ a; b ] -> op2 "div" a b + | Wasm_rem, [ a; b ] -> op2 "rem" a b + | Wasm_shr, [ a; b ] -> op2 "lshr" a b + | Wasm_xor, [ a; b ] -> op2 "xor" a b + | Wasm_and, [ a; b ] -> op2 "and" a b + + | Wasm_gt, [ a; b ] -> cmp "sgt" a b + | Wasm_lt, [ a; b ] -> cmp "slt" a b + | Wasm_eq, [ a; b ] -> cmp "eq" a b + | Wasm_eqz, [ a ] -> cmp "eq" a "null" + + | _ -> Format.printf "Unsupported operation %a\n" pp_wasm_operation op; assert false + +let rec compile_expression output expr = match expr with | Cvar local -> let r = new_reg () in - Format.printf "\t%s = load ptr, ptr %%local_%d\n" r local; + Format.fprintf output "\t%s = load ptr, ptr %%local_%d\n" r local; r | Cglobal name -> let r = new_reg () in - Format.printf "\t%s = load ptr, ptr @%s\n" r name; + Format.fprintf output "\t%s = load ptr, ptr @%s\n" r name; r | Cconst_i32 value -> let reg = new_reg () in - Format.printf "\t%s = inttoptr i32 %ld to ptr\n" reg value; + Format.fprintf output "\t%s = inttoptr i32 %ld to ptr\n" reg value; reg | Cop (Cload (cell, _), [ ptr ]) -> - let ptr = compile_expression ptr in + let ptr = compile_expression output ptr in let tmp = new_reg () in let value = new_reg () in - Format.printf "\t%s = getelementptr ptr, ptr %s, i32 %d\n" tmp ptr cell; - Format.printf "\t%s = load ptr, ptr %s\n" value tmp; + Format.fprintf output "\t%s = getelementptr ptr, ptr %s, i32 %d\n" tmp ptr cell; + Format.fprintf output "\t%s = load ptr, ptr %s\n" value tmp; value | Cop (Calloc 0, [ size ]) -> - let size = compile_expression size in + let size = compile_expression output size in let size' = new_reg () in let ptr = new_reg () in - Format.printf "\t%s = ptrtoint ptr %s to i32\n" size' size; - Format.printf "\t%s = call ptr @malloc(i32 %s)\n" ptr size'; + Format.fprintf output "\t%s = ptrtoint ptr %s to i32\n" size' size; + Format.fprintf output "\t%s = call ptr @malloc(i32 %s)\n" ptr size'; ptr | Cop (Calloc cells, []) -> let ptr = new_reg () in - Format.printf "\t%s = call ptr @malloc(i32 %d)\n" ptr (cells * 4); + Format.fprintf output "\t%s = call ptr @malloc(i32 %d)\n" ptr (cells * 4); ptr | Cop (Capply name, args) -> let args = args - |> List.map (fun expr -> Printf.sprintf "ptr %s" (compile_expression expr)) + |> List.map (fun expr -> Printf.sprintf "ptr %s" (compile_expression output expr)) |> String.concat ", " in let reg = new_reg () in - Format.printf "\t%s = call ptr @%s(%s)\n" reg name args; + Format.fprintf output "\t%s = call ptr @%s(%s)\n" reg name args; reg | Cop (Cwasm (op, _), args) -> - let args = List.map compile_expression args in - compile_wasm_operation op args + let args = List.map (compile_expression output) args in + compile_wasm_operation output op args | _ -> - Format.printf "%a\n" IR.pp_expression expr; + Format.fprintf output "%a\n" IR.pp_expression expr; assert false let is_block = function Cblock _ -> true | _ -> false -let rec compile_statement statement = - Format.print_newline (); +let while_stack = ref [] + +let rec compile_statement output statement = + Format.pp_print_newline output (); (* if (not (is_block statement)) then Format.printf "%a\n" pp_statement statement; *) match statement with | Cassign (local, value) -> - let ptr = compile_expression value in - Format.printf "\tstore ptr %s, ptr %%local_%d\n" ptr local + let ptr = compile_expression output value in + Format.fprintf output "\tstore ptr %s, ptr %%local_%d\n" ptr local | Cglobal_assign (global, expr) -> - let value = compile_expression expr in - Format.printf "\tstore ptr %s, ptr @%s\n" value global + let value = compile_expression output expr in + Format.fprintf output "\tstore ptr %s, ptr @%s\n" value global | Cstore (cell, ptr, value) -> - let value = compile_expression value in - let ptr = compile_expression ptr in + let value = compile_expression output value in + let ptr = compile_expression output ptr in let reg = new_reg () in - Format.printf "\t%s = getelementptr ptr, ptr %s, i32 %d\n" reg ptr cell; - Format.printf "\tstore ptr %s, ptr %s\n" value reg - - | Cblock statements -> List.iter compile_statement statements + Format.fprintf output "\t%s = getelementptr ptr, ptr %s, i32 %d\n" reg ptr cell; + Format.fprintf output "\tstore ptr %s, ptr %s\n" value reg - | _ -> - Format.printf "%a\n" IR.pp_statement statement; - assert false + | Cblock statements -> List.iter (compile_statement output) statements -let compile_function name fn = - Format.printf "\ndefine void @%s() {\n" name; + | Cifthenelse (condition, then_branch, else_branch) -> + let condition = + let cond = compile_expression output condition in + let reg = new_reg () in + Format.fprintf output "\t%s = icmp ne ptr %s, null\n" reg cond; + reg + in + let else_label = new_label () in + let then_label = new_label () in + + Format.fprintf output "\tbr i1 %s, label %%%s, label %%%s\n" condition then_label else_label; + + Format.fprintf output "%s: ; else\n" else_label; + compile_statement output else_branch; + + let end_label = new_label () in + Format.fprintf output "\tbr label %%%s\n" end_label; + + Format.fprintf output "%s: ; then\n" then_label; + compile_statement output then_branch; + + Format.fprintf output "\tbr label %%%s\n" end_label; + + Format.fprintf output "%s: ; end\n" end_label; + + | Cwhile (condition, body) -> + let while_label = new_label () in + Format.fprintf output "\tbr label %%%s\n" while_label; + Format.fprintf output "%s: ; while label\n" while_label; + while_stack := while_label :: !while_stack; + let condition = + let cond = compile_expression output condition in + let reg = new_reg () in + Format.fprintf output "\t%s = icmp ne ptr %s, null\n" reg cond; + reg + in + let end_label = new_label () in + let body_label = new_label () in + Format.fprintf output "\tbr i1 %s, label %%%s, label %%%s\n" condition body_label end_label; + Format.fprintf output "%s: ; body\n" body_label; + compile_statement output body; + Format.fprintf output "\tbr label %%%s\n" while_label; + Format.fprintf output "%s: ; while end\n" end_label; + while_stack := List.tl !while_stack + + | Ccontinue -> + let label = List.hd !while_stack in + Format.fprintf output "\tbr label %s\n" label + + | Cfailwith failure -> + let failure = compile_expression output failure in + Format.fprintf output "\tcall void @failwith(ptr %s)\n" failure; + Format.fprintf output "\tunreachable\n" + +let compile_function output name fn = + Format.fprintf output "\ndefine void @%s() {\n" name; let IR_of_michelson.{ body; locals } = fn in for i = 0 to locals do - Format.printf "\t%%local_%d = alloca ptr\n" i; + Format.fprintf output "\t%%local_%d = alloca ptr\n" i; done; - compile_statement body; + compile_statement output body; - Format.printf "\tret void\n}" + Format.fprintf output "\tret void\n}" -let compile_ir contract = +let compile_ir output contract = let IR_of_michelson.{ main; _ } = contract in - Format.printf "@__michelson_stack = global ptr null\n"; - Format.printf "declare ptr @malloc(i32)\n"; - Format.printf "declare ptr @parameter_load(ptr)\n"; - Format.printf "declare ptr @parameter_size()\n"; - Format.printf "declare ptr @save_storage(ptr, ptr)\n"; + Format.fprintf output "@__michelson_stack = global ptr null\n"; + Format.fprintf output "declare ptr @malloc(i32)\n"; + Format.fprintf output "declare ptr @parameter_load(ptr)\n"; + Format.fprintf output "declare ptr @parameter_size()\n"; + Format.fprintf output "declare ptr @save_storage(ptr, ptr)\n"; + Format.fprintf output "declare ptr @failwith(ptr)\n"; + Format.fprintf output "declare ptr @lookup_address(ptr)\n"; + Format.fprintf output "declare ptr @reverse_lookup_address(ptr)\n"; + Format.fprintf output "declare ptr @sender()\n"; + Format.fprintf output "declare ptr @transfer_tokens(ptr, ptr, ptr)\n"; + + (* TODO: Remove these while we don't have a better design for logging *) + Format.fprintf output "declare void @log(ptr)\n"; + Format.fprintf output "declare void @inspect_stack()\n"; + - compile_function "main" main; \ No newline at end of file + Format.fprintf output "define ptr @exec(ptr %%0) { ret ptr null }\n"; + + compile_function output "main" main + +let compile_llvm_to_wasm input output = + let ret = Sys.command ("llc -o " ^ output ^ " --march=wasm32 --filetype=obj -opaque-pointers " ^ input) in + match ret with + | 0 -> () + | _ -> + ignore @@ Sys.command ("cp " ^ input ^ " /tmp/failed.ll"); + failwith "Couldn't compile LLVM module" \ No newline at end of file diff --git a/deku-c/tunac/lib/runtime.c b/deku-c/tunac/lib/runtime.c new file mode 100644 index 0000000000..7cf1fe909c --- /dev/null +++ b/deku-c/tunac/lib/runtime.c @@ -0,0 +1,55 @@ +struct stack_node { + void* value; + struct stack_node* next; +}; + +extern struct stack_node* stack; + +// TODO: Change this to be after static data and uninitialized data +void* __heap_start = 0; + +void* malloc(unsigned long size) { + // TODO: Move this to a proper malloc implementation and build a gc + void* ptr = __heap_start; + __heap_start += size; + return ptr; +} + +struct stack_node { + void* value; + struct stack_node* next; +}; + +extern struct stack_node* __michelson_stack; + +// TODO: Change this to be after static data and uninitialized data +void* __heap_start = 0; + +void* malloc(unsigned long size) { + // TODO: Move this to a proper malloc implementation and build a gc + void* ptr = __heap_start; + __heap_start += size; + return ptr; +} + +extern void log(void *); + +void inspect_stack() { + struct stack_node* node = __michelson_stack; + while (node) { + log(node->value); + node = node->next; + } +} + +extern void main(); + +void _start() { + main(); +} + +extern void main(); + +void _start() { + main(); +} \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.ml b/deku-c/tunac/lib/tunac.ml index dc9896a925..27a80d8848 100644 --- a/deku-c/tunac/lib/tunac.ml +++ b/deku-c/tunac/lib/tunac.ml @@ -41,7 +41,7 @@ let report error = let report_error = function Ok c -> c | Error err -> report err; exit 1 -let compile_contract ~config contract = +let compile_contract ~config:_ contract = let open Lwt_result.Syntax in let open Proto_alpha_utils.Memory_proto_alpha in let canonical_contract = Result.get_ok @@ Protocol.Michelson_v1_primitives.prims_of_strings contract in @@ -54,34 +54,22 @@ let compile_contract ~config contract = in let contract = report_error @@ IR_of_michelson.compile_contract typed_contract in - let () = - Llvm_all_backends.initialize (); - let llvm_mod = Llvm_of_ir.compile_ir contract in - ignore llvm_mod - (* let target = Llvm_target.Target.by_triple "wasm32-unknown-unknown" in - let target_machine = - Llvm_target.TargetMachine.create - ~triple:"wasm32-unknown-unknown" - target - in - Llvm_target.TargetMachine.emit_to_file - llvm_mod - Llvm_target.CodeGenFileType.ObjectFile - "michelson_contract_from_llvm.wasm" - target_machine *) - in + let obj = + let filename, output = Filename.open_temp_file ~mode:[] "contract" ".ll" in + let fmt = Format.formatter_of_out_channel output in + Llvm_of_ir.compile_ir fmt contract; + close_out output; - let wasm_mod = Binaryen.Module.create () in - Wasm_of_ir.compile_ir - ~memory:config.memory - ~optimize:config.optimize - ~debug:config.debug - ~shared_memory:config.shared_memory - wasm_mod - contract + let objfile = Filename.temp_file "contract" ".wasm" in + Llvm_of_ir.compile_llvm_to_wasm filename objfile; + objfile + in + obj let compile_contract ~config contract = let contract = Tezos_micheline.Micheline.strip_locations contract in Lwt_result.map_error (fun _ -> "Error") @@ compile_contract ~config contract -let compile_value = Serialize.compile_value \ No newline at end of file +let compile_value = Serialize.compile_value + +let link = Linking.link_contract \ No newline at end of file diff --git a/deku-c/tunac/lib/tunac.mli b/deku-c/tunac/lib/tunac.mli index 460b545131..44419aeccf 100644 --- a/deku-c/tunac/lib/tunac.mli +++ b/deku-c/tunac/lib/tunac.mli @@ -11,6 +11,8 @@ type config = val parse : string -> contract -val compile_contract : config:config -> contract -> (Binaryen.Module.t, string) Lwt_result.t +val compile_contract : config:config -> contract -> (string, string) Lwt_result.t -val compile_value : node -> bytes \ No newline at end of file +val compile_value : node -> bytes + +val link : string list -> string -> unit \ No newline at end of file diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index efe1923a89..10d3dfec1a 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -243,17 +243,4 @@ let compile_ir ~memory ~optimize ~debug ~shared_memory wasm_mod contract = if optimize then Module.optimize wasm_mod; - let linking = - let open Linking in - [ Symbol_table [ { kind = Symtab_function - ; flags = [ Sym_exported ] - ; index = 10l - ; name = Some "main" } - ; { kind = Symtab_function - ; flags = [ Sym_undefined ] - ; index = 9l - ; name = None } ] ] - in - Linking.add_linking_metadata wasm_mod linking; - wasm_mod \ No newline at end of file diff --git a/deku-c/tunac/tests/compile.ml b/deku-c/tunac/tests/compile.ml index 70fd1ddb47..9620e70cda 100644 --- a/deku-c/tunac/tests/compile.ml +++ b/deku-c/tunac/tests/compile.ml @@ -20,13 +20,16 @@ let save_module wasm_mod filename = open Cmdliner -let compile_contract print debug optimize shared_memory output memory = +let compile_contract _print debug optimize shared_memory output memory = let open Lwt_result.Syntax in let config = Tunac.{ debug; shared_memory; optimize; memory } in let+ wasm_mod = Tunac.compile_contract ~config contract in - if print then - Binaryen.Module.print wasm_mod; - save_module wasm_mod output + Tunac.link + (* FIXME: It needs to be an absolute path for now, + I'll add a command line parameter later as an initial solution. *) + [ "runtime.wasm" + ; wasm_mod ] + output let compile_contract print debug optimize shared_memory output memory = Result.get_ok @@ Lwt_main.run @@ compile_contract print debug optimize shared_memory output memory diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index 1c35cd3846..bb4e23ee48 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -63,7 +63,7 @@ function encodeValue(value) { function inspect_all(exports) { console.log('Stack pointer ', exports.stack.value) - console.log('Heap pointer ', exports.heap.value) + // console.log('Heap pointer ', exports.heap.value) console.log('Stack') let stack = exports.stack.value @@ -102,6 +102,7 @@ function compileMichelsonCode(code) { async function wasmModuleOfMichelson(code) { await compileMichelsonCode(code) + console.log(process.cwd()) const wasm = fs.readFileSync('./mod.wasm') return WebAssembly.compile(wasm) } @@ -131,10 +132,15 @@ async function eval(code, parameter, storage, context = {}) { const imports = { env: { + log(ptr) { + console.log('Log from contract %d', ptr) + }, parameter_size() { + console.log('parameter_size: Parameter length: %d', parameterBuffer.length) return parameterBuffer.length }, parameter_load(ptr) { + console.log('parameter_load: Pointer location: %d', ptr) // console.log('Parameter at %d', ptr) for (let i = 0; i < parameterBuffer.length; i++) { bytes[i + ptr] = parameterBuffer[i] @@ -143,6 +149,7 @@ async function eval(code, parameter, storage, context = {}) { return 0 }, save_storage(ptr, size) { + console.log('save_storage: Pointer location: %d, size: %d.', ptr, size) storageBuffer = Buffer.alloc(size) for (let i = 0; i < size; i++) { @@ -205,7 +212,8 @@ async function eval(code, parameter, storage, context = {}) { } return addrLookup[descriptor] - } + }, + __stack_pointer: new WebAssembly.Global({ value: 'i32', mutable: true }) } } const instance = new WebAssembly.Instance(module, imports) @@ -222,7 +230,7 @@ async function eval(code, parameter, storage, context = {}) { } try { - instance.exports.main() + instance.exports._start() } catch (e) { if (failure === null) { throw e @@ -690,7 +698,7 @@ async function test_fa12() { totalSupply: 1_000_000_000 }) ) - // assertStorage(res, '') + assertStorage(res, '') } -test_fa12() \ No newline at end of file +// test_fa12() \ No newline at end of file From 736935ddfb68ea8873def6b75872e7d163c8fdb3 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 20 Dec 2022 21:20:10 -0300 Subject: [PATCH 17/21] wip: move some of stack instructions into runtime --- deku-c/tunac/lib/iR_of_michelson.ml | 108 ++++++---------------------- deku-c/tunac/lib/llvm_of_ir.ml | 5 ++ deku-c/tunac/lib/runtime.c | 76 +++++++++++++++----- 3 files changed, 83 insertions(+), 106 deletions(-) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index 54ee93204a..3a998d667b 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -82,100 +82,34 @@ let compile_pair ~env = block let compile_dig ~env n = - let n = Int32.sub n 1l in - let counter = Env.alloc_local env in - let node = Env.alloc_local env in - let loop = - Cblock - [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "__michelson_stack") - ; Cwhile (Cvar counter, - Cblock - [ Cassign (counter, Data.dec (Cvar counter)) - ; Cassign (node, Data.cdr (Cvar node)) ]) ] - in - Env.free_local env counter; - let a = Env.alloc_local env in - let block = - Cblock - [ loop - ; Cassign (a, Data.cdr (Cvar node)) - ; Cstore (1, Cvar node, Data.cdr (Cvar a)) - ; Cstore (1, Cvar a, Cglobal "__michelson_stack") - ; Cglobal_assign ("__michelson_stack", Cvar a) ] + let p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_dig_n", [ Cconst_i32 n ])) in - Env.free_local env a; - Env.free_local env node; - block + Env.free_local env p; + s let compile_dug ~env n = - let n = Int32.sub n 1l in - let node = Env.alloc_local env in - let counter = Env.alloc_local env in - let inner_loop = - Cblock - [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Data.cdr (Cglobal "__michelson_stack")) - ; Cwhile (Cvar counter, - Cblock - [ Cassign (counter, Data.dec (Cvar counter)) - ; Cassign (node, Data.cdr (Cvar node)) ]) ] + let p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_dug_n", [ Cconst_i32 n ])) in - Env.free_local env counter; - let head = Env.alloc_local env in - let block = - Cblock - [ inner_loop - ; Cassign (head, Cglobal "__michelson_stack") - ; Cglobal_assign ("__michelson_stack", Data.cdr (Cvar head)) - ; Cstore (1, Cvar head, Data.cdr (Cvar node)) - ; Cstore (1, Cvar node, Cvar head) ] - in - Env.free_local env node; - Env.free_local env head; - block + Env.free_local env p; + s let compile_drop ~env n = - let counter = Env.alloc_local env in - let node = Env.alloc_local env in - let inner_loop = - Cblock - [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "__michelson_stack") - ; Cwhile (Cvar counter, - Cblock - [ Cassign (counter, Data.dec (Cvar counter)) - ; Cassign (node, Data.cdr (Cvar node)) ] ) ] + let p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_drop_n", [ Cconst_i32 n ])) in - Env.free_local env counter; - let block = - Cblock - [ inner_loop - ; Cglobal_assign ("__michelson_stack", Cvar node) ] - in - Env.free_local env node; - block + Env.free_local env p; + s let compile_dup ~env n = - let counter = Env.alloc_local env in - let node = Env.alloc_local env in - let inner_loop = - Cblock - [ Cassign (counter, Cconst_i32 n) - ; Cassign (node, Cglobal "__michelson_stack") - ; Cwhile (Cvar counter - , Cblock - [ Cassign (counter, Data.dec (Cvar counter)) - ; Cassign (node, Data.cdr (Cvar node)) ] ) ] - in - Env.free_local env counter; - let block = - Cblock - [ inner_loop - ; compile_push ~env (Data.car (Cvar node)) ] - in - Env.free_local env node; - block + let p = Env.alloc_local env in + let s = Cassign (p, Cop (Capply "michelson_dup_n", [ Cconst_i32 n ])) in + Env.free_local env p; + s let compile_dip ~env n block = let n = Int32.sub n 1l in @@ -690,11 +624,11 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Cblock [ statement; compile_instruction env k ] | IDig (_, n, _, k) -> - let statement = compile_dig ~env (Int32.of_int n) in + let statement = compile_dig ~env (Int32.of_int (n - 1)) in Cblock [ statement; compile_instruction env k ] | IDug (_, n, _, k) -> - let statement = compile_dug ~env (Int32.of_int n) in + let statement = compile_dug ~env (Int32.of_int (n - 1)) in Cblock [ statement; compile_instruction env k ] | IDrop (_, k) -> diff --git a/deku-c/tunac/lib/llvm_of_ir.ml b/deku-c/tunac/lib/llvm_of_ir.ml index a907966b95..b0f72fbab3 100644 --- a/deku-c/tunac/lib/llvm_of_ir.ml +++ b/deku-c/tunac/lib/llvm_of_ir.ml @@ -215,6 +215,11 @@ let compile_ir output contract = Format.fprintf output "declare ptr @sender()\n"; Format.fprintf output "declare ptr @transfer_tokens(ptr, ptr, ptr)\n"; + Format.fprintf output "declare void @michelson_dup_n(ptr)\n"; + Format.fprintf output "declare void @michelson_drop_n(ptr)\n"; + Format.fprintf output "declare void @michelson_dug_n(ptr)\n"; + Format.fprintf output "declare void @michelson_dig_n(ptr)\n"; + (* TODO: Remove these while we don't have a better design for logging *) Format.fprintf output "declare void @log(ptr)\n"; Format.fprintf output "declare void @inspect_stack()\n"; diff --git a/deku-c/tunac/lib/runtime.c b/deku-c/tunac/lib/runtime.c index 7cf1fe909c..a4c720c1fb 100644 --- a/deku-c/tunac/lib/runtime.c +++ b/deku-c/tunac/lib/runtime.c @@ -1,19 +1,3 @@ -struct stack_node { - void* value; - struct stack_node* next; -}; - -extern struct stack_node* stack; - -// TODO: Change this to be after static data and uninitialized data -void* __heap_start = 0; - -void* malloc(unsigned long size) { - // TODO: Move this to a proper malloc implementation and build a gc - void* ptr = __heap_start; - __heap_start += size; - return ptr; -} struct stack_node { void* value; @@ -42,10 +26,64 @@ void inspect_stack() { } } -extern void main(); +void michelson_push(void* value) { + struct stack_node* node = malloc(sizeof(struct stack_node)); + node->value = value; + node->next = __michelson_stack; + __michelson_stack = node; +} -void _start() { - main(); +void michelson_dup_n(unsigned long n) { + struct stack_node* node = __michelson_stack; + + while (n) { + n--; + node = node->next; + } + + michelson_push(node->value); +} + +void michelson_drop_n(unsigned long n) { + struct stack_node* node = __michelson_stack; + + while (n) { + n--; + node = node->next; + } + + __michelson_stack = node; +} + +void michelson_dug_n(unsigned long n) { + struct stack_node* node; + struct stack_node* head = node = __michelson_stack; + + while (n) { + n--; + node = node->next; + } + + // TODO: This shouldn't use mutability + __michelson_stack = head->next; + head->next = node->next; + node->next = head; +} + +void michelson_dig_n(unsigned long n) { + struct stack_node* node = __michelson_stack; + struct stack_node* a; + + while (n) { + n--; + node = node->next; + } + + // TODO: This shouldn't use mutability + a = node->next; + node->next = a->next; + a->next = __michelson_stack; + __michelson_stack = a; } extern void main(); From 9db2a1a026d964a14484f3e651773d7b6e298fd4 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Tue, 17 Jan 2023 10:03:00 -0300 Subject: [PATCH 18/21] wip: use Rust instead of C for runtime --- deku-c/tunac/lib/runtime/.cargo/config.toml | 5 + deku-c/tunac/lib/runtime/.gitignore | 1 + deku-c/tunac/lib/runtime/Cargo.lock | 7 ++ deku-c/tunac/lib/runtime/Cargo.toml | 11 ++ deku-c/tunac/lib/runtime/src/lib.rs | 107 ++++++++++++++++++++ nix/deku-c/tuna.nix | 6 +- 6 files changed, 135 insertions(+), 2 deletions(-) create mode 100644 deku-c/tunac/lib/runtime/.cargo/config.toml create mode 100644 deku-c/tunac/lib/runtime/.gitignore create mode 100644 deku-c/tunac/lib/runtime/Cargo.lock create mode 100644 deku-c/tunac/lib/runtime/Cargo.toml create mode 100644 deku-c/tunac/lib/runtime/src/lib.rs diff --git a/deku-c/tunac/lib/runtime/.cargo/config.toml b/deku-c/tunac/lib/runtime/.cargo/config.toml new file mode 100644 index 0000000000..7aa4e8cbe5 --- /dev/null +++ b/deku-c/tunac/lib/runtime/.cargo/config.toml @@ -0,0 +1,5 @@ +[build] +rustflags = [ + "-C", "link-arg=--relocatable", + "-C", "link-arg=--no-gc-sections" +] \ No newline at end of file diff --git a/deku-c/tunac/lib/runtime/.gitignore b/deku-c/tunac/lib/runtime/.gitignore new file mode 100644 index 0000000000..c41cc9e35e --- /dev/null +++ b/deku-c/tunac/lib/runtime/.gitignore @@ -0,0 +1 @@ +/target \ No newline at end of file diff --git a/deku-c/tunac/lib/runtime/Cargo.lock b/deku-c/tunac/lib/runtime/Cargo.lock new file mode 100644 index 0000000000..07283154c4 --- /dev/null +++ b/deku-c/tunac/lib/runtime/Cargo.lock @@ -0,0 +1,7 @@ +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +version = 3 + +[[package]] +name = "runtime" +version = "0.1.0" diff --git a/deku-c/tunac/lib/runtime/Cargo.toml b/deku-c/tunac/lib/runtime/Cargo.toml new file mode 100644 index 0000000000..fb313959d8 --- /dev/null +++ b/deku-c/tunac/lib/runtime/Cargo.toml @@ -0,0 +1,11 @@ +[package] +name = "runtime" +version = "0.1.0" +edition = "2021" + +# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html + +[dependencies] + +[lib] +crate-type = ["cdylib"] diff --git a/deku-c/tunac/lib/runtime/src/lib.rs b/deku-c/tunac/lib/runtime/src/lib.rs new file mode 100644 index 0000000000..6d473a8e10 --- /dev/null +++ b/deku-c/tunac/lib/runtime/src/lib.rs @@ -0,0 +1,107 @@ +#![no_std] + +/* + * I'm still figuring out how to properly compile Rust to object files + * and link them with tunac generated files, so while using only rustc + * in order to do it we should avoid using external modules. + */ + +use core::panic::PanicInfo; + +#[panic_handler] +fn handle_panic(_: &PanicInfo) -> ! { + loop {} +} + + +static mut __heap_start: usize = 0; + +#[no_mangle] +pub unsafe extern "C" fn malloc(size: usize) -> usize { + let ptr = __heap_start; + __heap_start += size; + ptr +} + +#[repr(C)] +struct StackNode { + value: *mut u8, + next: *mut StackNode +} + +extern "C" { + // #[no_mangle] + static mut __michelson_stack: *mut StackNode; + + #[no_mangle] + fn main(); +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_push(value: *mut u8) { + let ptr = malloc(core::mem::size_of::()) as *mut StackNode; + let mut node = &mut *ptr; + node.value = value; + node.next = __michelson_stack; + __michelson_stack = ptr; +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_drop_n(n: u32) { + let mut node = __michelson_stack; + let mut n = n; + while n != 0 { + n -= 1; + node = (*node).next; + } + __michelson_stack = node; +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dup_n(n: u32) { + let mut node = __michelson_stack; + let mut n = n; + while n != 0 { + n -= 1; + node = (*node).next; + } + michelson_push((*node).value); +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dug_n(n: u32) { + let mut node = __michelson_stack; + let head = __michelson_stack; + let mut n = n; + + while n != 0 { + n -= 1; + node = (*node).next; + } + + __michelson_stack = (*head).next; + (*head).next = (*node).next; + (*node).next = head; +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dig_n(n: u32) { + let mut node = __michelson_stack; + let mut n = n; + + while n != 0 { + n -= 1; + node = (*node).next; + } + + // TODO: This shouldn't use mutability + let mut a = (*node).next; + (*node).next = (*a).next; + (*a).next = __michelson_stack; + __michelson_stack = a; +} + +#[no_mangle] +pub unsafe extern "C" fn _start() { + main(); +} \ No newline at end of file diff --git a/nix/deku-c/tuna.nix b/nix/deku-c/tuna.nix index 81e81e14ca..0ab265738d 100644 --- a/nix/deku-c/tuna.nix +++ b/nix/deku-c/tuna.nix @@ -29,9 +29,11 @@ buildDunePackage rec { tezos-micheline binaryen proto-alpha-utils - llvm + # llvm pkgs.gdb - # llvmPackages_14.lldb + pkgs.cargo + pkgs.rustup + pkgs.wabt ]; buildInputs = [ From 45814bbd967284f6fb8adb5dcf4526a19d1da92a Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Wed, 18 Jan 2023 17:41:10 -0300 Subject: [PATCH 19/21] wip: refactoring runtime library --- deku-c/tunac/lib/runtime/src/lib.rs | 120 ++++++++++++++++------------ 1 file changed, 71 insertions(+), 49 deletions(-) diff --git a/deku-c/tunac/lib/runtime/src/lib.rs b/deku-c/tunac/lib/runtime/src/lib.rs index 6d473a8e10..2af98b60a9 100644 --- a/deku-c/tunac/lib/runtime/src/lib.rs +++ b/deku-c/tunac/lib/runtime/src/lib.rs @@ -17,88 +17,110 @@ fn handle_panic(_: &PanicInfo) -> ! { static mut __heap_start: usize = 0; #[no_mangle] +#[inline] pub unsafe extern "C" fn malloc(size: usize) -> usize { let ptr = __heap_start; __heap_start += size; ptr } +#[inline] +fn alloc<'a, T>() -> &'a mut T { + unsafe { + // TODO: check pointer + let ptr = malloc(core::mem::size_of::()) as *mut T; + &mut *ptr + } +} + #[repr(C)] -struct StackNode { +#[derive(Clone, Copy)] +struct StackNode<'a> { value: *mut u8, - next: *mut StackNode + next: &'a StackNode<'a> +} + +impl<'a> StackNode<'a> { + pub fn new(value: *mut u8, next: &'a StackNode<'a>) -> &'a StackNode<'a> { + let mut node = alloc::>(); + node.value = value; + node.next = next; + node + } + + pub fn value(&'a self) -> *mut u8 { + self.value + } + + pub fn next(&'a self) -> &'a StackNode<'a> { + self.next + } + + pub fn push(&'a self, value: *mut u8) -> &'a StackNode<'a> { + StackNode::new(value, self) + } + + pub fn drop(&'a self, n: u32) -> &'a StackNode<'a> { + if n == 0 { + return self; + } + + self.next().drop(n - 1) + } + + pub fn dup(&'a self, n: u32) -> &'a StackNode<'a> { + self.push(self.drop(n).value()) + } + + pub fn push_nth(&'a self, n: u32, value: *mut u8) -> &'a StackNode<'a> { + if n == 0 { + return self.push(value) + } + + self.next().push_nth(n - 1, value).push(self.value()) + } + + pub fn pop_nth(&'a self, n: u32) -> (*mut u8, &'a StackNode<'a>) { + if n == 0 { + let digged = self.next(); + return (digged.value(), digged.next().push(self.value())) + } + + let (value, next) = self.next().pop_nth(n - 1); + (value, next.push(self.value())) + } } extern "C" { - // #[no_mangle] - static mut __michelson_stack: *mut StackNode; + static mut __michelson_stack: &'static mut StackNode<'static>; - #[no_mangle] fn main(); } #[no_mangle] pub unsafe extern "C" fn michelson_push(value: *mut u8) { - let ptr = malloc(core::mem::size_of::()) as *mut StackNode; - let mut node = &mut *ptr; - node.value = value; - node.next = __michelson_stack; - __michelson_stack = ptr; + *__michelson_stack = *__michelson_stack.push(value) } #[no_mangle] pub unsafe extern "C" fn michelson_drop_n(n: u32) { - let mut node = __michelson_stack; - let mut n = n; - while n != 0 { - n -= 1; - node = (*node).next; - } - __michelson_stack = node; + *__michelson_stack = *__michelson_stack.drop(n); } #[no_mangle] pub unsafe extern "C" fn michelson_dup_n(n: u32) { - let mut node = __michelson_stack; - let mut n = n; - while n != 0 { - n -= 1; - node = (*node).next; - } - michelson_push((*node).value); + *__michelson_stack = *__michelson_stack.dup(n) } #[no_mangle] pub unsafe extern "C" fn michelson_dug_n(n: u32) { - let mut node = __michelson_stack; - let head = __michelson_stack; - let mut n = n; - - while n != 0 { - n -= 1; - node = (*node).next; - } - - __michelson_stack = (*head).next; - (*head).next = (*node).next; - (*node).next = head; + *__michelson_stack = *__michelson_stack.push_nth(n, __michelson_stack.value()) } #[no_mangle] pub unsafe extern "C" fn michelson_dig_n(n: u32) { - let mut node = __michelson_stack; - let mut n = n; - - while n != 0 { - n -= 1; - node = (*node).next; - } - - // TODO: This shouldn't use mutability - let mut a = (*node).next; - (*node).next = (*a).next; - (*a).next = __michelson_stack; - __michelson_stack = a; + let (value, stack) = __michelson_stack.pop_nth(n); + *__michelson_stack = *stack.push(value) } #[no_mangle] From 79fc642223bab491bc0d5ecb5031621a2cc77ce3 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Wed, 1 Feb 2023 15:24:47 -0300 Subject: [PATCH 20/21] wip: comparisons --- deku-c/tunac/lib/iR_of_michelson.ml | 76 +++++++++------------ deku-c/tunac/lib/llvm_of_ir.ml | 101 +++++++++++++++++++++++----- deku-c/tunac/lib/wasm_of_ir.ml | 4 +- deku-c/tunac/tests/tests.js | 2 +- 4 files changed, 121 insertions(+), 62 deletions(-) diff --git a/deku-c/tunac/lib/iR_of_michelson.ml b/deku-c/tunac/lib/iR_of_michelson.ml index 3a998d667b..833cef9ef6 100644 --- a/deku-c/tunac/lib/iR_of_michelson.ml +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -23,6 +23,7 @@ type function_ = type contract = { main : function_ ; lambdas : (int * function_) list + ; compare : (int * function_) list ; static_data : bytes } module Env = struct @@ -154,7 +155,7 @@ let compile_dip ~env n block = let lambdas = ref [] let static_data = ref Bytes.empty -let rec compile_compare: type a b. Env.t -> expression -> expression -> int -> (a, b) ty -> statement = fun env x y var typ -> +let rec compile_static_compare: type a b. Env.t -> expression -> expression -> int -> (a, b) ty -> statement = fun env x y var typ -> let compare_i32 typ var x y = Cblock [ Cassign (var, Cop (Cwasm (Wasm_sub, typ), [ x; y ])) @@ -178,13 +179,15 @@ let rec compile_compare: type a b. Env.t -> expression -> expression -> int -> ( let b = Env.alloc_local env in let block = Cblock - [ compile_compare env (Data.car x) (Data.car y) a fst - ; compile_compare env (Data.cdr x) (Data.cdr y) b snd + [ compile_static_compare env (Data.car x) (Data.car y) a fst + ; compile_static_compare env (Data.cdr x) (Data.cdr y) b snd ; Cifthenelse (Cop (Cwasm (Wasm_eqz, I32), [ Cvar a ]) , Cassign (var, Cvar b) , Cassign (var, Cvar a)) ] in + Env.free_local env a; + Env.free_local env b; block | Bool_t -> @@ -205,41 +208,24 @@ let rec compile_compare: type a b. Env.t -> expression -> expression -> int -> ( | _ -> assert false -let compile_map_get env key_type map key value = - let compare = Env.alloc_local env in - let block = - Cblock - [ Cassign (value, Cconst_i32 0l) - ; Cwhile - (Cvar map - , Cblock - [ compile_compare env (Cvar key) (Data.car (Data.car (Cvar map))) compare key_type - ; Cifthenelse - (Cop (Cwasm (Wasm_eqz, I32), [ Cvar compare ]) - , Cblock - [ Cassign (value, Data.cdr (Data.car (Cvar map))) - ; Cassign (map, Cconst_i32 0l) ] - , Cassign (map, Data.cdr (Cvar map))) ]) ] - in - Env.free_local env compare; - block +let compile_dynamic_compare compare_key v a b = + Cassign (v, Cop (Capply "michelson_dynamic_compare", [ compare_key; a; b ])) -let compile_update_map env map key value = - let head = Env.alloc_local env in - let entry = Env.alloc_local env in - let block = - Cblock - [ Cassign (entry, Cop (Calloc 2, [])) - ; Cstore (0, Cvar entry, Cvar key) - ; Cstore (1, Cvar entry, Cvar value) - ; Cassign (head, Cop (Calloc 2, [])) - ; Cstore (0, Cvar head, Cvar entry) - ; Cstore (1, Cvar head, Cvar map) - ; Cassign (map, Cvar head) ] - in - Env.free_local env head; - Env.free_local env entry; - block +let compare_functions = ref [] + +let compile_compare_function: type a. a comparable_ty -> int = fun typ -> + let env = Env.make () in + let ret = Env.alloc_local env in + let statement = compile_static_compare env (Cvar 0) (Cvar 1) ret typ in + let fn = { body = statement; locals = Env.max env + 1 } in + compare_functions := (ret, fn) :: !compare_functions; + List.length !compare_functions - 1 + +let compile_map_get _env map key value = + Cassign (value, Cop (Capply "michelson_map_get", [ Cvar map; Cvar key ])) + +let compile_update_map _env map key value = + Cassign (map, Cop (Capply "michelson_map_update", [ Cvar map; Cvar key; Cvar value ])) let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> statement = fun env instr -> let int_operation typ op = @@ -615,12 +601,14 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let statement = compile_push ~env (Cconst_i32 (if v then -1l else 0l)) in Cblock [ statement; compile_instruction env k ] - | IEmpty_map (_, _, _, k) -> - let statement = compile_push ~env (Cconst_i32 0l) in + | IEmpty_map (_, key_type, _, k) -> + let key = compile_compare_function key_type in + let statement = compile_push ~env (Cconst_i32 (Int32.of_int key)) in Cblock [ statement; compile_instruction env k ] - | IEmpty_set (_, _, k) -> - let statement = compile_push ~env (Cconst_i32 0l) in + | IEmpty_set (_, key_type, k) -> + let key = compile_compare_function key_type in + let statement = compile_push ~env (Cconst_i32 (Int32.of_int key)) in Cblock [ statement; compile_instruction env k ] | IDig (_, n, _, k) -> @@ -780,7 +768,7 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state Cblock [ compile_pop x ; compile_pop y - ; compile_compare env (Cvar x) (Cvar y) v typ + ; compile_static_compare env (Cvar x) (Cvar y) v typ ; compile_push ~env (Cvar v) ] in Env.free_local env v; @@ -874,7 +862,7 @@ let rec compile_instruction: type a b c d. Env.t -> (a, b, c, d) kinstr -> state let map = Env.alloc_local env in let key = Env.alloc_local env in let value = Env.alloc_local env in - let map_get = compile_map_get env Int_t map key value in + let map_get = compile_map_get env map key value in let push = compile_push ~env (Cvar value) in let block = Cblock @@ -1363,7 +1351,7 @@ let compile_contract contract = |> List.rev |> List.mapi (fun idx (body, env) -> (idx, { body; locals = Env.max env + 1 })) in - { main; lambdas; static_data = !static_data } + { main; lambdas; static_data = !static_data; compare = !compare_functions } let compile_contract contract = try Ok (compile_contract contract) diff --git a/deku-c/tunac/lib/llvm_of_ir.ml b/deku-c/tunac/lib/llvm_of_ir.ml index b0f72fbab3..0ddcac84af 100644 --- a/deku-c/tunac/lib/llvm_of_ir.ml +++ b/deku-c/tunac/lib/llvm_of_ir.ml @@ -10,16 +10,24 @@ let new_label () = incr label_count; Printf.sprintf "L%d" !label_count -let compile_wasm_operation output op args = +let compile_wasm_operation output typ op args = + let typ = + match typ with + | I32 -> "i32" + | U32 -> "u32" + | I8 -> "i8" + | U8 -> "u8" + in + let op2 op a b = let a' = new_reg () in let b' = new_reg () in let c' = new_reg () in let c'' = new_reg () in - Format.fprintf output "\t%s = ptrtoint ptr %s to i32\n" a' a; - Format.fprintf output "\t%s = ptrtoint ptr %s to i32\n" b' b; - Format.fprintf output "\t%s = %s i32 %s, %s\n" c' op a' b'; - Format.fprintf output "\t%s = inttoptr i32 %s to ptr\n" c'' c'; + Format.fprintf output "\t%s = ptrtoint ptr %s to %s\n" a' a typ; + Format.fprintf output "\t%s = ptrtoint ptr %s to %s\n" b' b typ; + Format.fprintf output "\t%s = %s %s %s, %s\n" c' op typ a' b'; + Format.fprintf output "\t%s = inttoptr %s %s to ptr\n" c'' typ c'; c'' in @@ -98,9 +106,9 @@ let rec compile_expression output expr = Format.fprintf output "\t%s = call ptr @%s(%s)\n" reg name args; reg - | Cop (Cwasm (op, _), args) -> + | Cop (Cwasm (op, typ), args) -> let args = List.map (compile_expression output) args in - compile_wasm_operation output op args + compile_wasm_operation output typ op args | _ -> Format.fprintf output "%a\n" IR.pp_expression expr; @@ -188,21 +196,77 @@ let rec compile_statement output statement = Format.fprintf output "\tcall void @failwith(ptr %s)\n" failure; Format.fprintf output "\tunreachable\n" -let compile_function output name fn = - Format.fprintf output "\ndefine void @%s() {\n" name; - - let IR_of_michelson.{ body; locals } = fn in - +let compile_function_body output arguments body locals = for i = 0 to locals do Format.fprintf output "\t%%local_%d = alloca ptr\n" i; done; + for i = 0 to arguments - 1 do + Format.fprintf output "\tstore ptr %%%d, ptr %%local_%d\n" i i; + done; + compile_statement output body - compile_statement output body; - +let compile_function output name fn = + Format.fprintf output "\ndefine void @%s() {\n" name; + let IR_of_michelson.{ body; locals } = fn in + compile_function_body output 0 body locals; Format.fprintf output "\tret void\n}" +let compile_compare_function output name ret fn = + Format.fprintf output "\ndefine ptr @%s(ptr %%0, ptr %%1) {\n" name; + let IR_of_michelson.{ body; locals } = fn in + + compile_function_body output 2 body locals; + let ret_reg = new_reg () in + Format.fprintf output "\t%s = load ptr, ptr %%local_%d\n" ret_reg ret; + Format.fprintf output "\tret ptr %s\n }" ret_reg + +let compile_main_compare_function output functions = + let functions = List.rev functions in + List.iteri + (fun idx (ret, fn) -> + let name = Printf.sprintf "michelson_compare_function_%d" idx in + compile_compare_function output name ret fn) + functions; + + Format.fprintf output "\ndefine i32 @michelson_dynamic_compare(ptr %%0, ptr %%1, ptr %%2) {\n"; + + let return_value = new_reg () in + Format.fprintf output "\n%s = alloca i32\n" return_value; + let switch = new_label () in + let default = new_label () in + let key = new_reg () in + Format.fprintf output "br label %%%s\n" switch; + Format.fprintf output "%s:\n" switch; + Format.fprintf output "\t%s = ptrtoint ptr %%0 to i32\n" key; + Format.fprintf output "\tswitch i32 %s, label %%%s [\n" key default; + List.iteri + (fun idx _ -> + Format.fprintf output "\t\ti32 %d, label %%branch_%d\n" idx idx) + functions; + + Format.fprintf output "\t]\n"; + Format.fprintf output "%s:\n" default; + Format.fprintf output "\tunreachable\n"; + + let return_point = new_label () in + + List.iteri + (fun idx _ -> + let value = new_reg () in + Format.fprintf output "\nbranch_%d:\n" idx; + Format.fprintf output "\t%s = call i32 @michelson_compare_function_%d(ptr %%1, ptr %%2)\n" value idx; + Format.fprintf output "\tstore i32 %s, ptr %s\n" value return_value; + Format.fprintf output "\tbr label %%%s\n" return_point) + functions; + + Format.fprintf output "%s:\n" return_point; + let value = new_reg () in + Format.fprintf output "\t%s = load i32, ptr %s\n" value return_value; + Format.fprintf output "\tret i32 %s\n" value; + Format.fprintf output "}\n" + let compile_ir output contract = - let IR_of_michelson.{ main; _ } = contract in + let IR_of_michelson.{ main; compare; _ } = contract in Format.fprintf output "@__michelson_stack = global ptr null\n"; Format.fprintf output "declare ptr @malloc(i32)\n"; @@ -220,13 +284,18 @@ let compile_ir output contract = Format.fprintf output "declare void @michelson_dug_n(ptr)\n"; Format.fprintf output "declare void @michelson_dig_n(ptr)\n"; + Format.fprintf output "declare ptr @michelson_map_get(ptr, ptr)\n"; + Format.fprintf output "declare ptr @michelson_map_update(ptr, ptr, ptr)\n"; + (* TODO: Remove these while we don't have a better design for logging *) - Format.fprintf output "declare void @log(ptr)\n"; + Format.fprintf output "declare void @writev(ptr)\n"; Format.fprintf output "declare void @inspect_stack()\n"; + (* TODO: add lambdas *) Format.fprintf output "define ptr @exec(ptr %%0) { ret ptr null }\n"; + compile_main_compare_function output compare; compile_function output "main" main let compile_llvm_to_wasm input output = diff --git a/deku-c/tunac/lib/wasm_of_ir.ml b/deku-c/tunac/lib/wasm_of_ir.ml index 10d3dfec1a..11054c043c 100644 --- a/deku-c/tunac/lib/wasm_of_ir.ml +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -1,6 +1,8 @@ open IR open Binaryen +(* This is not being maintained in favor of llvm_of_ir, do not rely on this. *) + let gensym_count = ref 0 let gensym name = incr gensym_count; @@ -185,7 +187,7 @@ let compile_malloc wasm_mod = Function.add_function wasm_mod "malloc" Type.int32 Type.int32 [| Type.int32 |] body let compile_ir ~memory ~optimize ~debug ~shared_memory wasm_mod contract = - let IR_of_michelson.{ main; lambdas; static_data } = contract in + let IR_of_michelson.{ main; lambdas; static_data; _ } = contract in add_function wasm_mod "main" main; if lambdas <> [] then diff --git a/deku-c/tunac/tests/tests.js b/deku-c/tunac/tests/tests.js index bb4e23ee48..f44ba263e4 100644 --- a/deku-c/tunac/tests/tests.js +++ b/deku-c/tunac/tests/tests.js @@ -132,7 +132,7 @@ async function eval(code, parameter, storage, context = {}) { const imports = { env: { - log(ptr) { + writev(ptr) { console.log('Log from contract %d', ptr) }, parameter_size() { From e443efe4c862bb4a1eba84d5463dcc35260aae25 Mon Sep 17 00:00:00 2001 From: Renato Alencar Date: Wed, 1 Feb 2023 15:25:34 -0300 Subject: [PATCH 21/21] wip: maps proof of concept --- deku-c/tunac/lib/runtime/src/lib.rs | 147 ++++++++++++++++++++++++++-- 1 file changed, 141 insertions(+), 6 deletions(-) diff --git a/deku-c/tunac/lib/runtime/src/lib.rs b/deku-c/tunac/lib/runtime/src/lib.rs index 2af98b60a9..6b2112c617 100644 --- a/deku-c/tunac/lib/runtime/src/lib.rs +++ b/deku-c/tunac/lib/runtime/src/lib.rs @@ -33,6 +33,22 @@ fn alloc<'a, T>() -> &'a mut T { } } +struct Box<'a, T> (&'a T); + +impl<'a, T> Box<'a, T> { + pub fn new(value: T) -> Self { + unsafe { + let ptr = malloc(core::mem::size_of::()) as *mut T; + core::ptr::copy(&value, ptr, 1); + Box(&*ptr) + } + } + + pub fn as_ref(self) -> &'a T { + self.0 + } +} + #[repr(C)] #[derive(Clone, Copy)] struct StackNode<'a> { @@ -41,11 +57,8 @@ struct StackNode<'a> { } impl<'a> StackNode<'a> { - pub fn new(value: *mut u8, next: &'a StackNode<'a>) -> &'a StackNode<'a> { - let mut node = alloc::>(); - node.value = value; - node.next = next; - node + pub fn new(value: *mut u8, next: &'a StackNode<'a>) -> Box> { + Box::new(StackNode { value, next }) } pub fn value(&'a self) -> *mut u8 { @@ -57,7 +70,7 @@ impl<'a> StackNode<'a> { } pub fn push(&'a self, value: *mut u8) -> &'a StackNode<'a> { - StackNode::new(value, self) + StackNode::new(value, self).as_ref() } pub fn drop(&'a self, n: u32) -> &'a StackNode<'a> { @@ -94,6 +107,9 @@ impl<'a> StackNode<'a> { extern "C" { static mut __michelson_stack: &'static mut StackNode<'static>; + fn michelson_dynamic_compare(compare: u32, a: u32, b: u32) -> i32; + fn writev(x: u32); + fn main(); } @@ -123,6 +139,125 @@ pub unsafe extern "C" fn michelson_dig_n(n: u32) { *__michelson_stack = *stack.push(value) } +#[no_mangle] +pub unsafe extern "C" fn michelson_map_get(map: u32, key: u32) -> u32 { + Map::from(map).find(key).as_u32() +} + +struct Value { value: u32 } + +impl Value { + pub fn from(value: u32) -> Self { + Value { value } + } + + pub fn as_pair(&self) -> &'static (u32, u32) { + unsafe { &*(self.value as *const (u32, u32)) } + } + + pub fn as_triple(&self) -> &'static (u32, u32, u32) { + unsafe { &*(self.value as *const (u32, u32, u32)) } + } + + pub fn as_option(&self) -> Option { + match self.value { + 0 => None, + _ => Some(self.as_pair().1) + } + } + + pub fn as_u32(&self) -> u32 { + self.value + } + + pub fn pair(a: u32, b: u32) -> Self { + let pair = alloc::<(u32, u32)>(); + pair.0 = a; + pair.1 = b; + Value::from(pair as *const _ as u32) + } + + pub fn triple(a: u32, b: u32, c: u32) -> Self { + let triple = alloc::<(u32, u32, u32)>(); + triple.0 = a; + triple.1 = b; + triple.2 = c; + Value::from(triple as *const _ as u32) + } + + pub fn some(x: u32) -> Self { + Self::pair(1, x) + } + + pub fn none() -> Self { + Self::from(0) + } + + pub fn is_null(&self) -> bool { + self.value == 0 + } +} + +struct Map { + value: Value, + compare: u32 +} + +impl Map { + pub fn insert(self, key: u32, value: u32) -> Self { + Map { + value: Value::triple(key, value, self.as_u32()), + compare: self.compare + } + } + + pub fn from(value: u32) -> Self { + Map { + value: Value::from(value >> 4), + compare: value & 0xf + } + } + + pub fn key(&self) -> u32 { + self.value.as_triple().0 + } + + pub fn value(&self) -> u32 { + self.value.as_triple().1 + } + + pub fn next(&self) -> Box { + Box::new(Map::from(self.value.as_triple().2)) + } + + pub fn find_node(&self, key: u32) -> Option<&Map> { + if self.value.is_null() { + return None; + } + + match unsafe { michelson_dynamic_compare(self.compare, key, self.key()) } { + 0 => Some(self), + _ => self.next().as_ref().find_node(key) + } + } + + pub fn find(&self, key: u32) -> Value { + match self.find_node(key) { + Some(node) => Value::some(node.value()), + None => Value::none() + } + } + + pub fn as_u32(&self) -> u32 { + (self.value.as_u32() << 4) | self.compare + } +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_map_update(map: u32, key: u32, value: u32) -> u32 { + Map::from(map).insert(key, value).as_u32() +} + #[no_mangle] pub unsafe extern "C" fn _start() { main();