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/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..8aeae7504e 100644 --- a/deku-c/tunac/lib/dune +++ b/deku-c/tunac/lib/dune @@ -1,14 +1,14 @@ (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 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/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..964ef2288a --- /dev/null +++ b/deku-c/tunac/lib/iR.ml @@ -0,0 +1,84 @@ +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 wasm_type = + | I8 + | U8 + | I32 + | U32 +[@@deriving show] + +type operation = + | Capply of string + | Cload of int * wasm_type + | Calloc of int + | Cwasm of wasm_operation * wasm_type +[@@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 + | 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 ?(typ = I32) expr = Cop (Cload (0, typ), [ expr ]) + + let cdr ?(typ = I32) expr = Cop (Cload (1, typ), [ expr ]) + + let add ?(typ = I32) a b = Cop (Cwasm (Wasm_add, typ), [ a; b ]) + + let sub ?(typ = I32) a b = Cop (Cwasm (Wasm_sub, typ), [ 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 new file mode 100644 index 0000000000..833cef9ef6 --- /dev/null +++ b/deku-c/tunac/lib/iR_of_michelson.ml @@ -0,0 +1,1358 @@ +open Tezos_micheline +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 *) + +exception Compilation_error of error + +type function_ = + { body : statement + ; locals : int } + +type contract = + { main : function_ + ; lambdas : (int * function_) list + ; compare : (int * function_) list + ; static_data : bytes } + +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 ( + t.max <- Int.max reg t.max; + 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 compile_pop var = + Cblock + [ 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 "__michelson_stack") + ; Cglobal_assign ("__michelson_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, Data.alloc 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 p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_dig_n", [ Cconst_i32 n ])) + in + Env.free_local env p; + s + +let compile_dug ~env n = + let p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_dug_n", [ Cconst_i32 n ])) + in + Env.free_local env p; + s + +let compile_drop ~env n = + let p = Env.alloc_local env in + let s = + Cassign (p, Cop (Capply "michelson_drop_n", [ Cconst_i32 n ])) + in + Env.free_local env p; + s + +let compile_dup ~env n = + 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 + 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 "__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 pair = Env.alloc_local env in + let save_stack_block = + Cblock + [ Cassign (pair, Cop (Calloc 2, [])) + ; Cstore (0, Cvar pair, Cglobal "__michelson_stack") + ; Cstore (1, Cvar pair, 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; + + (* 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, 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 ] + +let lambdas = ref [] +let static_data = ref Bytes.empty + +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 ])) + ; 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_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 -> + 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_dynamic_compare compare_key v a b = + Cassign (v, Cop (Capply "michelson_dynamic_compare", [ compare_key; a; b ])) + +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 = + 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 + let block = + Cblock [ compile_pop top + ; compile_push ~env (Data.car (Cvar top)) ] + in + Env.free_local env top; + Cblock [ block; compile_instruction env k ] + + | 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; + Cblock [ block; compile_instruction env k ] + + | IUnpair (_, k) -> + let top = Env.alloc_local env in + let block = + Cblock [ compile_pop top + ; compile_push ~env (Data.cdr (Cvar top)) + ; compile_push ~env (Data.car (Cvar top)) ] + in + 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 block = int_operation I32 Wasm_add in + Cblock [ block; compile_instruction env k ] + + | ISub_int (_, k) -> + let block = int_operation I32 Wasm_sub in + Cblock [ block; compile_instruction env k ] + + | IMul_int (_, k) -> + 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 ])) ] + in + Env.free_local env x; + Cblock [ block; compile_instruction env k ] + + | IEq (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop 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; + Cblock [ block; compile_instruction env k ] + + | 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, 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; + Cblock [ block; compile_instruction env k ] + + | IEdiv_int (_, k) -> + 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, 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) ] + , 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; + Cblock [ block; compile_instruction env k ] + + (* Missing arithmetic instruction: INT, ISNAT, LSL, LSR *) + + | 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, I32), [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + Cblock [ block; compile_instruction env k ] + + | INot (_, k) -> + let p = Env.alloc_local env in + let block = + Cblock + [ compile_pop p + ; compile_push ~env (Cop (Cwasm (Wasm_xor, I32), [ Cvar p; Cconst_i32 0xffffffffl ])) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | 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, I32), [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + Cblock [ block; compile_instruction env k ] + + | 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, I32), [ Cvar p; Cvar q ])) ] + in + Env.free_local env p; + Env.free_local env q; + Cblock [ block; compile_instruction env k ] + + | IConst (_, Unit_t, (), k) -> + let p = compile_push ~env (Cconst_i32 0l) in + Cblock [ p; compile_instruction env k ] + + | ICons_none (_, _, k) -> + let p = compile_push ~env (Cconst_i32 0l) in + Cblock [ p; compile_instruction env k ] + + | INil (_, _, 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 + 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; + Cblock [ block; compile_instruction env k ] + + | ICons_left (_, _, k) -> + 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; + Cblock [ block; compile_instruction env k ] + + | ICons_right (_, _, k) -> + 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; + Cblock [ block; compile_instruction env k ] + + | ICons_pair (_, k) -> + (* TODO: Support IComb *) + 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 *) + 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; + Cblock [ block; compile_instruction env k ] + + | IIf_left { loc = _; branch_if_left; branch_if_right; k } -> + let p = Env.alloc_local env in + let block = + [ compile_pop p + ; compile_push ~env (Cop (Cload (1, I32), [ Cvar p ])) ] + in + Env.free_local env p; + 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 ]) + + | 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 + , compile_instruction env branch_if_true + , compile_instruction env branch_if_false) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | IIf_cons { loc = _; branch_if_cons; branch_if_nil; k } -> + 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)) + ; compile_instruction env branch_if_cons ] + , compile_instruction env branch_if_nil) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | IIf_none { loc = _; branch_if_some; branch_if_none; k } -> + 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_instruction env branch_if_some ] + , compile_instruction env branch_if_none) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ISwap (_, k) -> + 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; + Cblock [ block; compile_instruction env k ] + + | IConst (_, Int_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 (_, 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 *) + 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 ] + + | 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 (_, 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 (_, 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) -> + 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 - 1)) in + Cblock [ statement; compile_instruction env k ] + + | IDrop (_, k) -> + let statement = compile_drop ~env 1l in + Cblock [ statement; compile_instruction env k ] + + | IDropn (_, n, _, k) -> + let statement = compile_drop ~env (Int32.of_int n) in + Cblock [ statement; compile_instruction env k ] + + | IDup (_, k) -> + 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 - 1)) in + Cblock [ statement; compile_instruction env k ] + + | IDipn (_, n, _, b, k) -> + let block = compile_instruction env b in + if n = 0 then block + else + let statement = compile_dip ~env (Int32.of_int n) block in + Cblock [ statement; compile_instruction env k ] + + | IDip (_, b, _, 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 + Cblock [ compile_pop param; Cfailwith (Cvar param) ] + + | IList_iter (_, _, b, k) -> + let iter = Env.alloc_local env in + let iter_body = compile_instruction env b 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; + Cblock [ block; compile_instruction env k ] + + | ILoop (_, b, k) -> + (* TODO: Test it *) + let p = Env.alloc_local env in + let body = compile_instruction env b in + let block = + Cblock + [ Cassign (p, Cconst_i32 1l) + ; Cwhile (Cconst_i32 1l, + Cblock + [ compile_pop p + ; body ]) ] + in + Env.free_local env p; + Cblock [ block; compile_instruction env k ] + + | ILoop_left (_, b, k) -> + (* TODO: Test it *) + let p = Env.alloc_local env in + 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 = compile_instruction lenv body in + let lambda_n = Int32.of_int (List.length !lambdas) in + lambdas := (body, lenv) :: !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; + Cblock [ block; compile_instruction env k ] + + | IApply (_, _, k) -> + 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; + Cblock [ block; compile_instruction env k ] + + | IExec (_, _, k) -> + (* 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, I32), [ Cvar lambda ])) + ; Cstore (1, Cvar pair, Cvar argument) + ; Cassign (lambda, Data.cdr (Cvar lambda)) + ; Cassign (argument, Cvar pair) ]) + ; compile_push ~env (Cvar argument) + ; 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; + Env.free_local env pair; + Cblock [ block; compile_instruction env k ] + + | 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_static_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 ] + + | 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) -> + let statement = compile_push ~env (Cop (Capply "sender", [])) in + Cblock [ statement; compile_instruction env k ] + + | IAmount (_, k) -> + let statement = compile_push ~env (Cop (Capply "amount", [])) in + Cblock [ statement; 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 + (* TODO encode ticket 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 map_get = compile_map_get env map key value in + let push = compile_push ~env (Cvar value) in + let block = + Cblock + [ compile_pop key + ; compile_pop map + ; map_get + ; push ] + in + Env.free_local env map; + Env.free_local env key; + 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 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 + ; 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)) + +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, I32), [ Cvar ptr ])) + ; 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 = + Cblock + [ Cassign (var, Cop (Calloc 2, [])) + ; 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 + + | List_t (typ, _) -> + 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 block = + 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)) ] + in + Env.free_local env value; + block + + | 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 (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)) + +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 -> 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 (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 = + + 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 + 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 "__michelson_stack"))) + ; 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; + Env.free_local env size; + Env.free_local env value; + block + in + + 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 = + !lambdas + |> List.rev + |> List.mapi (fun idx (body, env) -> (idx, { body; locals = Env.max env + 1 })) + in + { main; lambdas; static_data = !static_data; compare = !compare_functions } + +let compile_contract contract = + try Ok (compile_contract contract) + with Compilation_error err -> Error err 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 new file mode 100644 index 0000000000..0ddcac84af --- /dev/null +++ b/deku-c/tunac/lib/llvm_of_ir.ml @@ -0,0 +1,307 @@ +open IR + +let reg_count = ref 0 +let new_reg () = + incr reg_count; + Printf.sprintf "%%r%d" !reg_count + +let label_count = ref 0 +let new_label () = + incr label_count; + Printf.sprintf "L%d" !label_count + +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 %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 + + 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 + + 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.fprintf output "\t%s = load ptr, ptr %%local_%d\n" r local; + r + + | Cglobal name -> + let r = new_reg () in + Format.fprintf output "\t%s = load ptr, ptr @%s\n" r name; + r + + | Cconst_i32 value -> + let reg = new_reg () in + Format.fprintf output "\t%s = inttoptr i32 %ld to ptr\n" reg value; + reg + + | Cop (Cload (cell, _), [ ptr ]) -> + let ptr = compile_expression output ptr in + let tmp = new_reg () in + let value = new_reg () in + 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 output size in + let size' = new_reg () in + let ptr = new_reg () in + 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.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 output expr)) + |> String.concat ", " + in + let reg = new_reg () in + Format.fprintf output "\t%s = call ptr @%s(%s)\n" reg name args; + reg + + | Cop (Cwasm (op, typ), args) -> + let args = List.map (compile_expression output) args in + compile_wasm_operation output typ op args + + | _ -> + Format.fprintf output "%a\n" IR.pp_expression expr; + assert false + +let is_block = function Cblock _ -> true | _ -> false + +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 output value in + Format.fprintf output "\tstore ptr %s, ptr %%local_%d\n" ptr local + + | Cglobal_assign (global, expr) -> + 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 output value in + let ptr = compile_expression output ptr in + let reg = new_reg () in + 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 + + | Cblock statements -> List.iter (compile_statement output) statements + + | 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_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 + +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; compare; _ } = contract in + + 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"; + + 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"; + + 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 @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 = + 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/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/runtime.c b/deku-c/tunac/lib/runtime.c new file mode 100644 index 0000000000..a4c720c1fb --- /dev/null +++ b/deku-c/tunac/lib/runtime.c @@ -0,0 +1,93 @@ + +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; + } +} + +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 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(); + +void _start() { + main(); +} \ No newline at end of file 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..6b2112c617 --- /dev/null +++ b/deku-c/tunac/lib/runtime/src/lib.rs @@ -0,0 +1,264 @@ +#![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] +#[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 + } +} + +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> { + value: *mut u8, + next: &'a StackNode<'a> +} + +impl<'a> StackNode<'a> { + pub fn new(value: *mut u8, next: &'a StackNode<'a>) -> Box> { + Box::new(StackNode { value, next }) + } + + 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).as_ref() + } + + 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" { + 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(); +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_push(value: *mut u8) { + *__michelson_stack = *__michelson_stack.push(value) +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_drop_n(n: u32) { + *__michelson_stack = *__michelson_stack.drop(n); +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dup_n(n: u32) { + *__michelson_stack = *__michelson_stack.dup(n) +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dug_n(n: u32) { + *__michelson_stack = *__michelson_stack.push_nth(n, __michelson_stack.value()) +} + +#[no_mangle] +pub unsafe extern "C" fn michelson_dig_n(n: u32) { + let (value, stack) = __michelson_stack.pop_nth(n); + *__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(); +} \ No newline at end of file diff --git a/deku-c/tunac/lib/serialize.ml b/deku-c/tunac/lib/serialize.ml new file mode 100644 index 0000000000..7c6e4170b1 --- /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 (_, "Elt", args, _) + | Prim (_, "Pair", args, _) -> + Bytes.concat Bytes.empty (List.map compile_value args) + + | Prim (_, "Some", [ arg ], _) + | Prim (_, "Left", [ arg ], _) -> + Bytes.(cat (int32_to_bytes 1l) (compile_value arg)) + + | Prim (_, "Right", [ arg ], _) -> + Bytes.(cat (int32_to_bytes 0l) (compile_value arg)) + + | Prim (_, "None", _, _) + | Prim (_, "False", [], []) + | Prim (_, "Unit", [], _) -> + int32_to_bytes 0l + + | Prim (_, "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 (rev 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/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..27a80d8848 --- /dev/null +++ b/deku-c/tunac/lib/tunac.ml @@ -0,0 +1,75 @@ + +type node = (int, string) Tezos_micheline.Micheline.node + +type contract = node + +type config = + { debug : bool + ; shared_memory : bool + ; optimize : bool + ; memory : int * int } + +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.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 -> + 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 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 + + 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 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 + +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 new file mode 100644 index 0000000000..44419aeccf --- /dev/null +++ b/deku-c/tunac/lib/tunac.mli @@ -0,0 +1,18 @@ + +type node = (int, string) Tezos_micheline.Micheline.node + +type contract = node + +type config = + { debug : bool + ; shared_memory : bool + ; optimize : bool + ; memory : int * int } + +val parse : string -> contract + +val compile_contract : config:config -> contract -> (string, string) Lwt_result.t + +val compile_value : node -> bytes + +val link : string list -> string -> unit \ 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..11054c043c --- /dev/null +++ b/deku-c/tunac/lib/wasm_of_ir.ml @@ -0,0 +1,248 @@ +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; + 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 = + let compile_load cell typ ptr = + (* TODO: How know if its signed or not? *) + 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 + | Capply name, params -> Expression.Call.make wasm_mod name (List.map (compile_expression wasm_mod) params) Type.int32 + | Cload (cell, typ), [ ptr ] -> compile_load cell typ (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, typ), params -> compile_wasm_operation wasm_mod typ wasm_operation params + + | _ -> failwith "Invalid operation format, check operation arguments." + +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) + (compile_expression wasm_mod y) + in + let op1 op x = + Expression.Unary.make wasm_mod op (compile_expression wasm_mod x) + in + 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" + +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 + + | 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 add_function wasm_mod name fn = + let IR_of_michelson.{ body; locals } = fn 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 + +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.Unreachable.make wasm_mod + in + let body = aux lambdas in + ignore @@ + Function.add_function wasm_mod "exec" + Type.(create [| int32 |]) + Type.int32 + [||] + (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 "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)) + ; 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 wasm_mod contract = + let IR_of_michelson.{ main; lambdas; static_data; _ } = 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; + + compile_malloc wasm_mod; + ignore @@ Export.add_function_export wasm_mod "malloc" "malloc"; + + ignore @@ + 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 "__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 "__michelson_stack" "__michelson_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; + + 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; + + 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 + ; 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 + failwith "Generated module is invalid"; *) + + if optimize then + Module.optimize wasm_mod; + + 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..9620e70cda --- /dev/null +++ b/deku-c/tunac/tests/compile.ml @@ -0,0 +1,77 @@ +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 filename = + let output = open_out_bin filename in + let mod_, _ = Binaryen.Module.write wasm_mod None in + output_bytes output mod_; + close_out output + +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 + 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 + +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 memory = + Arg.(value & opt (pair int int) (1, 10) & info [ "memory" ]) + +let contract_cmd = + Cmd.v (Cmd.info "contract") + Term.( + const compile_contract + $ print + $ debug + $ optimize + $ shared_memory + $ output + $ memory) + +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/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..bf9dff3c5d 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 cmdliner)) -(test - (name compile_value) - (libraries tunac alcotest)) +(rule + (alias runtest) + (action (run node tests.js)) + (deps fa12.tz 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/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..f44ba263e4 --- /dev/null +++ b/deku-c/tunac/tests/tests.js @@ -0,0 +1,704 @@ +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 car(exports, list) { + return load(exports, list, 0) +} + +function cdr(exports, list) { + return load(exports, list, 1) +} + +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 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('./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) + }) +} + +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) { + return new Promise((resolve, reject) => { + const p = child_process.exec( + './compile.exe contract --debug --output mod.wasm', + (err) => { + if (err) return reject(err) + resolve() + } + ) + + p.stdin.end(code) + p.stderr.pipe(process.stderr) + p.stdout.pipe(process.stdout) + }) +} + +async function wasmModuleOfMichelson(code) { + await compileMichelsonCode(code) + console.log(process.cwd()) + const wasm = fs.readFileSync('./mod.wasm') + return WebAssembly.compile(wasm) +} + +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: { + writev(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] + } + + 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 + }, + 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] + }, + __stack_pointer: new WebAssembly.Global({ value: 'i32', mutable: true }) + } + } + 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 + } + + try { + instance.exports._start() + } 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 } +} + +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 } } { 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 } } { 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 } } { 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 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; + // 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 } } + `, { 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 { SWAP; DROP } { 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') + + 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') + + 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') + + // 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, '') +} + +// test_fa12() \ 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/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 diff --git a/flake.lock b/flake.lock index 06197f73af..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": { @@ -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" } }, @@ -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 8bc6cef2da..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"; }; diff --git a/nix/deku-c/tuna.nix b/nix/deku-c/tuna.nix index 88ccd9752b..0ab265738d 100644 --- a/nix/deku-c/tuna.nix +++ b/nix/deku-c/tuna.nix @@ -2,17 +2,14 @@ nix-filter, lib, buildDunePackage, - zarith, - ppx_deriving, - ppx_yojson_conv, - yojson, - wasm, - data-encoding, tezos-micheline, - core, - core_unix, - ppx_jane, alcotest, + binaryen, + proto-alpha-utils, + emscripten, + ppx_blob, + llvm, + pkgs }: buildDunePackage rec { pname = "deku"; @@ -29,19 +26,18 @@ buildDunePackage rec { }; propagatedBuildInputs = [ - zarith - ppx_deriving - ppx_yojson_conv - data-encoding - wasm tezos-micheline + binaryen + proto-alpha-utils + # llvm + pkgs.gdb + pkgs.cargo + pkgs.rustup + pkgs.wabt ]; buildInputs = [ - yojson - core - core_unix - ppx_jane + binaryen ]; checkInputs = [ 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 110c48b541..3da3954dd4 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -44,26 +44,69 @@ 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"; + + 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-stdlib = super.tezos-stdlib.overrideAttrs (_: { - postPatch = '' - substituteInPlace "src/lib_stdlib/hash_queue.mli" --replace \ - "val filter : t -> (K.t -> V.t -> bool) -> unit" \ - "" - ''; + + 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"; @@ -95,6 +138,118 @@ 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 + ]; + }; + + 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; + 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-014-PtKathma.client + ligo-memory-proto-alpha + ligo-simple-utils + 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