From a6a8008201c9e46f6b3ca52802753ab825ab46f7 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 12:12:46 +0100 Subject: [PATCH 01/41] Use wasm-interp in the test suite because of multi-value support. --- README.md | 5 ++--- default.nix | 2 ++ test/fail/ok/use-before-define.wasm-run.ok | 2 +- test/fail/ok/use-before-define2.wasm-run.ok | 2 +- test/run.sh | 2 +- test/run/ok/actors.wasm-run.ok | 2 +- test/run/ok/array-bounds.wasm-run.ok | 2 +- test/run/ok/assertFalse.wasm-run.ok | 2 +- test/run/ok/async-calls.wasm-run.ok | 2 +- test/run/ok/asyncreturn.wasm-run.ok | 2 +- test/run/ok/await.wasm-run.ok | 2 +- test/run/ok/bank-example.wasm-run.ok | 2 +- test/run/ok/block.wasm-run.ok | 2 +- test/run/ok/for.wasm-run.ok | 2 +- test/run/ok/is.wasm-run.ok | 2 +- test/run/ok/literals.wasm-run.ok | 2 +- test/run/ok/overflow.wasm-run.ok | 2 +- 17 files changed, 19 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index fa7cb49f895..128109e3fff 100644 --- a/README.md +++ b/README.md @@ -48,11 +48,10 @@ To build `asc.js`, the JavaScript library, use nix-build -A js ``` -If you want to install `wasm` and `dvm` binaries with nix (for example because -you maintain your Ocaml installation manually), run +If you want to install `wabt` and `dvm` binaries with Nix, run ``` -nix-env -i -f . -A wasm +nix-env -i -f . -A wabt nix-env -i -f . -A dvm ``` To update the `dev` checkout and install `dvm` in one go, run `./update-dvm.sh`. diff --git a/default.nix b/default.nix index e9307becb8b..8be0435b0c8 100644 --- a/default.nix +++ b/default.nix @@ -50,6 +50,7 @@ let commonBuildInputs = [ ocaml_vlq nixpkgs.ocamlPackages.zarith nixpkgs.ocamlPackages.yojson + nixpkgs.wabt ocaml_bisect_ppx ocaml_bisect_ppx-ocamlbuild ]; in @@ -197,6 +198,7 @@ rec { }); + wabt = nixpkgs.wabt; wasm = ocaml_wasm; dvm = real-dvm; } diff --git a/test/fail/ok/use-before-define.wasm-run.ok b/test/fail/ok/use-before-define.wasm-run.ok index 0832a4ae813..286b4068a22 100644 --- a/test/fail/ok/use-before-define.wasm-run.ok +++ b/test/fail/ok/use-before-define.wasm-run.ok @@ -1 +1 @@ -_out/use-before-define.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/fail/ok/use-before-define2.wasm-run.ok b/test/fail/ok/use-before-define2.wasm-run.ok index 042955b9259..286b4068a22 100644 --- a/test/fail/ok/use-before-define2.wasm-run.ok +++ b/test/fail/ok/use-before-define2.wasm-run.ok @@ -1 +1 @@ -_out/use-before-define2.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run.sh b/test/run.sh index 262ef677f20..3c788dc9f7d 100755 --- a/test/run.sh +++ b/test/run.sh @@ -19,7 +19,7 @@ ACCEPT=no DFINITY=no EXTRA_ASC_FLAGS= ASC=${ASC:-$(realpath $(dirname $0)/../src/asc)} -WASM=${WASM:-wasm} +WASM=${WASM:-wasm-interp} DVM_WRAPPER=$(realpath $(dirname $0)/dvm.sh) while getopts "ad" o; do diff --git a/test/run/ok/actors.wasm-run.ok b/test/run/ok/actors.wasm-run.ok index fd492e3b4f5..286b4068a22 100644 --- a/test/run/ok/actors.wasm-run.ok +++ b/test/run/ok/actors.wasm-run.ok @@ -1 +1 @@ -_out/actors.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/array-bounds.wasm-run.ok b/test/run/ok/array-bounds.wasm-run.ok index 988f0569732..286b4068a22 100644 --- a/test/run/ok/array-bounds.wasm-run.ok +++ b/test/run/ok/array-bounds.wasm-run.ok @@ -1 +1 @@ -_out/array-bounds.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/assertFalse.wasm-run.ok b/test/run/ok/assertFalse.wasm-run.ok index e03ec0ea09e..286b4068a22 100644 --- a/test/run/ok/assertFalse.wasm-run.ok +++ b/test/run/ok/assertFalse.wasm-run.ok @@ -1 +1 @@ -_out/assertFalse.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/async-calls.wasm-run.ok b/test/run/ok/async-calls.wasm-run.ok index 8fca2e68476..286b4068a22 100644 --- a/test/run/ok/async-calls.wasm-run.ok +++ b/test/run/ok/async-calls.wasm-run.ok @@ -1 +1 @@ -_out/async-calls.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/asyncreturn.wasm-run.ok b/test/run/ok/asyncreturn.wasm-run.ok index 0b80fcc95f3..286b4068a22 100644 --- a/test/run/ok/asyncreturn.wasm-run.ok +++ b/test/run/ok/asyncreturn.wasm-run.ok @@ -1 +1 @@ -_out/asyncreturn.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/await.wasm-run.ok b/test/run/ok/await.wasm-run.ok index da185acef49..286b4068a22 100644 --- a/test/run/ok/await.wasm-run.ok +++ b/test/run/ok/await.wasm-run.ok @@ -1 +1 @@ -_out/await.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/bank-example.wasm-run.ok b/test/run/ok/bank-example.wasm-run.ok index b84483e8c59..286b4068a22 100644 --- a/test/run/ok/bank-example.wasm-run.ok +++ b/test/run/ok/bank-example.wasm-run.ok @@ -1 +1 @@ -_out/bank-example.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/block.wasm-run.ok b/test/run/ok/block.wasm-run.ok index fcc79ff8676..286b4068a22 100644 --- a/test/run/ok/block.wasm-run.ok +++ b/test/run/ok/block.wasm-run.ok @@ -1 +1 @@ -_out/block.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/for.wasm-run.ok b/test/run/ok/for.wasm-run.ok index 808d296fa47..286b4068a22 100644 --- a/test/run/ok/for.wasm-run.ok +++ b/test/run/ok/for.wasm-run.ok @@ -1 +1 @@ -_out/for.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/is.wasm-run.ok b/test/run/ok/is.wasm-run.ok index 7faf7aff33f..286b4068a22 100644 --- a/test/run/ok/is.wasm-run.ok +++ b/test/run/ok/is.wasm-run.ok @@ -1 +1 @@ -_out/is.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/literals.wasm-run.ok b/test/run/ok/literals.wasm-run.ok index 11a148f71ae..286b4068a22 100644 --- a/test/run/ok/literals.wasm-run.ok +++ b/test/run/ok/literals.wasm-run.ok @@ -1 +1 @@ -_out/literals.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed diff --git a/test/run/ok/overflow.wasm-run.ok b/test/run/ok/overflow.wasm-run.ok index 880c476f3f5..286b4068a22 100644 --- a/test/run/ok/overflow.wasm-run.ok +++ b/test/run/ok/overflow.wasm-run.ok @@ -1 +1 @@ -_out/overflow.wasm:0x___: runtime trap: unreachable executed +error running start function: unreachable executed From 218fc2fea812f6cc2b62025b0049e7a42533c0ff Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 13:04:45 +0100 Subject: [PATCH 02/41] Add test case for nary calls and returns --- test/run/n-ary.as | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 test/run/n-ary.as diff --git a/test/run/n-ary.as b/test/run/n-ary.as new file mode 100644 index 00000000000..734d1abc0d6 --- /dev/null +++ b/test/run/n-ary.as @@ -0,0 +1,27 @@ +func foo_0_0 () : () = (); + +func foo_0_1 () : (Int) = 1; + +func foo_0_2 () : (Int, Int) = (1,2); + +func foo_0_2_block () : (Int, Int) = { let x = 1; let y = 2; (x,y) }; + +func foo_0_return_2 () : (Int, Int) {return (1,2); (3,4)}; + +func foo_1_1 (x : Int) : Int {x + 1}; + +func foo_1_2 (x : Int) : (Int, Int) {(x,x)}; + +func foo_2_2 (x : Int, y : Int) : (Int, Int) {(x,y)}; + +func foo_2_1 (x : Int, y : Int) : Int {x + y}; + +foo_0_0(); + +assert (foo_0_1() == 1); + +let (x,y) = foo_0_2(); +assert (x == 1); +assert (y == 2); + +assert (foo_2_1(foo_1_2(5)) == 10); From acef67fc40a633fadbc37cbbe49d8708c929f37c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 13:05:37 +0100 Subject: [PATCH 03/41] Bump dev to allow n-ary function calls --- Jenkinsfile | 2 +- default.nix | 3 +-- shell.nix | 3 +-- test/compare-wat.sh | 6 ++++-- test/run.sh | 2 +- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Jenkinsfile b/Jenkinsfile index 31249da17a5..b63dcb73345 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -5,7 +5,7 @@ pipeline { steps { sh 'git submodule update --init --recursive' sh 'git clone --recursive git@github.com:dfinity-lab/dev nix/dev' - sh 'git -C nix/dev checkout 3fd77aeeae1cb35e2bd86d9a49996cd1aedf57c5' + sh 'git -C nix/dev checkout 6085834e135482b47624d1c276755882e4c04987' sh 'git -C nix/dev submodule update --init --recursive' } } diff --git a/default.nix b/default.nix index 8be0435b0c8..a4776cfada5 100644 --- a/default.nix +++ b/default.nix @@ -1,7 +1,6 @@ { nixpkgs ? (import ./nix/nixpkgs.nix) {}, test-dvm ? true, dvm ? null, - v8 ? true, }: let stdenv = nixpkgs.stdenv; in @@ -36,7 +35,7 @@ let real-dvm = throw "\"test-dvm = true\" requires a checkout of dev in ./nix.\nSee Jenkinsfile for the reqiure revision. " else # Pass devel = true until the dev test suite runs on MacOS again - ((import ./nix/dev) { v8 = v8; devel = true; }).dvm + ((import ./nix/dev) { devel = true; }).dvm else null else dvm; in diff --git a/shell.nix b/shell.nix index 89f10f05244..52d4538db4c 100644 --- a/shell.nix +++ b/shell.nix @@ -1,10 +1,9 @@ { nixpkgs ? (import ./nix/nixpkgs.nix) {}, test-dvm ? true, - v8 ? true, }: let stdenv = nixpkgs.stdenv; in -let default = import ./default.nix { inherit nixpkgs test-dvm v8; }; in +let default = import ./default.nix { inherit nixpkgs test-dvm; }; in # # Since building asc, and testing it, are two different derivation in default.nix diff --git a/test/compare-wat.sh b/test/compare-wat.sh index 5ff5d7ff52f..42cd930362e 100755 --- a/test/compare-wat.sh +++ b/test/compare-wat.sh @@ -9,6 +9,8 @@ old="$(git rev-parse HEAD)" new="" +WASM2WAT="wasm2wat --fold-exprs --no-check --enable-multi-value" + while getopts "f:t:" o; do case "${o}" in f) @@ -64,13 +66,13 @@ do mkdir compare-out/$base.old old-asc/bin/asc --dfinity $file -o compare-out/$base.old/$base.wasm 2> compare-out/$base.old/$base.stderr test ! -e compare-out/$base.old/$base.wasm || - wasm2wat --fold-exprs --no-check --enable-mutable-globals compare-out/$base.old/$base.wasm >& compare-out/$base.old/$base.wat + $WASM2WAT compare-out/$base.old/$base.wasm >& compare-out/$base.old/$base.wat rm -rf compare-out/$base.new mkdir compare-out/$base.new new-asc/bin/asc --dfinity $file -o compare-out/$base.new/$base.wasm 2> compare-out/$base.new/$base.stderr test ! -e compare-out/$base.new/$base.wasm || - wasm2wat --fold-exprs --no-check --enable-mutable-globals compare-out/$base.new/$base.wasm >& compare-out/$base.new/$base.wat + $WASM2WAT compare-out/$base.new/$base.wasm >& compare-out/$base.new/$base.wat diff -r -N -u compare-out/$base.old compare-out/$base.new diff --git a/test/run.sh b/test/run.sh index 3c788dc9f7d..cf66bb74c7c 100755 --- a/test/run.sh +++ b/test/run.sh @@ -19,7 +19,7 @@ ACCEPT=no DFINITY=no EXTRA_ASC_FLAGS= ASC=${ASC:-$(realpath $(dirname $0)/../src/asc)} -WASM=${WASM:-wasm-interp} +WASM=${WASM:-wasm-interp --enable-multi-value} DVM_WRAPPER=$(realpath $(dirname $0)/dvm.sh) while getopts "ad" o; do From e55b821e2a452faa30a6b4fc994b478baf5f287a Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 13:06:38 +0100 Subject: [PATCH 04/41] Use n-ary return values --- src/compile.ml | 105 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 69 insertions(+), 36 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 5cd25f5c05a..955fbcaf877 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -102,6 +102,8 @@ module E = struct func_types : func_type list ref; (* Number of parameters in the current function, to calculate indices of locals *) n_param : int32; + (* Number of return values, to correctly compile calls to Return *) + n_res : int; (* Types of locals *) locals : value_type list ref; local_names : (int32 * string) list ref; @@ -141,6 +143,7 @@ module E = struct local_names = ref []; local_vars_env = NameEnv.empty; n_param = 0l; + n_res = 0; ld = NameEnv.empty; prelude; end_of_static_memory = ref dyn_mem; @@ -156,11 +159,12 @@ module E = struct | Deferred _ -> true (* Resetting the environment for a new function *) - let mk_fun_env env n_param = + let mk_fun_env env n_param n_res = { env with locals = ref [I32Type]; (* the first tmp local *) local_names = ref [ n_param , "tmp" ]; - n_param = n_param; + n_param; + n_res; (* We keep all local vars that are bound to known functions or globals *) local_vars_env = NameEnv.filter (fun _ -> is_non_local) env.local_vars_env; ld = NameEnv.empty; @@ -253,6 +257,8 @@ module E = struct | Some (Defined fi) -> () | Some (Pending mk_fun) -> () + let get_n_res (env : t) = env.n_res + let get_imports (env : t) = !(env.imports) let get_exports (env : t) = !(env.exports) let get_dfinity_types (env : t) = !(env.dfinity_types) @@ -376,7 +382,7 @@ let store_ptr : G.t = module Func = struct let of_body env params retty mk_body = - let env1 = E.mk_fun_env env (Int32.of_int (List.length params)) in + let env1 = E.mk_fun_env env (Int32.of_int (List.length params)) (List.length retty) in List.iteri (fun i n -> E.add_local_name env1 (Int32.of_int i) n) params; let ty = FuncType (List.map (fun _ -> I32Type) params, retty) in let body = G.to_instr_list (mk_body env1) in @@ -920,7 +926,9 @@ module Closure = struct (* Calculate the wasm type for a given calling convention. An extra first argument for the closure! *) let ty env cc = - E.func_type env (FuncType (I32Type :: Lib.List.make cc.Value.n_args I32Type,[I32Type])) + E.func_type env (FuncType ( + I32Type :: Lib.List.make cc.Value.n_args I32Type, + Lib.List.make cc.Value.n_res I32Type)) (* Expect on the stack the function closure @@ -1293,14 +1301,13 @@ module Array = struct load_ptr )); E.define_built_in env "array_set" - (fun () -> Func.of_body env ["clos"; "idx"; "val"] [I32Type] (fun env1 -> + (fun () -> Func.of_body env ["clos"; "idx"; "val"] [] (fun env1 -> get_array_object ^^ get_first_arg ^^ (* the index *) BoxedInt.unbox env1 ^^ idx env ^^ get_second_arg ^^ (* the value *) - store_ptr ^^ - compile_unit + store_ptr )); E.define_built_in env "array_len" (fun () -> Func.of_body env ["clos"] [I32Type] (fun env1 -> @@ -1464,21 +1471,28 @@ module Array = struct ) ^^ get_r - (* Takes an argument tuple, and puts the elements on the stack, - processing each with the mangling argument *) - let to_args env n_args mangle = - if n_args = 1 - then - mangle + (* Takes n elements of the stack and produces an argument tuple *) + let from_args env n = + if n = 0 then compile_unit + else if n = 1 then G.nop else - let (set_tup, get_tup) = new_local env "tup" in - set_tup ^^ - G.table n_args (fun i -> - get_tup ^^ - load_n (Int32.of_int i) ^^ - mangle + let name = Printf.sprintf "to_%i_tuple" n in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in + Func.share_code env name args [I32Type] (fun env -> + lit env (Lib.List.table n (fun i -> G.i_ (GetLocal (nr (Int32.of_int i))))) ) + (* Takes an argument tuple, and puts the elements on the stack, + processing each with the mangling argument *) + let to_args env n_args = + assert (n_args <> 1); + let (set_tup, get_tup) = new_local env "tup" in + set_tup ^^ + G.table n_args (fun i -> + get_tup ^^ + load_n (Int32.of_int i) + ) + end (* Array *) module Dfinity = struct @@ -2275,6 +2289,19 @@ module Serialization = struct G.i_ (Call (nr (Dfinity.elem_externalize_i env))) ) + let serialize_n env n = match n with + | 0 -> G.nop + | 1 -> serialize env + | _ -> + let name = Printf.sprintf "serialize_%i" n in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in + let retty = Lib.List.make n I32Type in + Func.share_code env name args retty (fun env -> + G.table n (fun i -> + G.i_ (GetLocal (nr (Int32.of_int i))) ^^ serialize env + ) + ) + let deserialize env = Func.share_code env "deserialize" ["ref"] [I32Type] (fun env -> let get_elembuf = G.i_ (GetLocal (nr 0l)) in @@ -2537,7 +2564,8 @@ module FuncDec = struct the function will find in the closure. *) let compile_local_function env cc restore_env mk_pat mk_body at = let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in - Func.of_body env (["clos"] @ args) [I32Type] (fun env1 -> + let retty = Lib.List.make cc.Value.n_res I32Type in + Func.of_body env (["clos"] @ args) retty (fun env1 -> let get_closure = G.i (GetLocal (E.unary_closure_local env1) @@ at) in let (env2, closure_code) = restore_env env1 get_closure in @@ -2561,6 +2589,7 @@ module FuncDec = struct *) let compile_message env cc restore_env mk_pat mk_body at = let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in + assert (cc.Value.n_res = 0); Func.of_body env (["clos"] @ args) [] (fun env1 -> (* Restore memory *) OrthogonalPersistence.restore_mem env1 ^^ @@ -2583,7 +2612,6 @@ module FuncDec = struct Serialization.deserialize env in destruct_args_code get ^^ mk_body env3 ^^ - G.i_ Drop ^^ (* Collect garbage *) G.i_ (Call (nr (E.built_in env3 "collect"))) ^^ @@ -2596,6 +2624,7 @@ module FuncDec = struct (* Like compile__message, but no closure *) let compile_static_message env cc mk_pat mk_body at : E.func_with_names = let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in + assert (cc.Value.n_res = 0); (* Messages take no closure, return nothing*) Func.of_body env args [] (fun env1 -> (* Set up memory *) @@ -2611,7 +2640,6 @@ module FuncDec = struct Serialization.deserialize env in destruct_args_code get ^^ mk_body env2 ^^ - G.i_ Drop ^^ (* Collect memory *) G.i_ (Call (nr (E.built_in env "collect"))) ^^ @@ -3006,7 +3034,9 @@ and compile_exp (env : E.t) exp = match exp.it with G.if_ [] (code2 ^^ G.i_ Drop ^^ G.i_ (Br (nr 1l))) G.nop ) ^^ compile_unit - | RetE e -> compile_exp env e ^^ G.i (Return @@ exp.at) + | RetE e -> + compile_exp_flat env (E.get_n_res env) e ^^ + G.i (Return @@ exp.at) | OptE e -> Opt.inject env (compile_exp env e) | TupE [] -> compile_unit @@ -3024,8 +3054,9 @@ and compile_exp (env : E.t) exp = match exp.it with | CallE (cc, e1, _, e2) when isDirectCall env e1 <> None -> let fi = Lib.Option.value (isDirectCall env e1) in compile_null ^^ (* A dummy closure *) - compile_exp_flat env cc.Value.n_args G.nop e2 ^^ (* the args *) - G.i (Call (nr fi) @@ exp.at) + compile_exp_flat env cc.Value.n_args e2 ^^ (* the args *) + G.i (Call (nr fi) @@ exp.at) ^^ + Array.from_args env cc.Value.n_res | CallE (cc, e1, _, e2) -> begin match cc.Value.sort with | Type.Call Type.Local | Type.Construct -> @@ -3033,14 +3064,16 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp env e1 ^^ set_clos ^^ get_clos ^^ - compile_exp_flat env cc.Value.n_args G.nop e2 ^^ + compile_exp_flat env cc.Value.n_args e2 ^^ get_clos ^^ - Closure.call_closure env cc + Closure.call_closure env cc ^^ + Array.from_args env cc.Value.n_res | Type.Call Type.Sharable -> let (set_funcref, get_funcref) = new_local env "funcref" in compile_exp env e1 ^^ set_funcref ^^ - compile_exp_flat env cc.Value.n_args (Serialization.serialize env) e2 ^^ + compile_exp_flat env cc.Value.n_args e2 ^^ + Serialization.serialize_n env cc.Value.n_args ^^ FuncDec.call_funcref env cc get_funcref ^^ compile_unit end @@ -3077,7 +3110,7 @@ and compile_exp (env : E.t) exp = match exp.it with Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ get_i ^^ Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ - Closure.call_closure env1 (Value.local_cc 0 0) ^^ + Closure.call_closure env1 (Value.local_cc 0 1) ^^ let (set_oi, get_oi) = new_local env "opt" in set_oi ^^ @@ -3112,18 +3145,18 @@ and compile_exp (env : E.t) exp = match exp.it with (* Compiles an expression of tuple type of the given length, and puts them on the stack individually. *) -and compile_exp_flat env n mangle e = +and compile_exp_flat env n e = if n = 0 then compile_exp env e ^^ G.i_ Drop else if n = 1 - then compile_exp env e ^^ mangle + then compile_exp env e else match e.it with | TupE es -> assert (List.length es = n); - G.concat_map (fun e -> compile_exp env e ^^ mangle) es + G.concat_map (fun e -> compile_exp env e) es | _ -> compile_exp env e ^^ - Array.to_args env n mangle + Array.to_args env n and isDirectCall env e = match e.it with | VarE var -> @@ -3301,7 +3334,7 @@ and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it w (* Get captured variables *) let captured = Freevars_ir.captured p e in let mk_pat env1 = compile_func_pat env1 cc p in - let mk_body env1 = compile_exp env1 e in + let mk_body env1 = compile_exp_flat env1 cc.Value.n_res e in FuncDec.dec pre_env how last name cc captured mk_pat mk_body dec.at and compile_decs env decs : G.t = snd (compile_decs_block env true decs) @@ -3329,7 +3362,7 @@ prelude. So this function compiles the prelude, just to find out the bound names *) and find_prelude_names env = (* Create a throw-away environment *) - let env1 = E.mk_fun_env (E.mk_global (E.mode env) (E.get_prelude env) 0l) 0l in + let env1 = E.mk_fun_env (E.mk_global (E.mode env) (E.get_prelude env) 0l) 0l 0 in let (env2, _) = compile_prelude env1 in E.in_scope_set env2 @@ -3380,7 +3413,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = ( pre_env1, fun env -> let mk_pat inner_env = compile_func_pat inner_env cc pat in - let mk_body inner_env = compile_exp inner_env exp in + let mk_body inner_env = compile_exp_flat inner_env cc.Value.n_res exp in let f = FuncDec.compile_static_message env cc mk_pat mk_body f.at in fill f; G.nop From 5a91b6fa8940d8564cbc809fb0496c7365b52fa4 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 14:18:23 +0100 Subject: [PATCH 05/41] N-ary expression refactor part 1 this avoids much useless tuple boxing and reboxing. --- src/compile.ml | 280 ++++++++++++++++++++++++------------------------- 1 file changed, 139 insertions(+), 141 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 955fbcaf877..0cea4b9d16d 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1482,17 +1482,6 @@ module Array = struct lit env (Lib.List.table n (fun i -> G.i_ (GetLocal (nr (Int32.of_int i))))) ) - (* Takes an argument tuple, and puts the elements on the stack, - processing each with the mangling argument *) - let to_args env n_args = - assert (n_args <> 1); - let (set_tup, get_tup) = new_local env "tup" in - set_tup ^^ - G.table n_args (fun i -> - get_tup ^^ - load_n (Int32.of_int i) - ) - end (* Array *) module Dfinity = struct @@ -2876,33 +2865,43 @@ let rec compile_lexp (env : E.t) exp = match exp.it with G.nop, Var.set_val env var.it | IdxE (e1,e2) -> - compile_exp env e1 ^^ (* offset to array *) - compile_exp env e2 ^^ (* idx *) + compile_exp env 1 e1 ^^ (* offset to array *) + compile_exp env 1 e2 ^^ (* idx *) BoxedInt.unbox env ^^ Array.idx env, store_ptr | DotE (e, n) -> - compile_exp env e ^^ + compile_exp env 1 e ^^ (* Only real objects have mutable fields, no need to branch on the tag *) Object.idx env n, store_ptr | _ -> todo "compile_lexp" (Arrange_ir.exp exp) (G.i_ Unreachable, G.nop) +and compile_unit_nary n = + match n with + | 0 -> G.nop + | 1 -> compile_unit + | _ -> assert false + (* compile_exp returns an *value*. -Currently, number (I32Type) are just repesented as such, but other -types may be point (e.g. for function, array, tuple, object). - -Local variables (which maybe mutable, or have delayed initialisation) -are also points, but points to such values, and need to be read first. *) -and compile_exp (env : E.t) exp = match exp.it with - | IdxE (e1, e2) -> - compile_exp env e1 ^^ (* offset to array *) - compile_exp env e2 ^^ (* idx *) + +The manner in which it is returned depends on the argument arity: + arity = 0: Expression is of type () and nothing is put on the stack + arity = 1: The generic case. Returns a single value (pointer or unboxed scalar) on the stack + arity > 1: Expression is of tuple types. Puts elements on the stack + +The function needs to be complete for (arity = 1), i.e. all expression forms +need to be compilable as such. Others are just offered as an optimization. + *) +and compile_exp (env : E.t) arity exp = match arity, exp.it with + | 1, IdxE (e1, e2) -> + compile_exp env 1 e1 ^^ (* offset to array *) + compile_exp env 1 e2 ^^ (* idx *) BoxedInt.unbox env ^^ Array.idx env ^^ load_ptr - | DotE (e, ({it = Syntax.Name n;_} as name)) -> - compile_exp env e ^^ + | 1, DotE (e, ({it = Syntax.Name n;_} as name)) -> + compile_exp env 1 e ^^ Tagged.branch env [I32Type] ( [ Tagged.Object, Object.load_idx env name ] @ (if E.mode env = DfinityMode @@ -2914,59 +2913,60 @@ and compile_exp (env : E.t) exp = match exp.it with ) (* We only allow prims of certain shapes, as they occur in the prelude *) (* Binary prims *) - | CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> + | 1, CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> begin - compile_exp env e1 ^^ - compile_exp env e2 ^^ + compile_exp env 1 e1 ^^ + compile_exp env 1 e2 ^^ match p with | "Array.init" -> Array.init env | "Array.tabulate" -> Array.tabulate env | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end (* Unary prims *) - | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> + | 1, CallE (_, ({ it = PrimE p; _} as pe), _, e) -> begin - compile_exp env e ^^ + compile_exp env 1 e ^^ match p with | "abs" -> Prim.prim_abs env | "printInt" -> Dfinity.prim_printInt env | "print" -> Dfinity.prim_print env | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end - | VarE var -> + | 1, VarE var -> Var.get_val env var.it - | AssignE (e1,e2) -> + | _, AssignE (e1,e2) -> let (prepare_code, store_code) = compile_lexp env e1 in prepare_code ^^ - compile_exp env e2 ^^ + compile_exp env 1 e2 ^^ store_code ^^ - compile_unit - | LitE l -> + compile_unit_nary arity + | 1, LitE l -> compile_lit env l - | AssertE e1 -> - compile_exp env e1 ^^ + | _, AssertE e1 -> + compile_exp env 1 e1 ^^ BoxedInt.unbox env ^^ - G.if_ [I32Type] compile_unit (G.i (Unreachable @@ exp.at)) - | UnE (op, e1) -> - compile_exp env e1 ^^ + G.if_ [] G.nop (G.i (Unreachable @@ exp.at)) ^^ + compile_unit_nary arity + | 1, UnE (op, e1) -> + compile_exp env 1 e1 ^^ compile_unop env op - | BinE (e1, op, e2) -> - compile_exp env e1 ^^ - compile_exp env e2 ^^ + | 1, BinE (e1, op, e2) -> + compile_exp env 1 e1 ^^ + compile_exp env 1 e2 ^^ compile_binop env op - | RelE (e1, op, e2) -> - compile_exp env e1 ^^ - compile_exp env e2 ^^ + | 1, RelE (e1, op, e2) -> + compile_exp env 1 e1 ^^ + compile_exp env 1 e2 ^^ compile_relop env op - | IfE (e1, e2, e3) -> - let code1 = compile_exp env e1 in - let code2 = compile_exp env e2 in - let code3 = compile_exp env e3 in + | _, IfE (e1, e2, e3) -> + let code1 = compile_exp env 1 e1 in + let code2 = compile_exp env arity e2 in + let code3 = compile_exp env arity e3 in code1 ^^ BoxedInt.unbox env ^^ - G.if_ [I32Type] code2 code3 - | IsE (e1, e2) -> - let code1 = compile_exp env e1 in - let code2 = compile_exp env e2 in + G.if_ (Lib.List.make arity I32Type) code2 code3 + | 1, IsE (e1, e2) -> + let code1 = compile_exp env 1 e1 in + let code2 = compile_exp env 1 e2 in let (set_i, get_i) = new_local env "is_lhs" in let (set_j, get_j) = new_local env "is_rhs" in code1 ^^ @@ -2997,88 +2997,89 @@ and compile_exp (env : E.t) exp = match exp.it with get_j ^^ Heap.load_field 0l ^^ (* get the function id *) compile_mul_const Heap.word_size ^^ - compile_add_const 1l ^^ + compile_add_const 1l ^^ G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ) ] - | BlockE decs -> + | 1, BlockE decs -> compile_decs env decs - | LabelE (name, _ty, e) -> - G.block_ [I32Type] (G.with_current_depth (fun depth -> + | _, LabelE (name, _ty, e) -> + G.block_ (Lib.List.make arity I32Type) (G.with_current_depth (fun depth -> let env1 = E.add_label env name depth in - compile_exp env1 e + compile_exp env1 arity e )) - | BreakE (name, _ty) -> + | _, BreakE (name, _ty) -> let d = E.get_label_depth env name in compile_unit ^^ G.branch_to_ d - | LoopE (e, None) -> + | _, LoopE (e, None) -> G.loop_ [] ( - let code = compile_exp env e in + let code = compile_exp env 0 e in code ^^ G.i_ (Br (nr 0l)) ) ^^ G.i_ Unreachable - | LoopE (e1, Some e2) -> - let code1 = compile_exp env e1 in - let code2 = compile_exp env e2 in + | _, LoopE (e1, Some e2) -> + let code1 = compile_exp env 0 e1 in + let code2 = compile_exp env 1 e2 in G.loop_ [] ( - code1 ^^ G.i_ Drop ^^ + code1 ^^ code2 ^^ BoxedInt.unbox env ^^ G.if_ [] (G.i_ (Br (nr 1l))) G.nop ) ^^ - compile_unit - | WhileE (e1, e2) -> - let code1 = compile_exp env e1 in - let code2 = compile_exp env e2 in + compile_unit_nary arity + | _, WhileE (e1, e2) -> + let code1 = compile_exp env 1 e1 in + let code2 = compile_exp env 0 e2 in G.loop_ [] ( code1 ^^ BoxedInt.unbox env ^^ - G.if_ [] (code2 ^^ G.i_ Drop ^^ G.i_ (Br (nr 1l))) G.nop + G.if_ [] (code2 ^^ G.i_ (Br (nr 1l))) G.nop ) ^^ - compile_unit - | RetE e -> - compile_exp_flat env (E.get_n_res env) e ^^ + compile_unit_nary arity + | _, RetE e -> + compile_exp env (E.get_n_res env) e ^^ G.i (Return @@ exp.at) - | OptE e -> - Opt.inject env (compile_exp env e) - | TupE [] -> compile_unit - | TupE es -> Array.lit env (List.map (compile_exp env) es) - | ProjE (e1,n) -> - compile_exp env e1 ^^ (* offset to tuple (an array) *) + | 1, OptE e -> + Opt.inject env (compile_exp env 1 e) + | 1, TupE [] -> compile_unit + | _, TupE [] -> assert (arity = 0); G.nop + | 1, TupE es -> Array.lit env (List.map (compile_exp env 1) es) + | _, TupE es -> assert (arity == List.length es); G.concat_map (compile_exp env 1) es + | 1, ProjE (e1,n) -> + compile_exp env 1 e1 ^^ (* offset to tuple (an array) *) Array.load_n (Int32.of_int n) - | ArrayE (m, es) -> Array.lit env (List.map (compile_exp env) es) - | ActorE (name, fs) -> + | 1, ArrayE (m, es) -> Array.lit env (List.map (compile_exp env 1) es) + | 1, ActorE (name, fs) -> let captured = Freevars_ir.exp exp in let prelude_names = find_prelude_names env in if Freevars_ir.M.is_empty (Freevars_ir.diff captured prelude_names) then actor_lit env name fs else todo "non-closed actor" (Arrange_ir.exp exp) G.i_ Unreachable - | CallE (cc, e1, _, e2) when isDirectCall env e1 <> None -> - let fi = Lib.Option.value (isDirectCall env e1) in - compile_null ^^ (* A dummy closure *) - compile_exp_flat env cc.Value.n_args e2 ^^ (* the args *) - G.i (Call (nr fi) @@ exp.at) ^^ - Array.from_args env cc.Value.n_res - | CallE (cc, e1, _, e2) -> - begin match cc.Value.sort with - | Type.Call Type.Local | Type.Construct -> + | _, CallE (cc, e1, _, e2) -> + begin match isDirectCall env e1, cc.Value.sort with + | Some fi, _ -> + compile_null ^^ (* A dummy closure *) + compile_exp env cc.Value.n_args e2 ^^ (* the args *) + G.i (Call (nr fi) @@ exp.at) + | None, (Type.Call Type.Local | Type.Construct) -> let (set_clos, get_clos) = new_local env "clos" in - compile_exp env e1 ^^ + compile_exp env 1 e1 ^^ set_clos ^^ get_clos ^^ - compile_exp_flat env cc.Value.n_args e2 ^^ + compile_exp env cc.Value.n_args e2 ^^ get_clos ^^ - Closure.call_closure env cc ^^ - Array.from_args env cc.Value.n_res - | Type.Call Type.Sharable -> + Closure.call_closure env cc + | None, Type.Call Type.Sharable -> let (set_funcref, get_funcref) = new_local env "funcref" in - compile_exp env e1 ^^ + compile_exp env 1 e1 ^^ set_funcref ^^ - compile_exp_flat env cc.Value.n_args e2 ^^ + compile_exp env cc.Value.n_args e2 ^^ Serialization.serialize_n env cc.Value.n_args ^^ - FuncDec.call_funcref env cc get_funcref ^^ - compile_unit - end - | SwitchE (e, cs) -> - let code1 = compile_exp env e in + FuncDec.call_funcref env cc get_funcref + end ^^ + if arity <> cc.Value.n_res + then (assert (arity = 1); Array.from_args env cc.Value.n_res) + else G.nop + | 1, SwitchE (e, cs) -> + let code1 = compile_exp env 1 e in let (set_i, get_i) = new_local env "switch_in" in let (set_j, get_j) = new_local env "switch_out" in @@ -3090,15 +3091,15 @@ and compile_exp (env : E.t) exp = match exp.it with let (env1, alloc_code, code) = compile_pat env AllocHow.M.empty pat in CannotFail alloc_code ^^^ orElse ( CannotFail get_i ^^^ code ^^^ - CannotFail (compile_exp env1 e) ^^^ CannotFail set_j) + CannotFail (compile_exp env1 1 e) ^^^ CannotFail set_j) (go env cs) in let code2 = go env cs in code1 ^^ set_i ^^ orTrap code2 ^^ get_j - | ForE (p, e1, e2) -> - let code1 = compile_exp env e1 in + | _, ForE (p, e1, e2) -> + let code1 = compile_exp env 1 e1 in let (env1, alloc_code, code2) = compile_mono_pat env AllocHow.M.empty p in - let code3 = compile_exp env1 e2 in + let code3 = compile_exp env1 0 e2 in let (set_i, get_i) = new_local env "iter" in (* Store the iterator *) @@ -3121,43 +3122,40 @@ and compile_exp (env : E.t) exp = match exp.it with G.if_ [] G.nop ( alloc_code ^^ get_oi ^^ Opt.project ^^ - code2 ^^ code3 ^^ G.i_ Drop ^^ G.i_ (Br (nr 1l)) + code2 ^^ code3 ^^ G.i_ (Br (nr 1l)) ) ) ^^ - compile_unit + compile_unit_nary arity (* Async-wait lowering support features *) - | DeclareE (name, _, e) -> - let (env1, i) = E.add_local_with_offset env name.it 1l in - Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i_ (SetLocal (nr i)) ^^ - compile_exp env1 e - | DefineE (name, _, e) -> - compile_exp env e ^^ - Var.set_val env name.it ^^ - compile_unit - | NewObjE ({ it = Type.Object _ (*sharing*); _}, fs) -> + | _, DeclareE (name, _, e) -> + let (env1, i) = E.add_local_with_offset env name.it 1l in + Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ + G.i_ (SetLocal (nr i)) ^^ + compile_exp env1 arity e + | _, DefineE (name, _, e) -> + compile_exp env 1 e ^^ + Var.set_val env name.it ^^ + compile_unit_nary arity + | 1, NewObjE ({ it = Type.Object _ (*sharing*); _}, fs) -> let fs' = List.map (fun (name, id) -> (name, fun env -> Var.get_val_ptr env id.it)) fs in Object.lit_raw env fs' + (* We wanted a specialized arity, but no case matches. So we have + to try with the general (which should always succeed) *) + | 0, _ -> + compile_exp env 1 exp ^^ + G.i_ Drop + | n, _ when n > 1 -> + compile_exp env 1 exp ^^ + let (set_tup, get_tup) = new_local env "tup" in + set_tup ^^ + G.table n (fun i -> + get_tup ^^ + Array.load_n (Int32.of_int i) + ) | _ -> todo "compile_exp" (Arrange_ir.exp exp) (G.i_ Unreachable) -(* Compiles an expression of tuple type of the given length, and - puts them on the stack individually. -*) -and compile_exp_flat env n e = - if n = 0 - then compile_exp env e ^^ G.i_ Drop - else if n = 1 - then compile_exp env e - else match e.it with - | TupE es -> - assert (List.length es = n); - G.concat_map (fun e -> compile_exp env e) es - | _ -> - compile_exp env e ^^ - Array.to_args env n - and isDirectCall env e = match e.it with | VarE var -> begin match E.lookup_var env var.it with @@ -3310,13 +3308,13 @@ and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it w ) | ExpD e -> (pre_env, G.nop, fun env -> - compile_exp env e ^^ + compile_exp env 1 e ^^ if last then G.nop else G.i_ Drop ) | LetD (p, e) -> let (pre_env1, alloc_code, fill_code) = compile_mono_pat pre_env how p in ( pre_env1, alloc_code, fun env -> - compile_exp env e ^^ + compile_exp env 1 e ^^ fill_code ^^ if last then compile_unit else G.nop ) @@ -3326,7 +3324,7 @@ and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it w let (pre_env1, alloc_code) = AllocHow.add_local pre_env how name.it in ( pre_env1, alloc_code, fun env -> - compile_exp env e ^^ + compile_exp env 1 e ^^ Var.set_val env name.it ^^ if last then compile_unit else G.nop ) @@ -3334,7 +3332,7 @@ and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it w (* Get captured variables *) let captured = Freevars_ir.captured p e in let mk_pat env1 = compile_func_pat env1 cc p in - let mk_body env1 = compile_exp_flat env1 cc.Value.n_res e in + let mk_body env1 = compile_exp env1 cc.Value.n_res e in FuncDec.dec pre_env how last name cc captured mk_pat mk_body dec.at and compile_decs env decs : G.t = snd (compile_decs_block env true decs) @@ -3386,7 +3384,7 @@ and compile_private_actor_field pre_env (f : Ir.exp_field) = Tagged.store Tagged.MutBox ^^ compile_unboxed_const ptr ^^ - compile_exp env f.it.exp ^^ + compile_exp env 1 f.it.exp ^^ Var.store ) @@ -3413,7 +3411,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = ( pre_env1, fun env -> let mk_pat inner_env = compile_func_pat inner_env cc pat in - let mk_body inner_env = compile_exp_flat inner_env cc.Value.n_res exp in + let mk_body inner_env = compile_exp inner_env cc.Value.n_res exp in let f = FuncDec.compile_static_message env cc mk_pat mk_body f.at in fill f; G.nop From c4361c1ebe4fb6bd83c064ecd58ff4f7635f2ba3 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 14:50:34 +0100 Subject: [PATCH 06/41] Compiler: Avoid tuple boxing even when returning from Blocks --- src/compile.ml | 88 +++++++++++++++++++++++++++----------------------- 1 file changed, 47 insertions(+), 41 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 0cea4b9d16d..f21f48ed4a8 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1649,8 +1649,7 @@ module Dfinity = struct then BoxedInt.unbox env ^^ G.i_ (Call (nr (test_show_i32_i env))) ^^ - G.i_ (Call (nr (test_print_i env))) ^^ - compile_unit + G.i_ (Call (nr (test_print_i env))) else G.i_ Unreachable @@ -1659,8 +1658,7 @@ module Dfinity = struct then compile_databuf_of_text env ^^ (* Call print *) - G.i_ (Call (nr (test_print_i env))) ^^ - compile_unit + G.i_ (Call (nr (test_print_i env))) else G.i_ Unreachable @@ -2638,7 +2636,7 @@ module FuncDec = struct ) (* Compile a closed function declaration (has no free variables) *) - let dec_closed pre_env cc last name mk_pat mk_body at = + let dec_closed pre_env cc name mk_pat mk_body at = let (fi, fill) = E.reserve_fun pre_env name.it in let d = { allocate = Var.static_fun_pointer fi; is_direct_call = Some fi } in let pre_env1 = E.add_local_deferred pre_env name.it d in @@ -2646,10 +2644,11 @@ module FuncDec = struct let restore_no_env env1 _ = (env1, G.nop) in let f = compile_local_function env cc restore_no_env mk_pat mk_body at in fill f; - if last then d.allocate env else G.nop) + G.nop + ) (* Compile a closure declaration (has free variables) *) - let dec_closure pre_env cc h last name captured mk_pat mk_body at = + let dec_closure pre_env cc h name captured mk_pat mk_body at = let is_local = cc.Value.sort <> Type.Call Type.Sharable in let (set_li, get_li) = new_local pre_env (name.it ^ "_clos") in @@ -2737,10 +2736,9 @@ module FuncDec = struct end ^^ (* Store it *) - Var.set_val env name.it ^^ - if last then Var.get_val env name.it else G.nop) + Var.set_val env name.it) - let dec pre_env how last name cc captured mk_pat mk_body at = + let dec pre_env how name cc captured mk_pat mk_body at = let is_local = cc.Value.sort <> Type.Call Type.Sharable in if not is_local && E.mode pre_env <> DfinityMode @@ -2750,9 +2748,9 @@ module FuncDec = struct else match AllocHow.M.find_opt name.it how with | None -> assert is_local; - dec_closed pre_env cc last name mk_pat mk_body at + dec_closed pre_env cc name mk_pat mk_body at | Some h -> - dec_closure pre_env cc (Some h) last name captured mk_pat mk_body at + dec_closure pre_env cc (Some h) name captured mk_pat mk_body at end (* FuncDec *) @@ -2913,8 +2911,9 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with ) (* We only allow prims of certain shapes, as they occur in the prelude *) (* Binary prims *) - | 1, CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> + | _, CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> begin + assert (arity = 1); compile_exp env 1 e1 ^^ compile_exp env 1 e2 ^^ match p with @@ -2923,13 +2922,19 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end (* Unary prims *) - | 1, CallE (_, ({ it = PrimE p; _} as pe), _, e) -> + | _, CallE (_, ({ it = PrimE p; _} as pe), _, e) -> begin compile_exp env 1 e ^^ match p with - | "abs" -> Prim.prim_abs env - | "printInt" -> Dfinity.prim_printInt env - | "print" -> Dfinity.prim_print env + | "abs" -> + assert (arity = 1); + Prim.prim_abs env + | "printInt" -> + Dfinity.prim_printInt env ^^ + compile_unit_nary arity + | "print" -> + Dfinity.prim_print env ^^ + compile_unit_nary arity | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end | 1, VarE var -> @@ -3001,8 +3006,8 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ) ] - | 1, BlockE decs -> - compile_decs env decs + | _, BlockE decs -> + compile_decs env arity decs | _, LabelE (name, _ty, e) -> G.block_ (Lib.List.make arity I32Type) (G.with_current_depth (fun depth -> let env1 = E.add_label env name depth in @@ -3142,13 +3147,15 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with fs in Object.lit_raw env fs' (* We wanted a specialized arity, but no case matches. So we have - to try with the general (which should always succeed) *) + to use the general form (which should always succeed), and unpack the + resulting tuple + *) | 0, _ -> compile_exp env 1 exp ^^ G.i_ Drop | n, _ when n > 1 -> - compile_exp env 1 exp ^^ let (set_tup, get_tup) = new_local env "tup" in + compile_exp env 1 exp ^^ set_tup ^^ G.table n (fun i -> get_tup ^^ @@ -3301,22 +3308,15 @@ and compile_func_pat env cc pat = orTrap (fill_pat env1 pat) in (env1, alloc_code, fill_code) -and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it with - | TypD _ -> - (pre_env, G.nop, fun _ -> - if last then compile_unit else G.nop - ) - | ExpD e -> - (pre_env, G.nop, fun env -> - compile_exp env 1 e ^^ - if last then G.nop else G.i_ Drop - ) +and compile_dec pre_env arity how dec : E.t * G.t * (E.t -> G.t) = match dec.it with + | TypD _ -> (pre_env, G.nop, fun _ -> compile_unit_nary arity) + | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env arity e) | LetD (p, e) -> let (pre_env1, alloc_code, fill_code) = compile_mono_pat pre_env how p in ( pre_env1, alloc_code, fun env -> compile_exp env 1 e ^^ fill_code ^^ - if last then compile_unit else G.nop + compile_unit_nary arity ) | VarD (name, e) -> assert (AllocHow.M.find_opt name.it how = Some AllocHow.LocalMut || @@ -3326,24 +3326,30 @@ and compile_dec last pre_env how dec : E.t * G.t * (E.t -> G.t) = match dec.it w ( pre_env1, alloc_code, fun env -> compile_exp env 1 e ^^ Var.set_val env name.it ^^ - if last then compile_unit else G.nop + compile_unit_nary arity ) | FuncD (cc, name, _, p, _rt, e) -> (* Get captured variables *) let captured = Freevars_ir.captured p e in let mk_pat env1 = compile_func_pat env1 cc p in let mk_body env1 = compile_exp env1 cc.Value.n_res e in - FuncDec.dec pre_env how last name cc captured mk_pat mk_body dec.at + let (pre_env1, alloc_code, mk_code) = FuncDec.dec pre_env how name cc captured mk_pat mk_body dec.at in + let lookup_code env = + match arity with + | 0 -> G.nop + | 1 -> Var.get_val env name.it + | _ -> assert false in + (pre_env1, alloc_code, fun env -> mk_code env ^^ lookup_code env) -and compile_decs env decs : G.t = snd (compile_decs_block env true decs) +and compile_decs env arity decs : G.t = snd (compile_decs_block env arity decs) -and compile_decs_block env keep_last decs : (E.t * G.t) = +and compile_decs_block env arity decs : (E.t * G.t) = let how = AllocHow.decs env decs in let rec go pre_env decs = match decs with - | [] -> (pre_env, G.nop, fun _ -> if keep_last then compile_unit else G.nop) (* empty declaration list? *) - | [dec] -> compile_dec keep_last pre_env how dec + | [] -> (pre_env, G.nop, fun _ -> compile_unit_nary arity) + | [dec] -> compile_dec pre_env arity how dec | (dec::decs) -> - let (pre_env1, alloc_code1, mk_code1) = compile_dec false pre_env how dec in + let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env 0 how dec in let (pre_env2, alloc_code2, mk_code2) = go pre_env1 decs in (pre_env2, alloc_code1 ^^ alloc_code2, fun env -> mk_code1 env ^^ mk_code2 env) in let (env1, alloc_code, mk_code) = go env decs in @@ -3351,7 +3357,7 @@ and compile_decs_block env keep_last decs : (E.t * G.t) = and compile_prelude env = (* Allocate the primitive functions *) - let (env1, code) = compile_decs_block env false (E.get_prelude env).it in + let (env1, code) = compile_decs_block env 0 (E.get_prelude env).it in (env1, code) (* Is this a hack? When determining whether an actor is closed, @@ -3370,7 +3376,7 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = let rec go env = function | [] -> G.nop | (prog::progs) -> - let (env1, code1) = compile_decs_block env false prog.it in + let (env1, code1) = compile_decs_block env 0 prog.it in let code2 = go env1 progs in code1 ^^ code2 in go env1 progs From 02dc038b77352d779d5a985ad988f7ddebc08ff6 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 15:18:03 +0100 Subject: [PATCH 07/41] Optimize `let (x,y) = foo()` to avoid tuple --- src/compile.ml | 36 ++++++++++++++++++++++++++++++------ test/compare-wat.sh | 4 ++-- 2 files changed, 32 insertions(+), 8 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index f21f48ed4a8..27265c7fff8 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3080,9 +3080,12 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with Serialization.serialize_n env cc.Value.n_args ^^ FuncDec.call_funcref env cc get_funcref end ^^ - if arity <> cc.Value.n_res - then (assert (arity = 1); Array.from_args env cc.Value.n_res) - else G.nop + begin match arity with + | _ when arity = cc.Value.n_res -> G.nop + | 0 -> G.table cc.Value.n_res (fun _ -> G.i_ Drop) + | 1 -> Array.from_args env cc.Value.n_res + | _ -> assert false + end | 1, SwitchE (e, cs) -> let code1 = compile_exp env 1 e in let (set_i, get_i) = new_local env "switch_in" in @@ -3275,11 +3278,32 @@ and compile_pat env how pat : E.t * G.t * patternCode = let fill_code = fill_pat env1 pat in (env1, alloc_code, fill_code) -(* Used for mono patterns (let, function arguments) *) +(* Used for mono patterns (ForE) *) and compile_mono_pat env how pat = let (env1, alloc_code, code) = compile_pat env how pat in (env1, alloc_code, orTrap code) +(* Used for let patterns: If the patterns is an n-ary tuple pattern, + we want to compile the expression accordingly, to avoid the reboxing. +*) +and compile_n_ary_pat env how pat = + let (env1, alloc_code) = alloc_pat env how pat in + let arity, fill_code = + match pat.it with + (* Nothing to match: Do not even put something on the stack *) + | WildP -> 0, G.nop + (* The good case: We have a tuple pattern *) + | TupP ps when List.length ps <> 1 -> + let arity = List.length ps in + (* We have to fill the pattern in reverse order, to take things off the + stack. This is only ok as long as patterns have no side effects. + *) + arity, G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) + (* The general case: Create a single value, match that. *) + | _ -> + 1, orTrap (fill_pat env1 pat) + in (env1, alloc_code, arity, fill_code) + (* Used for function patterns The complication is that functions are n-ary, and we get the elements separately. @@ -3312,9 +3336,9 @@ and compile_dec pre_env arity how dec : E.t * G.t * (E.t -> G.t) = match dec.it | TypD _ -> (pre_env, G.nop, fun _ -> compile_unit_nary arity) | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env arity e) | LetD (p, e) -> - let (pre_env1, alloc_code, fill_code) = compile_mono_pat pre_env how p in + let (pre_env1, alloc_code, pat_arity, fill_code) = compile_n_ary_pat pre_env how p in ( pre_env1, alloc_code, fun env -> - compile_exp env 1 e ^^ + compile_exp env pat_arity e ^^ fill_code ^^ compile_unit_nary arity ) diff --git a/test/compare-wat.sh b/test/compare-wat.sh index 42cd930362e..b6f7dcd56bc 100755 --- a/test/compare-wat.sh +++ b/test/compare-wat.sh @@ -9,7 +9,7 @@ old="$(git rev-parse HEAD)" new="" -WASM2WAT="wasm2wat --fold-exprs --no-check --enable-multi-value" +WASM2WAT="wasm2wat --no-check --enable-multi-value" while getopts "f:t:" o; do case "${o}" in @@ -74,7 +74,7 @@ do test ! -e compare-out/$base.new/$base.wasm || $WASM2WAT compare-out/$base.new/$base.wasm >& compare-out/$base.new/$base.wat - diff -r -N -u compare-out/$base.old compare-out/$base.new + diff -r -N -u10 compare-out/$base.old compare-out/$base.new rm -rf compare-out/$base.old rm -rf compare-out/$base.new From 329ea1aba98d88b7b76c590f3665692f77c05d9a Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 15 Dec 2018 15:38:25 +0100 Subject: [PATCH 08/41] Nix tweaks --- default.nix | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index a4776cfada5..62ee74f9690 100644 --- a/default.nix +++ b/default.nix @@ -49,7 +49,6 @@ let commonBuildInputs = [ ocaml_vlq nixpkgs.ocamlPackages.zarith nixpkgs.ocamlPackages.yojson - nixpkgs.wabt ocaml_bisect_ppx ocaml_bisect_ppx-ocamlbuild ]; in @@ -101,7 +100,7 @@ rec { buildInputs = [ native - ocaml_wasm + nixpkgs.wabt nixpkgs.bash nixpkgs.perl ] ++ @@ -150,7 +149,7 @@ rec { buildInputs = [ native-coverage - ocaml_wasm + nixpkgs.wabt nixpkgs.bash nixpkgs.perl ocaml_bisect_ppx From 4e9b8ba3c29f26223986cfdfff23d344267f05db Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 17 Dec 2018 09:42:27 +0100 Subject: [PATCH 09/41] Further refactoring of stack representations in the compiler with a bidirectional data flow, somehow, and a dedicate data type. --- src/compile.ml | 665 +++++++++++++----------- src/instrList.ml | 5 + test/run/ok/bank-example.wasm.stderr.ok | 200 +++---- test/run/ok/bit-ops.wasm.stderr.ok | 100 ++-- test/run/ok/literals.wasm.stderr.ok | 6 +- test/run/ok/overflow.wasm.stderr.ok | 26 +- 6 files changed, 542 insertions(+), 460 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 27265c7fff8..71e0e8c228e 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1472,9 +1472,8 @@ module Array = struct get_r (* Takes n elements of the stack and produces an argument tuple *) - let from_args env n = + let from_stack env n = if n = 0 then compile_unit - else if n = 1 then G.nop else let name = Printf.sprintf "to_%i_tuple" n in let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in @@ -1482,6 +1481,16 @@ module Array = struct lit env (Lib.List.table n (fun i -> G.i_ (GetLocal (nr (Int32.of_int i))))) ) + (* Takes an argument tuple and puts the elements on the stack: *) + let to_stack env n = + if n = 0 then G.i_ Drop else + let name = Printf.sprintf "from_%i_tuple" n in + let retty = Lib.List.make n I32Type in + Func.share_code env name ["tup"] retty (fun env -> + let get_tup = G.i_ (GetLocal (nr 0l)) in + G.table n (fun i -> get_tup ^^ load_n (Int32.of_int i)) + ) + end (* Array *) module Dfinity = struct @@ -2754,6 +2763,68 @@ module FuncDec = struct end (* FuncDec *) +module StackRep = struct + + (* Value representation on the stack: + + Compiling an expression means putting its value on the stack. But + there are various ways of putting a value onto the stack -- unboxed, + tupled etc. + *) + type t = Vanilla | UnboxedTuple of int | Unreachable + + let unit = UnboxedTuple 0 + + (* + Most expression have a “preferred”, most optimal, form. Hence, + compile_exp put them on the stack in that form, and also returns + the form it chose. + + But the users of compile_exp usually want a specific form as well. + So they use compile_exp_as, indicating the form they expect. compile_exp_as + then does the necessary coercions. + + So far, the stack representations is merely an integer, the arity: + arity = 0: Expression is of type () and nothing is put on the stack + arity = 1: The generic case. Returns a single value (pointer or unboxed + scalar) on the stack + arity > 1: Expression is of tuple types. Puts elements on the stack + To add: Unreachable, Unboxed Int + *) + + let of_arity n = + if n = 1 then Vanilla else UnboxedTuple n + + let to_wasm_type = function + | Vanilla -> [I32Type] + | UnboxedTuple n -> Lib.List.make n I32Type + | Unreachable -> [] + + let to_string = function + | Vanilla -> "Vanilla" + | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n + | Unreachable -> "Unreachable" + + let drop env (sr_in : t) = + match sr_in with + | Vanilla -> G.i_ Drop + | UnboxedTuple n -> G.table n (fun _ -> G.i_ Drop) + | Unreachable -> G.nop + + let adjust env (sr_in : t) sr_out = + if sr_in = sr_out + then G.nop + else match sr_in, sr_out with + | Unreachable, _ -> G.nop + | UnboxedTuple n, Vanilla -> Array.from_stack env n + | Vanilla, UnboxedTuple n -> Array.to_stack env n + | _, _ -> + Printf.eprintf "Unknown stack_rep conversion %s -> %s\n" + (to_string sr_in) (to_string sr_out); + G.nop +end + + module PatCode = struct (* Pattern failure code on demand. @@ -2863,231 +2934,235 @@ let rec compile_lexp (env : E.t) exp = match exp.it with G.nop, Var.set_val env var.it | IdxE (e1,e2) -> - compile_exp env 1 e1 ^^ (* offset to array *) - compile_exp env 1 e2 ^^ (* idx *) + compile_exp_vanilla env e1 ^^ (* offset to array *) + compile_exp_vanilla env e2 ^^ (* idx *) BoxedInt.unbox env ^^ Array.idx env, store_ptr | DotE (e, n) -> - compile_exp env 1 e ^^ + compile_exp_vanilla env e ^^ (* Only real objects have mutable fields, no need to branch on the tag *) Object.idx env n, store_ptr | _ -> todo "compile_lexp" (Arrange_ir.exp exp) (G.i_ Unreachable, G.nop) -and compile_unit_nary n = - match n with - | 0 -> G.nop - | 1 -> compile_unit - | _ -> assert false - -(* compile_exp returns an *value*. - -The manner in which it is returned depends on the argument arity: - arity = 0: Expression is of type () and nothing is put on the stack - arity = 1: The generic case. Returns a single value (pointer or unboxed scalar) on the stack - arity > 1: Expression is of tuple types. Puts elements on the stack - -The function needs to be complete for (arity = 1), i.e. all expression forms -need to be compilable as such. Others are just offered as an optimization. - *) -and compile_exp (env : E.t) arity exp = match arity, exp.it with - | 1, IdxE (e1, e2) -> - compile_exp env 1 e1 ^^ (* offset to array *) - compile_exp env 1 e2 ^^ (* idx *) - BoxedInt.unbox env ^^ - Array.idx env ^^ - load_ptr - | 1, DotE (e, ({it = Syntax.Name n;_} as name)) -> - compile_exp env 1 e ^^ - Tagged.branch env [I32Type] - ( [ Tagged.Object, Object.load_idx env name ] @ - (if E.mode env = DfinityMode - then [ Tagged.Reference, actor_fake_object_idx env {name with it = n} ] - else []) @ - match Array.fake_object_idx env n with - | None -> [] - | Some code -> [ Tagged.Array, code ] - ) +and compile_exp (env : E.t) exp = match exp.it with + | IdxE (e1, e2) -> + StackRep.Vanilla, + compile_exp_vanilla env e1 ^^ (* offset to array *) + compile_exp_vanilla env e2 ^^ (* idx *) + BoxedInt.unbox env ^^ + Array.idx env ^^ + load_ptr + | DotE (e, ({it = Syntax.Name n;_} as name)) -> + StackRep.Vanilla, + compile_exp_vanilla env e ^^ + Tagged.branch env [I32Type] ( + [ Tagged.Object, Object.load_idx env name ] @ + (if E.mode env = DfinityMode + then [ Tagged.Reference, actor_fake_object_idx env {name with it = n} ] + else []) @ + match Array.fake_object_idx env n with + | None -> [] + | Some code -> [ Tagged.Array, code ] + ) (* We only allow prims of certain shapes, as they occur in the prelude *) (* Binary prims *) - | _, CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> + | CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> + StackRep.Vanilla, begin - assert (arity = 1); - compile_exp env 1 e1 ^^ - compile_exp env 1 e2 ^^ + compile_exp_vanilla env e1 ^^ + compile_exp_vanilla env e2 ^^ match p with | "Array.init" -> Array.init env | "Array.tabulate" -> Array.tabulate env | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end (* Unary prims *) - | _, CallE (_, ({ it = PrimE p; _} as pe), _, e) -> + | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> begin - compile_exp env 1 e ^^ - match p with - | "abs" -> - assert (arity = 1); - Prim.prim_abs env - | "printInt" -> - Dfinity.prim_printInt env ^^ - compile_unit_nary arity - | "print" -> - Dfinity.prim_print env ^^ - compile_unit_nary arity - | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) + match p with + | "abs" -> + StackRep.Vanilla, + compile_exp_vanilla env e ^^ + Prim.prim_abs env + | "printInt" -> + StackRep.unit, + compile_exp_vanilla env e ^^ + Dfinity.prim_printInt env + | "print" -> + StackRep.unit, + compile_exp_vanilla env e ^^ + Dfinity.prim_print env + | _ -> + StackRep.Unreachable, + todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) end - | 1, VarE var -> - Var.get_val env var.it - | _, AssignE (e1,e2) -> - let (prepare_code, store_code) = compile_lexp env e1 in - prepare_code ^^ - compile_exp env 1 e2 ^^ - store_code ^^ - compile_unit_nary arity - | 1, LitE l -> - compile_lit env l - | _, AssertE e1 -> - compile_exp env 1 e1 ^^ - BoxedInt.unbox env ^^ - G.if_ [] G.nop (G.i (Unreachable @@ exp.at)) ^^ - compile_unit_nary arity - | 1, UnE (op, e1) -> - compile_exp env 1 e1 ^^ - compile_unop env op - | 1, BinE (e1, op, e2) -> - compile_exp env 1 e1 ^^ - compile_exp env 1 e2 ^^ - compile_binop env op - | 1, RelE (e1, op, e2) -> - compile_exp env 1 e1 ^^ - compile_exp env 1 e2 ^^ - compile_relop env op - | _, IfE (e1, e2, e3) -> - let code1 = compile_exp env 1 e1 in - let code2 = compile_exp env arity e2 in - let code3 = compile_exp env arity e3 in - code1 ^^ BoxedInt.unbox env ^^ - G.if_ (Lib.List.make arity I32Type) code2 code3 - | 1, IsE (e1, e2) -> - let code1 = compile_exp env 1 e1 in - let code2 = compile_exp env 1 e2 in - let (set_i, get_i) = new_local env "is_lhs" in - let (set_j, get_j) = new_local env "is_rhs" in - code1 ^^ - set_i ^^ - code2 ^^ - set_j ^^ - - get_i ^^ - Tagged.branch env [I32Type] - [ Tagged.Array, - G.i_ Drop ^^ BoxedInt.lit_false env - ; Tagged.Reference, - (* TODO: Implement IsE for actor references? *) - G.i_ Drop ^^ BoxedInt.lit_false env - ; Tagged.Object, - (* There are two cases: Either the class is a pointer to - the object on the RHS, or it is -- mangled -- the - function id stored therein *) - Heap.load_field Object.class_position ^^ - (* Equal? *) - get_j ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ - G.if_ [I32Type] - (BoxedInt.lit_true env) - (* Static function id? *) - ( get_i ^^ - Heap.load_field Object.class_position ^^ - get_j ^^ - Heap.load_field 0l ^^ (* get the function id *) - compile_mul_const Heap.word_size ^^ - compile_add_const 1l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) - ) - ] - | _, BlockE decs -> - compile_decs env arity decs - | _, LabelE (name, _ty, e) -> - G.block_ (Lib.List.make arity I32Type) (G.with_current_depth (fun depth -> - let env1 = E.add_label env name depth in - compile_exp env1 arity e - )) - | _, BreakE (name, _ty) -> - let d = E.get_label_depth env name in - compile_unit ^^ G.branch_to_ d - | _, LoopE (e, None) -> - G.loop_ [] ( - let code = compile_exp env 0 e in - code ^^ G.i_ (Br (nr 0l)) - ) ^^ - G.i_ Unreachable - | _, LoopE (e1, Some e2) -> - let code1 = compile_exp env 0 e1 in - let code2 = compile_exp env 1 e2 in - G.loop_ [] ( - code1 ^^ - code2 ^^ BoxedInt.unbox env ^^ - G.if_ [] (G.i_ (Br (nr 1l))) G.nop - ) ^^ - compile_unit_nary arity - | _, WhileE (e1, e2) -> - let code1 = compile_exp env 1 e1 in - let code2 = compile_exp env 0 e2 in - G.loop_ [] ( - code1 ^^ BoxedInt.unbox env ^^ - G.if_ [] (code2 ^^ G.i_ (Br (nr 1l))) G.nop - ) ^^ - compile_unit_nary arity - | _, RetE e -> - compile_exp env (E.get_n_res env) e ^^ + | VarE var -> + StackRep.Vanilla, + Var.get_val env var.it + | AssignE (e1,e2) -> + StackRep.unit, + let (prepare_code, store_code) = compile_lexp env e1 in + prepare_code ^^ + compile_exp_vanilla env e2 ^^ + store_code + | LitE l -> + StackRep.Vanilla, + compile_lit env l + | AssertE e1 -> + StackRep.unit, + compile_exp_vanilla env e1 ^^ + BoxedInt.unbox env ^^ + G.if_ [] G.nop (G.i (Unreachable @@ exp.at)) + | UnE (op, e1) -> + StackRep.Vanilla, + compile_exp_vanilla env e1 ^^ + compile_unop env op + | BinE (e1, op, e2) -> + StackRep.Vanilla, + compile_exp_vanilla env e1 ^^ + compile_exp_vanilla env e2 ^^ + compile_binop env op + | RelE (e1, op, e2) -> + StackRep.Vanilla, + compile_exp_vanilla env e1 ^^ + compile_exp_vanilla env e2 ^^ + compile_relop env op + | IfE (e1, e2, e3) -> + (* Todo: Somehow “join” the stack representations *) + StackRep.Vanilla, + let code1 = compile_exp_vanilla env e1 in + let code2 = compile_exp_vanilla env e2 in + let code3 = compile_exp_vanilla env e3 in + code1 ^^ BoxedInt.unbox env ^^ + G.if_ (Lib.List.make 1 I32Type) code2 code3 + | IsE (e1, e2) -> + StackRep.Vanilla, + let code1 = compile_exp_vanilla env e1 in + let code2 = compile_exp_vanilla env e2 in + let (set_i, get_i) = new_local env "is_lhs" in + let (set_j, get_j) = new_local env "is_rhs" in + code1 ^^ + set_i ^^ + code2 ^^ + set_j ^^ + + get_i ^^ + Tagged.branch env [I32Type] + [ Tagged.Array, + G.i_ Drop ^^ BoxedInt.lit_false env + ; Tagged.Reference, + (* TODO: Implement IsE for actor references? *) + G.i_ Drop ^^ BoxedInt.lit_false env + ; Tagged.Object, + (* There are two cases: Either the class is a pointer to + the object on the RHS, or it is -- mangled -- the + function id stored therein *) + Heap.load_field Object.class_position ^^ + (* Equal? *) + get_j ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.if_ [I32Type] + (BoxedInt.lit_true env) + (* Static function id? *) + ( get_i ^^ + Heap.load_field Object.class_position ^^ + get_j ^^ + Heap.load_field 0l ^^ (* get the function id *) + compile_mul_const Heap.word_size ^^ + compile_add_const 1l ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) + ) + ] + | BlockE decs -> + compile_decs env decs + | LabelE (name, _ty, e) -> + let sr, code = G.with_current_depth' (fun depth -> + let env1 = E.add_label env name depth in + compile_exp env1 e + ) in + sr, + G.block_ (StackRep.to_wasm_type sr) code + | BreakE (name, _ty) -> + let d = E.get_label_depth env name in + StackRep.Unreachable, + (* TODO: Is this properly typed? Write more tests! *) + compile_unit ^^ + G.branch_to_ d + | LoopE (e, None) -> + StackRep.Unreachable, + G.loop_ [] (compile_exp_unit env e ^^ G.i_ (Br (nr 0l)) + ) + ^^ + G.i_ Unreachable + | LoopE (e1, Some e2) -> + StackRep.unit, + G.loop_ [] ( + compile_exp_unit env e1 ^^ + compile_exp_vanilla env e2 ^^ + BoxedInt.unbox env ^^ + G.if_ [] (G.i_ (Br (nr 1l))) G.nop + ) + | WhileE (e1, e2) -> + StackRep.unit, + G.loop_ [] ( + compile_exp_vanilla env e1 ^^ + BoxedInt.unbox env ^^ + G.if_ [] ( + compile_exp_unit env e2 ^^ + G.i_ (Br (nr 1l)) + ) G.nop + ) + | RetE e -> + StackRep.Unreachable, + compile_exp_as env (StackRep.of_arity (E.get_n_res env)) e ^^ G.i (Return @@ exp.at) - | 1, OptE e -> - Opt.inject env (compile_exp env 1 e) - | 1, TupE [] -> compile_unit - | _, TupE [] -> assert (arity = 0); G.nop - | 1, TupE es -> Array.lit env (List.map (compile_exp env 1) es) - | _, TupE es -> assert (arity == List.length es); G.concat_map (compile_exp env 1) es - | 1, ProjE (e1,n) -> - compile_exp env 1 e1 ^^ (* offset to tuple (an array) *) - Array.load_n (Int32.of_int n) - | 1, ArrayE (m, es) -> Array.lit env (List.map (compile_exp env 1) es) - | 1, ActorE (name, fs) -> + | OptE e -> + StackRep.Vanilla, + Opt.inject env (compile_exp_vanilla env e) + | TupE es -> + StackRep.UnboxedTuple (List.length es), + G.concat_map (compile_exp_vanilla env) es + | ProjE (e1,n) -> + StackRep.Vanilla, + compile_exp_vanilla env e1 ^^ (* offset to tuple (an array) *) + Array.load_n (Int32.of_int n) + | ArrayE (m, es) -> + StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) + | ActorE (name, fs) -> + StackRep.Vanilla, let captured = Freevars_ir.exp exp in let prelude_names = find_prelude_names env in if Freevars_ir.M.is_empty (Freevars_ir.diff captured prelude_names) then actor_lit env name fs else todo "non-closed actor" (Arrange_ir.exp exp) G.i_ Unreachable - | _, CallE (cc, e1, _, e2) -> - begin match isDirectCall env e1, cc.Value.sort with - | Some fi, _ -> - compile_null ^^ (* A dummy closure *) - compile_exp env cc.Value.n_args e2 ^^ (* the args *) - G.i (Call (nr fi) @@ exp.at) - | None, (Type.Call Type.Local | Type.Construct) -> - let (set_clos, get_clos) = new_local env "clos" in - compile_exp env 1 e1 ^^ - set_clos ^^ - get_clos ^^ - compile_exp env cc.Value.n_args e2 ^^ - get_clos ^^ - Closure.call_closure env cc - | None, Type.Call Type.Sharable -> - let (set_funcref, get_funcref) = new_local env "funcref" in - compile_exp env 1 e1 ^^ - set_funcref ^^ - compile_exp env cc.Value.n_args e2 ^^ - Serialization.serialize_n env cc.Value.n_args ^^ - FuncDec.call_funcref env cc get_funcref - end ^^ - begin match arity with - | _ when arity = cc.Value.n_res -> G.nop - | 0 -> G.table cc.Value.n_res (fun _ -> G.i_ Drop) - | 1 -> Array.from_args env cc.Value.n_res - | _ -> assert false - end - | 1, SwitchE (e, cs) -> - let code1 = compile_exp env 1 e in + | CallE (cc, e1, _, e2) -> + StackRep.of_arity (cc.Value.n_res), + begin match isDirectCall env e1, cc.Value.sort with + | Some fi, _ -> + compile_null ^^ (* A dummy closure *) + compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ (* the args *) + G.i (Call (nr fi) @@ exp.at) + | None, (Type.Call Type.Local | Type.Construct) -> + let (set_clos, get_clos) = new_local env "clos" in + compile_exp_vanilla env e1 ^^ + set_clos ^^ + get_clos ^^ + compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ + get_clos ^^ + Closure.call_closure env cc + | None, Type.Call Type.Sharable -> + let (set_funcref, get_funcref) = new_local env "funcref" in + compile_exp_vanilla env e1 ^^ + set_funcref ^^ + compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ + Serialization.serialize_n env cc.Value.n_args ^^ + FuncDec.call_funcref env cc get_funcref + end + | SwitchE (e, cs) -> + StackRep.Vanilla, + let code1 = compile_exp_vanilla env e in let (set_i, get_i) = new_local env "switch_in" in let (set_j, get_j) = new_local env "switch_out" in @@ -3099,72 +3174,60 @@ and compile_exp (env : E.t) arity exp = match arity, exp.it with let (env1, alloc_code, code) = compile_pat env AllocHow.M.empty pat in CannotFail alloc_code ^^^ orElse ( CannotFail get_i ^^^ code ^^^ - CannotFail (compile_exp env1 1 e) ^^^ CannotFail set_j) + CannotFail (compile_exp_vanilla env1 e) ^^^ CannotFail set_j) (go env cs) in let code2 = go env cs in code1 ^^ set_i ^^ orTrap code2 ^^ get_j - | _, ForE (p, e1, e2) -> - let code1 = compile_exp env 1 e1 in - let (env1, alloc_code, code2) = compile_mono_pat env AllocHow.M.empty p in - let code3 = compile_exp env1 0 e2 in - - let (set_i, get_i) = new_local env "iter" in - (* Store the iterator *) - code1 ^^ - set_i ^^ - - G.loop_ [] - ( get_i ^^ - Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ - get_i ^^ - Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ - Closure.call_closure env1 (Value.local_cc 0 1) ^^ - let (set_oi, get_oi) = new_local env "opt" in - set_oi ^^ - - (* Check for null *) - get_oi ^^ - compile_null ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ - G.if_ [] - G.nop - ( alloc_code ^^ get_oi ^^ Opt.project ^^ - code2 ^^ code3 ^^ G.i_ (Br (nr 1l)) - ) - ) ^^ - compile_unit_nary arity + | ForE (p, e1, e2) -> + StackRep.unit, + let code1 = compile_exp_vanilla env e1 in + let (env1, alloc_code, code2) = compile_mono_pat env AllocHow.M.empty p in + let code3 = compile_exp_unit env1 e2 in + + let (set_i, get_i) = new_local env "iter" in + (* Store the iterator *) + code1 ^^ + set_i ^^ + + G.loop_ [] ( + get_i ^^ + Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ + get_i ^^ + Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ + Closure.call_closure env1 (Value.local_cc 0 1) ^^ + let (set_oi, get_oi) = new_local env "opt" in + set_oi ^^ + + (* Check for null *) + get_oi ^^ + compile_null ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.if_ [] + G.nop + ( alloc_code ^^ get_oi ^^ Opt.project ^^ + code2 ^^ code3 ^^ G.i_ (Br (nr 1l)) + ) + ) (* Async-wait lowering support features *) - | _, DeclareE (name, _, e) -> - let (env1, i) = E.add_local_with_offset env name.it 1l in - Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i_ (SetLocal (nr i)) ^^ - compile_exp env1 arity e - | _, DefineE (name, _, e) -> - compile_exp env 1 e ^^ - Var.set_val env name.it ^^ - compile_unit_nary arity - | 1, NewObjE ({ it = Type.Object _ (*sharing*); _}, fs) -> - let fs' = List.map + | DeclareE (name, _, e) -> + let (env1, i) = E.add_local_with_offset env name.it 1l in + let sr, code = compile_exp env1 e in + sr, + Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ + G.i_ (SetLocal (nr i)) ^^ + code + | DefineE (name, _, e) -> + StackRep.unit, + compile_exp_vanilla env e ^^ + Var.set_val env name.it + | NewObjE ({ it = Type.Object _ (*sharing*); _}, fs) -> + StackRep.Vanilla, + let fs' = List.map (fun (name, id) -> (name, fun env -> Var.get_val_ptr env id.it)) fs in - Object.lit_raw env fs' - (* We wanted a specialized arity, but no case matches. So we have - to use the general form (which should always succeed), and unpack the - resulting tuple - *) - | 0, _ -> - compile_exp env 1 exp ^^ - G.i_ Drop - | n, _ when n > 1 -> - let (set_tup, get_tup) = new_local env "tup" in - compile_exp env 1 exp ^^ - set_tup ^^ - G.table n (fun i -> - get_tup ^^ - Array.load_n (Int32.of_int i) - ) - | _ -> todo "compile_exp" (Arrange_ir.exp exp) (G.i_ Unreachable) + Object.lit_raw env fs' + | _ -> StackRep.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i_ Unreachable) and isDirectCall env e = match e.it with | VarE var -> @@ -3174,6 +3237,16 @@ and isDirectCall env e = match e.it with end | _ -> None +and compile_exp_as env sr_out e = + let sr_in, code = compile_exp env e in + code ^^ StackRep.adjust env sr_in sr_out + +and compile_exp_vanilla (env : E.t) exp = + compile_exp_as env StackRep.Vanilla exp + +and compile_exp_unit (env : E.t) exp = + compile_exp_as env StackRep.unit exp + (* The compilation of declarations (and patterns!) needs to handle mutual recursion. @@ -3291,17 +3364,17 @@ and compile_n_ary_pat env how pat = let arity, fill_code = match pat.it with (* Nothing to match: Do not even put something on the stack *) - | WildP -> 0, G.nop + | WildP -> StackRep.unit, G.nop (* The good case: We have a tuple pattern *) | TupP ps when List.length ps <> 1 -> - let arity = List.length ps in + let sr = StackRep.UnboxedTuple (List.length ps) in (* We have to fill the pattern in reverse order, to take things off the stack. This is only ok as long as patterns have no side effects. *) - arity, G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) + sr, G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) (* The general case: Create a single value, match that. *) | _ -> - 1, orTrap (fill_pat env1 pat) + StackRep.Vanilla, orTrap (fill_pat env1 pat) in (env1, alloc_code, arity, fill_code) (* Used for function patterns @@ -3332,15 +3405,15 @@ and compile_func_pat env cc pat = orTrap (fill_pat env1 pat) in (env1, alloc_code, fill_code) -and compile_dec pre_env arity how dec : E.t * G.t * (E.t -> G.t) = match dec.it with - | TypD _ -> (pre_env, G.nop, fun _ -> compile_unit_nary arity) - | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env arity e) +and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = match dec.it with + | TypD _ -> (pre_env, G.nop, fun _ -> StackRep.unit, G.nop) + | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env e) | LetD (p, e) -> let (pre_env1, alloc_code, pat_arity, fill_code) = compile_n_ary_pat pre_env how p in ( pre_env1, alloc_code, fun env -> - compile_exp env pat_arity e ^^ - fill_code ^^ - compile_unit_nary arity + StackRep.unit, + compile_exp_as env pat_arity e ^^ + fill_code ) | VarD (name, e) -> assert (AllocHow.M.find_opt name.it how = Some AllocHow.LocalMut || @@ -3348,41 +3421,45 @@ and compile_dec pre_env arity how dec : E.t * G.t * (E.t -> G.t) = match dec.it let (pre_env1, alloc_code) = AllocHow.add_local pre_env how name.it in ( pre_env1, alloc_code, fun env -> - compile_exp env 1 e ^^ - Var.set_val env name.it ^^ - compile_unit_nary arity + StackRep.unit, + compile_exp_vanilla env e ^^ + Var.set_val env name.it ) | FuncD (cc, name, _, p, _rt, e) -> (* Get captured variables *) let captured = Freevars_ir.captured p e in let mk_pat env1 = compile_func_pat env1 cc p in - let mk_body env1 = compile_exp env1 cc.Value.n_res e in + let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in let (pre_env1, alloc_code, mk_code) = FuncDec.dec pre_env how name cc captured mk_pat mk_body dec.at in - let lookup_code env = - match arity with - | 0 -> G.nop - | 1 -> Var.get_val env name.it - | _ -> assert false in - (pre_env1, alloc_code, fun env -> mk_code env ^^ lookup_code env) + (pre_env1, alloc_code, fun env -> + StackRep.Vanilla, mk_code env ^^ Var.get_val env name.it + ) -and compile_decs env arity decs : G.t = snd (compile_decs_block env arity decs) +and compile_decs env decs : StackRep.t * G.t = snd (compile_decs_block env decs) -and compile_decs_block env arity decs : (E.t * G.t) = +and compile_decs_block env decs : (E.t * (StackRep.t * G.t)) = let how = AllocHow.decs env decs in let rec go pre_env decs = match decs with - | [] -> (pre_env, G.nop, fun _ -> compile_unit_nary arity) - | [dec] -> compile_dec pre_env arity how dec + | [] -> (pre_env, G.nop, fun _ -> (StackRep.unit, G.nop)) + | [dec] -> compile_dec pre_env how dec | (dec::decs) -> - let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env 0 how dec in + let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env how dec in let (pre_env2, alloc_code2, mk_code2) = go pre_env1 decs in - (pre_env2, alloc_code1 ^^ alloc_code2, fun env -> mk_code1 env ^^ mk_code2 env) in + ( pre_env2, + alloc_code1 ^^ alloc_code2, + fun env -> + let (sr1, code1) = mk_code1 env in + let (sr2, code2) = mk_code2 env in + (sr2, code1 ^^ StackRep.drop env sr1 ^^ code2) + ) in let (env1, alloc_code, mk_code) = go env decs in - (env1, alloc_code ^^ mk_code env1) + let (sr, code) = mk_code env1 in + (env1, (sr, alloc_code ^^ code)) and compile_prelude env = (* Allocate the primitive functions *) - let (env1, code) = compile_decs_block env 0 (E.get_prelude env).it in - (env1, code) + let (env1, (sr, code)) = compile_decs_block env (E.get_prelude env).it in + (env1, code ^^ StackRep.drop env sr) (* Is this a hack? When determining whether an actor is closed, we should disregard the prelude, because every actor is compiled with the @@ -3400,9 +3477,9 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = let rec go env = function | [] -> G.nop | (prog::progs) -> - let (env1, code1) = compile_decs_block env 0 prog.it in + let (env1, (sr, code1)) = compile_decs_block env prog.it in let code2 = go env1 progs in - code1 ^^ code2 in + code1 ^^ StackRep.drop env1 sr ^^ code2 in go env1 progs ) @@ -3414,7 +3491,7 @@ and compile_private_actor_field pre_env (f : Ir.exp_field) = Tagged.store Tagged.MutBox ^^ compile_unboxed_const ptr ^^ - compile_exp env 1 f.it.exp ^^ + compile_exp_vanilla env f.it.exp ^^ Var.store ) @@ -3441,7 +3518,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = ( pre_env1, fun env -> let mk_pat inner_env = compile_func_pat inner_env cc pat in - let mk_body inner_env = compile_exp inner_env cc.Value.n_res exp in + let mk_body inner_env = compile_exp_as inner_env (StackRep.of_arity cc.Value.n_res) exp in let f = FuncDec.compile_static_message env cc mk_pat mk_body f.at in fill f; G.nop @@ -3477,7 +3554,7 @@ and actor_lit outer_env name fs = let start_fun = Func.of_body env [] [] (fun env3 -> (* Compile stuff here *) let (env4, prelude_code) = compile_prelude env3 in - let (env5, init_code ) = compile_actor_fields env4 fs in + let (env5, init_code) = compile_actor_fields env4 fs in prelude_code ^^ init_code) in let start_fi = E.add_fun env start_fun "start" in diff --git a/src/instrList.ml b/src/instrList.ml index f31a06be855..eb763a0e392 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -89,6 +89,11 @@ let with_current_depth (k : depth -> t) : t = let depth = new_depth_label () in remember_depth depth (k depth) +let with_current_depth' (k : depth -> ('a * t)) : ('a * t) = + let depth = new_depth_label () in + let x, is = k depth in + (x, remember_depth depth is) + let branch_to_ (p : depth) : t = fun d rest -> nr (Br (nr Int32.(sub d (Lib.Promise.value p)))) :: rest diff --git a/test/run/ok/bank-example.wasm.stderr.ok b/test/run/ok/bank-example.wasm.stderr.ok index 6faf816921f..aa95d4eae3e 100644 --- a/test/run/ok/bank-example.wasm.stderr.ok +++ b/test/run/ok/bank-example.wasm.stderr.ok @@ -1,3 +1,103 @@ +non-closed actor: (ActorE + anon-object-1.32 + (issuer issuer (CallE (class 0 -> 1) (VarE Issuer) (TupE)) Const Private) + (reserve + reserve + (CallE (class 1 -> 1) (VarE Account) (VarE supply)) + Const + Private + ) + (getIssuer + getIssuer + (BlockE + (FuncD + (shared 1 -> 0) + getIssuer + (VarP $32) + (TupT) + (BlockE + (LetD (TupP) (TupE)) + (ExpD + (CallE + ( 1 -> 0) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $0) + (PrimT Any) + (CallE + ( 1 -> 0) + (VarE $0) + (BlockE + (ExpD (RetE (CallE ( 1 -> 0) (VarE $0) (VarE issuer)))) + ) + ) + ) + ) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $33) + (PrimT Any) + (CallE (shared 1 -> 0) (VarE $32) (VarE $33)) + ) + ) + ) + ) + ) + ) + ) + Const + Public + ) + (getReserve + getReserve + (BlockE + (FuncD + (shared 1 -> 0) + getReserve + (VarP $34) + (TupT) + (BlockE + (LetD (TupP) (TupE)) + (ExpD + (CallE + ( 1 -> 0) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $1) + (PrimT Any) + (CallE + ( 1 -> 0) + (VarE $1) + (BlockE + (ExpD (RetE (CallE ( 1 -> 0) (VarE $1) (VarE reserve)))) + ) + ) + ) + ) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $35) + (PrimT Any) + (CallE (shared 1 -> 0) (VarE $34) (VarE $35)) + ) + ) + ) + ) + ) + ) + ) + Const + Public + ) +) non-closed actor: (ActorE self (balance balance (VarE initialBalance) Var Private) @@ -201,103 +301,3 @@ non-closed actor: (ActorE Public ) ) -non-closed actor: (ActorE - anon-object-1.32 - (issuer issuer (CallE (class 0 -> 1) (VarE Issuer) (TupE)) Const Private) - (reserve - reserve - (CallE (class 1 -> 1) (VarE Account) (VarE supply)) - Const - Private - ) - (getIssuer - getIssuer - (BlockE - (FuncD - (shared 1 -> 0) - getIssuer - (VarP $32) - (TupT) - (BlockE - (LetD (TupP) (TupE)) - (ExpD - (CallE - ( 1 -> 0) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $0) - (PrimT Any) - (CallE - ( 1 -> 0) - (VarE $0) - (BlockE - (ExpD (RetE (CallE ( 1 -> 0) (VarE $0) (VarE issuer)))) - ) - ) - ) - ) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $33) - (PrimT Any) - (CallE (shared 1 -> 0) (VarE $32) (VarE $33)) - ) - ) - ) - ) - ) - ) - ) - Const - Public - ) - (getReserve - getReserve - (BlockE - (FuncD - (shared 1 -> 0) - getReserve - (VarP $34) - (TupT) - (BlockE - (LetD (TupP) (TupE)) - (ExpD - (CallE - ( 1 -> 0) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $1) - (PrimT Any) - (CallE - ( 1 -> 0) - (VarE $1) - (BlockE - (ExpD (RetE (CallE ( 1 -> 0) (VarE $1) (VarE reserve)))) - ) - ) - ) - ) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $35) - (PrimT Any) - (CallE (shared 1 -> 0) (VarE $34) (VarE $35)) - ) - ) - ) - ) - ) - ) - ) - Const - Public - ) -) diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok index e468e42c1cf..8bc1dd83f40 100644 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ b/test/run/ok/bit-ops.wasm.stderr.ok @@ -1,64 +1,64 @@ -compile_binop: RotROp -compile_binop: RotROp -compile_binop: RotLOp -compile_binop: RotLOp -compile_binop: ShiftROp -compile_binop: ShiftROp -compile_binop: ShiftLOp -compile_binop: ShiftLOp -compile_binop: XorOp -compile_binop: XorOp -compile_binop: AndOp -compile_binop: AndOp -compile_binop: OrOp -compile_binop: OrOp compile_unop: NotOp compile_unop: NotOp -compile_binop: RotROp -compile_binop: RotROp -compile_binop: RotLOp -compile_binop: RotLOp -compile_binop: ShiftROp -compile_binop: ShiftROp -compile_binop: ShiftLOp -compile_binop: ShiftLOp -compile_binop: XorOp -compile_binop: XorOp -compile_binop: AndOp -compile_binop: AndOp compile_binop: OrOp compile_binop: OrOp -compile_unop: NotOp -compile_unop: NotOp -compile_binop: RotROp -compile_binop: RotROp -compile_binop: RotLOp -compile_binop: RotLOp -compile_binop: ShiftROp -compile_binop: ShiftROp -compile_binop: ShiftLOp -compile_binop: ShiftLOp -compile_binop: XorOp -compile_binop: XorOp compile_binop: AndOp compile_binop: AndOp -compile_binop: OrOp -compile_binop: OrOp -compile_unop: NotOp -compile_unop: NotOp -compile_binop: RotROp -compile_binop: RotROp -compile_binop: RotLOp -compile_binop: RotLOp -compile_binop: ShiftROp -compile_binop: ShiftROp -compile_binop: ShiftLOp -compile_binop: ShiftLOp compile_binop: XorOp compile_binop: XorOp +compile_binop: ShiftLOp +compile_binop: ShiftLOp +compile_binop: ShiftROp +compile_binop: ShiftROp +compile_binop: RotLOp +compile_binop: RotLOp +compile_binop: RotROp +compile_binop: RotROp +compile_unop: NotOp +compile_unop: NotOp +compile_binop: OrOp +compile_binop: OrOp compile_binop: AndOp compile_binop: AndOp +compile_binop: XorOp +compile_binop: XorOp +compile_binop: ShiftLOp +compile_binop: ShiftLOp +compile_binop: ShiftROp +compile_binop: ShiftROp +compile_binop: RotLOp +compile_binop: RotLOp +compile_binop: RotROp +compile_binop: RotROp +compile_unop: NotOp +compile_unop: NotOp compile_binop: OrOp compile_binop: OrOp +compile_binop: AndOp +compile_binop: AndOp +compile_binop: XorOp +compile_binop: XorOp +compile_binop: ShiftLOp +compile_binop: ShiftLOp +compile_binop: ShiftROp +compile_binop: ShiftROp +compile_binop: RotLOp +compile_binop: RotLOp +compile_binop: RotROp +compile_binop: RotROp compile_unop: NotOp compile_unop: NotOp +compile_binop: OrOp +compile_binop: OrOp +compile_binop: AndOp +compile_binop: AndOp +compile_binop: XorOp +compile_binop: XorOp +compile_binop: ShiftLOp +compile_binop: ShiftLOp +compile_binop: ShiftROp +compile_binop: ShiftROp +compile_binop: RotLOp +compile_binop: RotLOp +compile_binop: RotROp +compile_binop: RotROp diff --git a/test/run/ok/literals.wasm.stderr.ok b/test/run/ok/literals.wasm.stderr.ok index de083a70fac..63c35bad1f5 100644 --- a/test/run/ok/literals.wasm.stderr.ok +++ b/test/run/ok/literals.wasm.stderr.ok @@ -1,4 +1,4 @@ -compile_lit: (CharLit 2612) -compile_lit: (Word32Lit 4294967295) -compile_lit: (Word16Lit 6_5535) compile_lit: (Word8Lit 255) +compile_lit: (Word16Lit 6_5535) +compile_lit: (Word32Lit 4294967295) +compile_lit: (CharLit 2612) diff --git a/test/run/ok/overflow.wasm.stderr.ok b/test/run/ok/overflow.wasm.stderr.ok index d87024f9416..362c8a99d5f 100644 --- a/test/run/ok/overflow.wasm.stderr.ok +++ b/test/run/ok/overflow.wasm.stderr.ok @@ -1,16 +1,16 @@ -compile_lit: Overflow in literal 72462525423451963967165868 -compile_lit: Overflow in literal 1314235251543424342678909 -compile_lit: Overflow in literal 1152921504606846976 -compile_lit: Overflow in literal 1152921504606846976 -compile_lit: Overflow in literal 6917529027641081856 -compile_lit: Overflow in literal 2305843009213693952 -compile_lit: Overflow in literal 4611686018427387904 -compile_lit: Overflow in literal 2305843009213693952 -compile_lit: Overflow in literal 4611686018427387903 -compile_lit: Overflow in literal 4611686018427387904 -compile_lit: Overflow in literal 4294967295 -compile_lit: Overflow in literal 4294967296 +compile_lit: Overflow in literal 9223372036854775807 compile_lit: Overflow in literal 9223372036854775808 compile_lit: Overflow in literal 9223372036854775808 -compile_lit: Overflow in literal 9223372036854775807 compile_lit: Overflow in literal 9223372036854775808 +compile_lit: Overflow in literal 4294967295 +compile_lit: Overflow in literal 4294967296 +compile_lit: Overflow in literal 4611686018427387903 +compile_lit: Overflow in literal 4611686018427387904 +compile_lit: Overflow in literal 4611686018427387904 +compile_lit: Overflow in literal 2305843009213693952 +compile_lit: Overflow in literal 6917529027641081856 +compile_lit: Overflow in literal 2305843009213693952 +compile_lit: Overflow in literal 1152921504606846976 +compile_lit: Overflow in literal 1152921504606846976 +compile_lit: Overflow in literal 72462525423451963967165868 +compile_lit: Overflow in literal 1314235251543424342678909 From aa7efd421625d86713d6e47737258f97ad6c5e78 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 17 Dec 2018 09:54:16 +0100 Subject: [PATCH 10/41] Use Vanilla StackRep around Label and Break MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit since `wasm` doesn’t support multi-value stack types yet. --- src/compile.ml | 23 ++++++++++++++--------- test/run/n-ary.as | 17 +++++++++++++++++ 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 71e0e8c228e..78c6fce0733 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3078,17 +3078,22 @@ and compile_exp (env : E.t) exp = match exp.it with | BlockE decs -> compile_decs env decs | LabelE (name, _ty, e) -> - let sr, code = G.with_current_depth' (fun depth -> - let env1 = E.add_label env name depth in - compile_exp env1 e - ) in - sr, - G.block_ (StackRep.to_wasm_type sr) code - | BreakE (name, _ty) -> + (* The value here can come from many places -- the expression, + or any of the nested returns. Hard to tell which is the best + stack representation here. Also, our wasm encoder does not + handle multi-value stack returns yet, it seems. + So let’s go with Vanialla. *) + StackRep.Vanilla, + G.block_ (StackRep.to_wasm_type StackRep.Vanilla) ( + G.with_current_depth (fun depth -> + let env1 = E.add_label env name depth in + compile_exp_vanilla env1 e + ) + ) + | BreakE (name, e) -> let d = E.get_label_depth env name in StackRep.Unreachable, - (* TODO: Is this properly typed? Write more tests! *) - compile_unit ^^ + compile_exp_vanilla env e ^^ G.branch_to_ d | LoopE (e, None) -> StackRep.Unreachable, diff --git a/test/run/n-ary.as b/test/run/n-ary.as index 734d1abc0d6..0fd60c96f89 100644 --- a/test/run/n-ary.as +++ b/test/run/n-ary.as @@ -8,6 +8,8 @@ func foo_0_2_block () : (Int, Int) = { let x = 1; let y = 2; (x,y) }; func foo_0_return_2 () : (Int, Int) {return (1,2); (3,4)}; +func foo_0_break_2 () : (Int, Int) { label exit : (Int,Int) { break exit (1,2); (3,4) } }; + func foo_1_1 (x : Int) : Int {x + 1}; func foo_1_2 (x : Int) : (Int, Int) {(x,x)}; @@ -20,8 +22,23 @@ foo_0_0(); assert (foo_0_1() == 1); +{ let (x,y) = foo_0_2(); assert (x == 1); assert (y == 2); +}; + +{ +let (x,y) = foo_0_return_2(); +assert (x == 1); +assert (y == 2); +}; + +{ +let (x,y) = foo_0_break_2(); +assert (x == 1); +assert (y == 2); +}; + assert (foo_2_1(foo_1_2(5)) == 10); From 8783539df916e6e3eaa1a1ff5889891d26d376d5 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 10:22:46 +0100 Subject: [PATCH 11/41] Copy Wasm.Ast and Wasm.Types into this repository because we need to include multi-value support. I tried to get rid of the wasm reference interpreter dependency alltogether, given that we really only needs the AST (we already have a copy of the serialization module), and it would be nice to have a single `Source` module, for example, but we are using a lot of stuff from `Wasm.Lib`, e.g. for value types. Once multi-value support is officially supported by the `wasm` library I am happy to undo these changes and start using the official version again. --- default.nix | 2 + src/_tags | 3 +- src/compile.ml | 166 ++++++++--------- src/compile.mli | 2 +- src/instrList.ml | 4 +- src/js_main.ml | 2 +- src/main.ml | 2 +- src/pipeline.ml | 2 +- src/pipeline.mli | 2 +- src/wasm_copy.mlpack | 5 + src/wasm_copy/ast.ml | 257 ++++++++++++++++++++++++++ src/{ => wasm_copy}/customModule.ml | 2 +- src/{ => wasm_copy}/customSections.ml | 0 src/{ => wasm_copy}/encodeMap.ml | 4 +- src/wasm_copy/types.ml | 108 +++++++++++ 15 files changed, 467 insertions(+), 94 deletions(-) create mode 100644 src/wasm_copy.mlpack create mode 100644 src/wasm_copy/ast.ml rename src/{ => wasm_copy}/customModule.ml (98%) rename src/{ => wasm_copy}/customSections.ml (100%) rename src/{ => wasm_copy}/encodeMap.ml (99%) create mode 100644 src/wasm_copy/types.ml diff --git a/default.nix b/default.nix index 62ee74f9690..cb38a984b2e 100644 --- a/default.nix +++ b/default.nix @@ -61,10 +61,12 @@ rec { src = sourceByRegex ./. [ "src/" "src/Makefile.*" + "src/wasm_copy/" "src/.*.ml" "src/.*.mli" "src/.*.mly" "src/.*.mll" + "src/.*.mlpack" "src/_tags" "test/" "test/node-test.js" diff --git a/src/_tags b/src/_tags index 7615e1ea774..845ca8ad8f5 100644 --- a/src/_tags +++ b/src/_tags @@ -1 +1,2 @@ -<*>: coverage +<**/*>: coverage +: for-pack(Wasm_copy) diff --git a/src/compile.ml b/src/compile.ml index 78c6fce0733..e2ffd26f00f 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1,10 +1,10 @@ -open Wasm.Ast -open Wasm.Types +open Wasm_copy.Ast +open Wasm_copy.Types open Source open Ir -open CustomModule +open Wasm_copy.CustomModule module G = InstrList let (^^) = G.(^^) (* is this how we do that? *) @@ -114,7 +114,7 @@ module E = struct (* The prelude. We need to re-use this when compiling actors *) prelude : prog; (* Exports that need a custom type for the hypervisor *) - dfinity_types : (int32 * CustomSections.type_ list) list ref; + dfinity_types : (int32 * Wasm_copy.CustomSections.type_ list) list ref; (* Where does static memory end and dynamic memory begin? *) end_of_static_memory : int32 ref; (* Static memory defined so far *) @@ -311,7 +311,7 @@ end (* Function called compile_* return a list of instructions (and maybe other stuff) *) -let compile_unboxed_const i = G.i_ (Wasm.Ast.Const (nr (Wasm.Values.I32 i))) +let compile_unboxed_const i = G.i_ (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) let compile_unboxed_true = compile_unboxed_const 1l let compile_unboxed_false = compile_unboxed_const 0l let compile_unboxed_zero = compile_unboxed_const 0l @@ -323,10 +323,10 @@ let compile_null = compile_unboxed_const 3l let compile_op_const op i = compile_unboxed_const i ^^ G.i_ (Binary (Wasm.Values.I32 op)) -let compile_add_const = compile_op_const Wasm.Ast.I32Op.Add -let compile_sub_const = compile_op_const Wasm.Ast.I32Op.Sub -let compile_mul_const = compile_op_const Wasm.Ast.I32Op.Mul -let compile_divU_const = compile_op_const Wasm.Ast.I32Op.DivU +let compile_add_const = compile_op_const Wasm_copy.Ast.I32Op.Add +let compile_sub_const = compile_op_const Wasm_copy.Ast.I32Op.Sub +let compile_mul_const = compile_op_const Wasm_copy.Ast.I32Op.Mul +let compile_divU_const = compile_op_const Wasm_copy.Ast.I32Op.DivU (* Locals *) @@ -361,7 +361,7 @@ let from_0_to_n env mk_body = compile_while ( get_i ^^ get_n ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtS)) + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ) ( mk_body get_i ^^ @@ -428,7 +428,7 @@ module Heap = struct (* Add to old heap value *) G.i_ (GetGlobal (nr heap_ptr)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (SetGlobal (nr heap_ptr)) ) @@ -488,11 +488,11 @@ module Heap = struct from_0_to_n env (fun get_i -> get_to ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_from ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ G.i_ (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) @@ -609,21 +609,21 @@ module BitTagged = struct (* Check bit *) get_i ^^ compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.And)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ compile_unboxed_const 1l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ retty ( get_i ^^ compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.ShrU)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) ^^ is1) ( get_i ^^ is2) let tag = compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Shl)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Shl)) ^^ compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Or)) + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Or)) end (* BitTagged *) @@ -683,7 +683,7 @@ module Tagged = struct get_i ^^ load ^^ compile_unboxed_const (int_of_tag tag) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ retty (get_i ^^ code) (go cases) in set_i ^^ @@ -962,7 +962,7 @@ module BoxedInt = struct let box env = Func.share_code env "box_int" ["n"] [I32Type] (fun env -> let get_n = G.i_ (GetLocal (nr 0l)) in get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 5)) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtU)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ G.if_ [I32Type] (get_n ^^ BitTagged.tag) (Tagged.obj env Tagged.Int [ G.i_ (GetLocal (nr 0l)) ]) @@ -1009,12 +1009,12 @@ module Prim = struct get_i ^^ BoxedInt.unbox env ^^ compile_unboxed_zero ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtS)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ^^ G.if_ [I32Type] ( compile_unboxed_zero ^^ get_i ^^ BoxedInt.unbox env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ BoxedInt.box env ) ( get_i ) @@ -1108,13 +1108,13 @@ module Object = struct compile_add_const header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_f ^^ get_f ^^ Heap.load_field 0l ^^ (* the hash field *) get_hash ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [] ( get_f ^^ compile_add_const Heap.word_size ^^ @@ -1174,8 +1174,8 @@ module Text = struct compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ get_len2 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ Heap.dyn_alloc_bytes env ^^ set_z ^^ @@ -1186,7 +1186,7 @@ module Text = struct get_z ^^ get_len1 ^^ get_len2 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ Heap.store_field len_field ^^ (* Copy first string *) @@ -1207,7 +1207,7 @@ module Text = struct get_z ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_len2 ^^ @@ -1229,7 +1229,7 @@ module Text = struct get_len1 ^^ get_len2 ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [] G.nop (compile_unboxed_false ^^ G.i_ Return) ^^ (* We could do word-wise comparisons if we know that the trailing bytes @@ -1239,16 +1239,16 @@ module Text = struct get_x ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ get_y ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [] G.nop (compile_unboxed_false ^^ G.i_ Return) ) ^^ compile_unboxed_true @@ -1272,14 +1272,14 @@ module Array = struct get_idx ^^ get_array ^^ Heap.load_field len_field ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtU)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ G.if_ [] G.nop (G.i_ Unreachable) ^^ get_idx ^^ compile_add_const header_size ^^ compile_mul_const element_size ^^ get_array ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ) (* Expects on the stack the pointer to the array. *) @@ -1333,7 +1333,7 @@ module Array = struct Closure.load_closure 1l ^^ (* Get length *) Heap.load_field len_field ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [I32Type] (* Then *) compile_null @@ -1740,7 +1740,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_unboxed_const 0l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_[] (* First run, call the start function *) ( G.i_ (Call (nr start_funid)) ) @@ -1776,7 +1776,7 @@ module OrthogonalPersistence = struct compile_unboxed_const ElemHeap.table_end ^^ G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ compile_unboxed_const ElemHeap.table_end ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ G.i_ (Call (nr (Dfinity.data_externalize_i env))) ^^ G.i_ (SetGlobal (nr mem_global)) ^^ @@ -1945,14 +1945,14 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_i ^^ compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ load_ptr ^^ @@ -1965,7 +1965,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ get_i ^^ @@ -1973,7 +1973,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ load_ptr ^^ @@ -2000,7 +2000,7 @@ module Serialization = struct get_loc ^^ get_tmp env ^^ get_ptr_offset ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ store_ptr ) ) @@ -2060,12 +2060,12 @@ module Serialization = struct (* While we have not reached the end of the area *) ( get_x ^^ compile_to ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtS)) + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ) ( mk_code get_x ^^ get_x ^^ get_x ^^ object_size env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_x ) @@ -2109,7 +2109,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) @@ -2122,7 +2122,7 @@ module Serialization = struct compile_add_const Closure.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) @@ -2162,7 +2162,7 @@ module Serialization = struct (* Adjust reference *) get_tbl_area ^^ get_i ^^ compile_mul_const Heap.word_size ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_x ^^ Heap.load_field 1l ^^ ElemHeap.recall_reference env ^^ @@ -2197,7 +2197,7 @@ module Serialization = struct Heap.load_field 1l ^^ compile_mul_const Heap.word_size ^^ get_tbl_area ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ load_ptr ^^ ElemHeap.remember_reference env ^^ Heap.store_field 1l @@ -2249,7 +2249,7 @@ module Serialization = struct (* Adjust pointers *) get_start ^^ get_end ^^ - compile_unboxed_zero ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + compile_unboxed_zero ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ shift_pointers env ^^ (* Extract references, and remember how many there were *) @@ -2262,14 +2262,14 @@ module Serialization = struct (* Create databuf *) get_start ^^ - get_end ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + get_end ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ G.i_ (Call (nr (Dfinity.data_externalize_i env))) ^^ set_databuf ^^ (* Append this reference at the end of the extracted references *) get_end ^^ get_tbl_size ^^ compile_mul_const Heap.word_size ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_databuf ^^ store_ptr ^^ (* And bump table end *) @@ -2335,7 +2335,7 @@ module Serialization = struct (* Check if we got something unboxed (data buf size 1 word) *) get_data_len ^^ compile_unboxed_const Heap.word_size ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [I32Type] (* Yes, we got something unboxed. Return it, and do _not_ bump the heap pointer *) ( get_start ^^ load_ptr ) @@ -2343,7 +2343,7 @@ module Serialization = struct ( (* update heap pointer *) get_start ^^ get_data_len ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (SetGlobal (nr Heap.heap_ptr)) ^^ (* Fix pointers *) @@ -2408,7 +2408,7 @@ module GC = struct (* If this is static, ignore it *) get_obj ^^ get_begin_from_space ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtU)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ G.if_ [] (get_end_to_space ^^ G.i_ Return) G.nop ^^ (* If this is an indirection, just use that value *) @@ -2434,9 +2434,9 @@ module GC = struct (* Calculate new pointer *) get_end_to_space ^^ get_begin_to_space ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ get_begin_from_space ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_new_ptr ^^ (* Set indirection *) @@ -2454,7 +2454,7 @@ module GC = struct (* Calculate new end of to space *) get_end_to_space ^^ get_len ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ) let register env (end_of_static_space : int32) = Func.define_built_in env "collect" [] [] (fun env -> @@ -2501,13 +2501,13 @@ module GC = struct (* Copy the to-space to the beginning of memory. *) get_begin_to_space ^^ get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ + get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ Heap.memcpy env ^^ (* Reset the heap pointer *) get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add)) ^^ + get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ G.i_ (SetGlobal (nr Heap.heap_ptr)) ) @@ -2707,7 +2707,7 @@ module FuncDec = struct let f = compile_message env cc restore_env mk_pat mk_body at in let fi = E.add_fun env f name.it in E.add_dfinity_type env (fi, - CustomSections.I32 :: Lib.List.make cc.Value.n_args CustomSections.ElemBuf + Wasm_copy.CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) ); fi in @@ -2901,29 +2901,29 @@ let compile_unop env op = Syntax.(match op with set_tmp env ^^ compile_unboxed_zero ^^ get_tmp env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub))) + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub))) | PosOp -> G.nop | _ -> todo "compile_unop" (Arrange.unop op) G.i_ Unreachable ) let compile_binop env op = Syntax.(match op with - | AddOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Add))) - | SubOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Sub))) - | MulOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.Mul))) - | DivOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.DivU))) - | ModOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm.Ast.I32Op.RemU))) + | AddOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add))) + | SubOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub))) + | MulOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul))) + | DivOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU))) + | ModOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU))) | CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) G.i_ Unreachable ) let compile_relop env op = Syntax.(BoxedInt.lift_unboxed_binary env (match op with - | EqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) - | NeqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + | EqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + | NeqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [I32Type] compile_unboxed_false compile_unboxed_true - | GeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.GeS)) - | GtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.GtS)) - | LeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LeS)) - | LtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.LtS)) + | GeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) + | GtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) + | LeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) + | LtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) )) @@ -3062,7 +3062,7 @@ and compile_exp (env : E.t) exp = match exp.it with Heap.load_field Object.class_position ^^ (* Equal? *) get_j ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [I32Type] (BoxedInt.lit_true env) (* Static function id? *) @@ -3072,7 +3072,7 @@ and compile_exp (env : E.t) exp = match exp.it with Heap.load_field 0l ^^ (* get the function id *) compile_mul_const Heap.word_size ^^ compile_add_const 1l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ) ] | BlockE decs -> @@ -3207,7 +3207,7 @@ and compile_exp (env : E.t) exp = match exp.it with (* Check for null *) get_oi ^^ compile_null ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [] G.nop ( alloc_code ^^ get_oi ^^ Opt.project ^^ @@ -3284,12 +3284,12 @@ enabled mutual recursion. and compile_lit_pat env l = match l with | Syntax.NullLit -> compile_lit env l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(NatLit _ | IntLit _ | BoolLit _) -> BoxedInt.unbox env ^^ compile_lit env l ^^ BoxedInt.unbox env ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(TextLit t) -> Text.lit env t ^^ Text.compare env @@ -3304,7 +3304,7 @@ and fill_pat env pat : patternCode = match pat.it with set_i ^^ get_i ^^ compile_null ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm.Ast.I32Op.Eq)) ^^ + G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ [] fail_code ( get_i ^^ Opt.project ^^ @@ -3513,7 +3513,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = I have not reviewed/fixed the code below. *) let (fi, fill) = E.reserve_fun pre_env name.it in - E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args CustomSections.ElemBuf); + E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args Wasm_copy.CustomSections.ElemBuf); E.add_export pre_env (nr { name = Dfinity.explode name.it; edesc = nr (FuncExport (nr fi)) @@ -3566,7 +3566,7 @@ and actor_lit outer_env name fs = OrthogonalPersistence.register env start_fi; let m = conclude_module env name.it None in - let (_map, wasm) = CustomModule.encode m in + let (_map, wasm) = Wasm_copy.CustomModule.encode m in wasm in let code = @@ -3655,8 +3655,8 @@ and conclude_module env module_name start_fi_o = }; types = E.get_dfinity_types env; persist = - [ (OrthogonalPersistence.mem_global, CustomSections.DataBuf) - ; (OrthogonalPersistence.elem_global, CustomSections.ElemBuf) + [ (OrthogonalPersistence.mem_global, Wasm_copy.CustomSections.DataBuf) + ; (OrthogonalPersistence.elem_global, Wasm_copy.CustomSections.ElemBuf) ]; module_name; function_names = diff --git a/src/compile.mli b/src/compile.mli index ce0789f661e..6a70b9a080d 100644 --- a/src/compile.mli +++ b/src/compile.mli @@ -1,3 +1,3 @@ type mode = WasmMode | DfinityMode -val compile : mode -> string -> Ir.prog -> Ir.prog list -> CustomModule.extended_module +val compile : mode -> string -> Ir.prog -> Ir.prog list -> Wasm_copy.CustomModule.extended_module diff --git a/src/instrList.ml b/src/instrList.ml index eb763a0e392..fbd618cb60f 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -7,8 +7,8 @@ features are * Some simple peephole optimizations. *) -open Wasm.Types -open Wasm.Ast +open Wasm_copy.Types +open Wasm_copy.Ast open Wasm.Source (* Some simpl peephole optimizations, to make the output code look less stupid *) diff --git a/src/js_main.ml b/src/js_main.ml index d76f2878645..34b2709c183 100644 --- a/src/js_main.ml +++ b/src/js_main.ml @@ -57,7 +57,7 @@ let js_compile_with mode_string source_map source convert = let js_compile_wasm mode source_map s = js_compile_with mode source_map s - (fun m -> let (map, wasm) = CustomModule.encode m in Js.bytestring wasm, Js.string map) + (fun m -> let (map, wasm) = Wasm_copy.CustomModule.encode m in Js.bytestring wasm, Js.string map) let () = Js.export "ActorScript" diff --git a/src/main.ml b/src/main.ml index 46894bdd5b0..df0dffbab81 100644 --- a/src/main.ml +++ b/src/main.ml @@ -82,7 +82,7 @@ let process_files files : unit = let module_name = Filename.remove_extension (Filename.basename !out_file) in let module_ = exit_on_failure Pipeline.(compile_files !compile_mode files module_name) in let oc = open_out !out_file in - let (source_map, wasm) = CustomModule.encode module_ in + let (source_map, wasm) = Wasm_copy.CustomModule.encode module_ in output_string oc wasm; close_out oc; if !Flags.source_map then begin diff --git a/src/pipeline.ml b/src/pipeline.ml index 89e6a419a14..4ca61983f0b 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -279,7 +279,7 @@ let run_files env = function (* Compilation *) type compile_mode = Compile.mode = WasmMode | DfinityMode -type compile_result = (CustomModule.extended_module, Diag.messages) result +type compile_result = (Wasm_copy.CustomModule.extended_module, Diag.messages) result let compile_with check mode name : compile_result = match check initial_stat_env name with diff --git a/src/pipeline.mli b/src/pipeline.mli index 92677d228fe..1f000eade22 100644 --- a/src/pipeline.mli +++ b/src/pipeline.mli @@ -33,7 +33,7 @@ val run_lexer : env -> Lexing.lexbuf -> string -> run_result val run_stdin : env -> unit type compile_mode = WasmMode | DfinityMode -type compile_result = (CustomModule.extended_module, Diag.messages) result +type compile_result = (Wasm_copy.CustomModule.extended_module, Diag.messages) result val compile_file : compile_mode -> string -> string -> compile_result val compile_files : compile_mode -> string list -> string -> compile_result val compile_string : compile_mode -> string -> string -> compile_result diff --git a/src/wasm_copy.mlpack b/src/wasm_copy.mlpack new file mode 100644 index 00000000000..27e55b51f7a --- /dev/null +++ b/src/wasm_copy.mlpack @@ -0,0 +1,5 @@ +wasm_copy/Types +wasm_copy/Ast +wasm_copy/CustomModule +wasm_copy/CustomSections +wasm_copy/EncodeMap diff --git a/src/wasm_copy/ast.ml b/src/wasm_copy/ast.ml new file mode 100644 index 00000000000..0d382e6e0af --- /dev/null +++ b/src/wasm_copy/ast.ml @@ -0,0 +1,257 @@ +(* + * Throughout the implementation we use consistent naming conventions for + * syntactic elements, associated with the types defined here and in a few + * other places: + * + * x : var + * v : value + * e : instrr + * f : func + * m : module_ + * + * t : value_type + * s : func_type + * c : context / config + * + * These conventions mostly follow standard practice in language semantics. + *) + +open Types + + +(* Operators *) + +module IntOp = +struct + type unop = Clz | Ctz | Popcnt + type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU + | And | Or | Xor | Shl | ShrS | ShrU | Rotl | Rotr + type testop = Eqz + type relop = Eq | Ne | LtS | LtU | GtS | GtU | LeS | LeU | GeS | GeU + type cvtop = ExtendSI32 | ExtendUI32 | WrapI64 + | TruncSF32 | TruncUF32 | TruncSF64 | TruncUF64 + | ReinterpretFloat +end + +module FloatOp = +struct + type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt + type binop = Add | Sub | Mul | Div | Min | Max | CopySign + type testop + type relop = Eq | Ne | Lt | Gt | Le | Ge + type cvtop = ConvertSI32 | ConvertUI32 | ConvertSI64 | ConvertUI64 + | PromoteF32 | DemoteF64 + | ReinterpretInt +end + +module I32Op = IntOp +module I64Op = IntOp +module F32Op = FloatOp +module F64Op = FloatOp + +type unop = (I32Op.unop, I64Op.unop, F32Op.unop, F64Op.unop) Wasm.Values.op +type binop = (I32Op.binop, I64Op.binop, F32Op.binop, F64Op.binop) Wasm.Values.op +type testop = (I32Op.testop, I64Op.testop, F32Op.testop, F64Op.testop) Wasm.Values.op +type relop = (I32Op.relop, I64Op.relop, F32Op.relop, F64Op.relop) Wasm.Values.op +type cvtop = (I32Op.cvtop, I64Op.cvtop, F32Op.cvtop, F64Op.cvtop) Wasm.Values.op + +type 'a memop = + {ty : value_type; align : int; offset : Wasm.Memory.offset; sz : 'a option} +type loadop = (Wasm.Memory.pack_size * Wasm.Memory.extension) memop +type storeop = Wasm.Memory.pack_size memop + + +(* Expressions *) + +type var = int32 Wasm.Source.phrase +type literal = Wasm.Values.value Wasm.Source.phrase +type name = int list + +type instr = instr' Wasm.Source.phrase +and instr' = + | Unreachable (* trap unconditionally *) + | Nop (* do nothing *) + | Drop (* forget a value *) + | Select (* branchless conditional *) + | Block of stack_type * instr list (* execute in sequence *) + | Loop of stack_type * instr list (* loop header *) + | If of stack_type * instr list * instr list (* conditional *) + | Br of var (* break to n-th surrounding label *) + | BrIf of var (* conditional break *) + | BrTable of var list * var (* indexed break *) + | Return (* break from function body *) + | Call of var (* call function *) + | CallIndirect of var (* call function through table *) + | GetLocal of var (* read local variable *) + | SetLocal of var (* write local variable *) + | TeeLocal of var (* write local variable and keep value *) + | GetGlobal of var (* read global variable *) + | SetGlobal of var (* write global variable *) + | Load of loadop (* read memory at address *) + | Store of storeop (* write memory at address *) + | MemorySize (* size of linear memory *) + | MemoryGrow (* grow linear memory *) + | Const of literal (* constant *) + | Test of testop (* numeric test *) + | Compare of relop (* numeric comparison *) + | Unary of unop (* unary numeric operator *) + | Binary of binop (* binary numeric operator *) + | Convert of cvtop (* conversion *) + + +(* Globals & Functions *) + +type const = instr list Wasm.Source.phrase + +type global = global' Wasm.Source.phrase +and global' = +{ + gtype : global_type; + value : const; +} + +type func = func' Wasm.Source.phrase +and func' = +{ + ftype : var; + locals : value_type list; + body : instr list; +} + + +(* Tables & Memories *) + +type table = table' Wasm.Source.phrase +and table' = +{ + ttype : table_type; +} + +type memory = memory' Wasm.Source.phrase +and memory' = +{ + mtype : memory_type; +} + +type 'data segment = 'data segment' Wasm.Source.phrase +and 'data segment' = +{ + index : var; + offset : const; + init : 'data; +} + +type table_segment = var list segment +type memory_segment = string segment + + +(* Modules *) + +type type_ = func_type Wasm.Source.phrase + +type export_desc = export_desc' Wasm.Source.phrase +and export_desc' = + | FuncExport of var + | TableExport of var + | MemoryExport of var + | GlobalExport of var + +type export = export' Wasm.Source.phrase +and export' = +{ + name : name; + edesc : export_desc; +} + +type import_desc = import_desc' Wasm.Source.phrase +and import_desc' = + | FuncImport of var + | TableImport of table_type + | MemoryImport of memory_type + | GlobalImport of global_type + +type import = import' Wasm.Source.phrase +and import' = +{ + module_name : name; + item_name : name; + idesc : import_desc; +} + +type module_ = module_' Wasm.Source.phrase +and module_' = +{ + types : type_ list; + globals : global list; + tables : table list; + memories : memory list; + funcs : func list; + start : var option; + elems : var list segment list; + data : string segment list; + imports : import list; + exports : export list; +} + + +(* Auxiliary functions *) + +let empty_module = +{ + types = []; + globals = []; + tables = []; + memories = []; + funcs = []; + start = None; + elems = []; + data = []; + imports = []; + exports = []; +} + +open Wasm.Source + +let func_type_for (m : module_) (x : var) : func_type = + (Lib.List32.nth m.it.types x.it).it + +let import_type (m : module_) (im : import) : extern_type = + let {idesc; _} = im.it in + match idesc.it with + | FuncImport x -> ExternFuncType (func_type_for m x) + | TableImport t -> ExternTableType t + | MemoryImport t -> ExternMemoryType t + | GlobalImport t -> ExternGlobalType t + +let export_type (m : module_) (ex : export) : extern_type = + let {edesc; _} = ex.it in + let its = List.map (import_type m) m.it.imports in + let open Lib.List32 in + match edesc.it with + | FuncExport x -> + let fts = + funcs its @ List.map (fun f -> func_type_for m f.it.ftype) m.it.funcs + in ExternFuncType (nth fts x.it) + | TableExport x -> + let tts = tables its @ List.map (fun t -> t.it.ttype) m.it.tables in + ExternTableType (nth tts x.it) + | MemoryExport x -> + let mts = memories its @ List.map (fun m -> m.it.mtype) m.it.memories in + ExternMemoryType (nth mts x.it) + | GlobalExport x -> + let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in + ExternGlobalType (nth gts x.it) + +let string_of_name n = + let b = Buffer.create 16 in + let escape uc = + if uc < 0x20 || uc >= 0x7f then + Buffer.add_string b (Printf.sprintf "\\u{%02x}" uc) + else begin + let c = Char.chr uc in + if c = '\"' || c = '\\' then Buffer.add_char b '\\'; + Buffer.add_char b c + end + in + List.iter escape n; + Buffer.contents b diff --git a/src/customModule.ml b/src/wasm_copy/customModule.ml similarity index 98% rename from src/customModule.ml rename to src/wasm_copy/customModule.ml index 313b91d960d..93911284737 100644 --- a/src/customModule.ml +++ b/src/wasm_copy/customModule.ml @@ -3,7 +3,7 @@ *) open Wasm.Source -open Wasm.Ast +open Ast type extended_module = { (* The non-custom sections *) diff --git a/src/customSections.ml b/src/wasm_copy/customSections.ml similarity index 100% rename from src/customSections.ml rename to src/wasm_copy/customSections.ml diff --git a/src/encodeMap.ml b/src/wasm_copy/encodeMap.ml similarity index 99% rename from src/encodeMap.ml rename to src/wasm_copy/encodeMap.ml index 7fd1f7b2c5c..ae687771ddd 100644 --- a/src/encodeMap.ml +++ b/src/wasm_copy/encodeMap.ml @@ -128,7 +128,7 @@ let encode m = (* Types *) - open Wasm.Types + open Types let value_type = function | I32Type -> vs7 (-0x01) @@ -168,7 +168,7 @@ let encode m = (* Expressions *) open Wasm.Source - open Wasm.Ast + open Ast open Wasm.Values open Wasm.Memory diff --git a/src/wasm_copy/types.ml b/src/wasm_copy/types.ml new file mode 100644 index 00000000000..5a6c0ea762c --- /dev/null +++ b/src/wasm_copy/types.ml @@ -0,0 +1,108 @@ +(* Types *) + +type value_type = I32Type | I64Type | F32Type | F64Type +type elem_type = AnyFuncType +type stack_type = value_type list +type func_type = FuncType of stack_type * stack_type + +type 'a limits = {min : 'a; max : 'a option} +type mutability = Immutable | Mutable +type table_type = TableType of Int32.t limits * elem_type +type memory_type = MemoryType of Int32.t limits +type global_type = GlobalType of value_type * mutability +type extern_type = + | ExternFuncType of func_type + | ExternTableType of table_type + | ExternMemoryType of memory_type + | ExternGlobalType of global_type + + +(* Attributes *) + +let size = function + | I32Type | F32Type -> 4 + | I64Type | F64Type -> 8 + + +(* Subtyping *) + +let match_limits lim1 lim2 = + Wasm.I32.ge_u lim1.min lim2.min && + match lim1.max, lim2.max with + | _, None -> true + | None, Some _ -> false + | Some i, Some j -> Wasm.I32.le_u i j + +let match_func_type ft1 ft2 = + ft1 = ft2 + +let match_table_type (TableType (lim1, et1)) (TableType (lim2, et2)) = + et1 = et2 && match_limits lim1 lim2 + +let match_memory_type (MemoryType lim1) (MemoryType lim2) = + match_limits lim1 lim2 + +let match_global_type gt1 gt2 = + gt1 = gt2 + +let match_extern_type et1 et2 = + match et1, et2 with + | ExternFuncType ft1, ExternFuncType ft2 -> match_func_type ft1 ft2 + | ExternTableType tt1, ExternTableType tt2 -> match_table_type tt1 tt2 + | ExternMemoryType mt1, ExternMemoryType mt2 -> match_memory_type mt1 mt2 + | ExternGlobalType gt1, ExternGlobalType gt2 -> match_global_type gt1 gt2 + | _, _ -> false + + +(* Filters *) + +let funcs = + Lib.List.map_filter (function ExternFuncType t -> Some t | _ -> None) +let tables = + Lib.List.map_filter (function ExternTableType t -> Some t | _ -> None) +let memories = + Lib.List.map_filter (function ExternMemoryType t -> Some t | _ -> None) +let globals = + Lib.List.map_filter (function ExternGlobalType t -> Some t | _ -> None) + + +(* String conversion *) + +let string_of_value_type = function + | I32Type -> "i32" + | I64Type -> "i64" + | F32Type -> "f32" + | F64Type -> "f64" + +let string_of_value_types = function + | [t] -> string_of_value_type t + | ts -> "[" ^ String.concat " " (List.map string_of_value_type ts) ^ "]" + +let string_of_elem_type = function + | AnyFuncType -> "anyfunc" + +let string_of_limits {min; max} = + Wasm.I32.to_string_u min ^ + (match max with None -> "" | Some n -> " " ^ Wasm.I32.to_string_u n) + +let string_of_memory_type = function + | MemoryType lim -> string_of_limits lim + +let string_of_table_type = function + | TableType (lim, t) -> string_of_limits lim ^ " " ^ string_of_elem_type t + +let string_of_global_type = function + | GlobalType (t, Immutable) -> string_of_value_type t + | GlobalType (t, Mutable) -> "(mut " ^ string_of_value_type t ^ ")" + +let string_of_stack_type ts = + "[" ^ String.concat " " (List.map string_of_value_type ts) ^ "]" + +let string_of_func_type (FuncType (ins, out)) = + string_of_stack_type ins ^ " -> " ^ string_of_stack_type out + +let string_of_extern_type = function + | ExternFuncType ft -> "func " ^ string_of_func_type ft + | ExternTableType tt -> "table " ^ string_of_table_type tt + | ExternMemoryType mt -> "memory " ^ string_of_memory_type mt + | ExternGlobalType gt -> "global " ^ string_of_global_type gt From 680ade7fdef46306775c347763ad44a429e0a151 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 10:43:38 +0100 Subject: [PATCH 12/41] Generate proper multi-value Wasm by cherry-picking the changes to `ast.ml` and `encode.ml` from https://github.com/WebAssembly/multi-value into our code copy. --- src/compile.ml | 99 ++++++++++++++++++++------------------ src/instrList.ml | 9 ++-- src/wasm_copy/ast.ml | 8 +-- src/wasm_copy/encodeMap.ml | 22 ++++----- 4 files changed, 71 insertions(+), 67 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index e2ffd26f00f..72108627f19 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -349,7 +349,9 @@ let new_local env name = (* expects a number on the stack. Iterates from zero t below that number *) let compile_while cond body = - G.loop_ [] ( cond ^^ G.if_ [] (body ^^ G.i_ (Br (nr 1l))) G.nop) + G.loop_ (ValBlockType None) ( + cond ^^ G.if_ (ValBlockType None) (body ^^ G.i_ (Br (nr 1l))) G.nop + ) let from_0_to_n env mk_body = let (set_n, get_n) = new_local env "n" in @@ -963,14 +965,14 @@ module BoxedInt = struct let get_n = G.i_ (GetLocal (nr 0l)) in get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 5)) ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ - G.if_ [I32Type] + G.if_ (ValBlockType (Some I32Type)) (get_n ^^ BitTagged.tag) (Tagged.obj env Tagged.Int [ G.i_ (GetLocal (nr 0l)) ]) ) let unbox env = Func.share_code env "unbox_int" ["n"] [I32Type] (fun env -> let get_n = G.i_ (GetLocal (nr 0l)) in get_n ^^ - BitTagged.if_unboxed env [I32Type] + BitTagged.if_unboxed env (ValBlockType (Some I32Type)) G.nop (Heap.load_field payload_field) ) @@ -1010,7 +1012,7 @@ module Prim = struct BoxedInt.unbox env ^^ compile_unboxed_zero ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ^^ - G.if_ [I32Type] + G.if_ (ValBlockType (Some I32Type)) ( compile_unboxed_zero ^^ get_i ^^ BoxedInt.unbox env ^^ @@ -1115,7 +1117,7 @@ module Object = struct Heap.load_field 0l ^^ (* the hash field *) get_hash ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [] + G.if_ (ValBlockType None) ( get_f ^^ compile_add_const Heap.word_size ^^ (* dereference the indirection *) @@ -1230,7 +1232,7 @@ module Text = struct get_len1 ^^ get_len2 ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [] G.nop (compile_unboxed_false ^^ G.i_ Return) ^^ + G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i_ Return) ^^ (* We could do word-wise comparisons if we know that the trailing bytes are zeroed *) @@ -1249,7 +1251,7 @@ module Text = struct G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [] G.nop (compile_unboxed_false ^^ G.i_ Return) + G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i_ Return) ) ^^ compile_unboxed_true ) @@ -1273,7 +1275,7 @@ module Array = struct get_array ^^ Heap.load_field len_field ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ - G.if_ [] G.nop (G.i_ Unreachable) ^^ + G.if_ (ValBlockType None) G.nop (G.i_ Unreachable) ^^ get_idx ^^ compile_add_const header_size ^^ @@ -1334,7 +1336,7 @@ module Array = struct (* Get length *) Heap.load_field len_field ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [I32Type] + G.if_ (ValBlockType (Some I32Type)) (* Then *) compile_null (* Else *) @@ -1741,7 +1743,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_unboxed_const 0l ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_[] + G.if_ (ValBlockType None) (* First run, call the start function *) ( G.i_ (Call (nr start_funid)) ) @@ -1833,11 +1835,11 @@ module Serialization = struct set_copy ^^ get_x ^^ - BitTagged.if_unboxed env [I32Type] + BitTagged.if_unboxed env (ValBlockType (Some I32Type)) ( (* Tagged unboxed value, can be left alone *) G.i_ Drop ^^ get_x ) - ( Tagged.branch env [I32Type] + ( Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, (* x still on the stack *) Heap.alloc env 2l ^^ @@ -1992,7 +1994,7 @@ module Serialization = struct let get_ptr_offset = G.i_ (GetLocal (nr 1l)) in get_loc ^^ load_ptr ^^ - BitTagged.if_unboxed env [] + BitTagged.if_unboxed env (ValBlockType None) (* nothing to do *) ( G.i_ Drop ) ( set_tmp env ^^ @@ -2010,7 +2012,7 @@ module Serialization = struct Func.share_code env "object_size" ["x"] [I32Type] (fun env -> let get_x = G.i_ (GetLocal (nr 0l)) in get_x ^^ - Tagged.branch env [I32Type] + Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) @@ -2074,7 +2076,7 @@ module Serialization = struct let for_each_pointer env get_x mk_code = let (set_ptr_loc, get_ptr_loc) = new_local env "ptr_loc" in get_x ^^ - Tagged.branch_default env [] G.nop + Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.MutBox, compile_add_const (Int32.mul Heap.word_size Var.mutbox_field) ^^ set_ptr_loc ^^ @@ -2154,7 +2156,7 @@ module Serialization = struct walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ - Tagged.branch_default env [] G.nop + Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, (* x still on the stack *) G.i_ Drop ^^ @@ -2188,7 +2190,7 @@ module Serialization = struct walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ - Tagged.branch_default env [] G.nop + Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, (* x still on the stack *) @@ -2222,7 +2224,7 @@ module Serialization = struct (* Copy data *) get_x ^^ - BitTagged.if_unboxed env [] + BitTagged.if_unboxed env (ValBlockType None) (* We have a bit-tagged raw value. Put this into a singleton databuf, which will be recognized as such by its size. *) @@ -2336,7 +2338,7 @@ module Serialization = struct get_data_len ^^ compile_unboxed_const Heap.word_size ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [I32Type] + G.if_ (ValBlockType (Some I32Type)) (* Yes, we got something unboxed. Return it, and do _not_ bump the heap pointer *) ( get_start ^^ load_ptr ) (* No, it is actual heap-data *) @@ -2403,17 +2405,17 @@ module GC = struct get_obj ^^ (* If this is an unboxed scalar, ignore it *) - BitTagged.if_unboxed env [] (G.i_ Drop ^^ get_end_to_space ^^ G.i_ Return) (G.i_ Drop) ^^ + BitTagged.if_unboxed env (ValBlockType None) (G.i_ Drop ^^ get_end_to_space ^^ G.i_ Return) (G.i_ Drop) ^^ (* If this is static, ignore it *) get_obj ^^ get_begin_from_space ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ - G.if_ [] (get_end_to_space ^^ G.i_ Return) G.nop ^^ + G.if_ (ValBlockType None) (get_end_to_space ^^ G.i_ Return) G.nop ^^ (* If this is an indirection, just use that value *) get_obj ^^ - Tagged.branch_default env [] G.nop [ + Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Indirection, G.i_ Drop ^^ @@ -2795,10 +2797,12 @@ module StackRep = struct let of_arity n = if n = 1 then Vanilla else UnboxedTuple n - let to_wasm_type = function - | Vanilla -> [I32Type] - | UnboxedTuple n -> Lib.List.make n I32Type - | Unreachable -> [] + let to_block_type env = function + | Vanilla -> ValBlockType (Some I32Type) + | UnboxedTuple 0 -> ValBlockType None + | UnboxedTuple 1 -> ValBlockType (Some I32Type) + | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) + | Unreachable -> ValBlockType None let to_string = function | Vanilla -> "Vanilla" @@ -2862,14 +2866,14 @@ module PatCode = struct | CanFail is2 -> CanFail (fun fail_code -> let inner_fail = G.new_depth_label () in let inner_fail_code = compile_unboxed_false ^^ G.branch_to_ inner_fail in - G.labeled_block_ [I32Type] inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ - G.if_ [] G.nop (is2 fail_code) + G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ + G.if_ (ValBlockType None) G.nop (is2 fail_code) ) | CannotFail is2 -> CannotFail ( let inner_fail = G.new_depth_label () in let inner_fail_code = compile_unboxed_false ^^ G.branch_to_ inner_fail in - G.labeled_block_ [I32Type] inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ - G.if_ [] G.nop is2 + G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ + G.if_ (ValBlockType None) G.nop is2 ) let orTrap : patternCode -> G.t = function @@ -2919,7 +2923,7 @@ let compile_binop env op = Syntax.(match op with let compile_relop env op = Syntax.(BoxedInt.lift_unboxed_binary env (match op with | EqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | NeqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [I32Type] compile_unboxed_false compile_unboxed_true + G.if_ (ValBlockType (Some I32Type)) compile_unboxed_false compile_unboxed_true | GeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) | GtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) | LeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) @@ -2957,7 +2961,7 @@ and compile_exp (env : E.t) exp = match exp.it with | DotE (e, ({it = Syntax.Name n;_} as name)) -> StackRep.Vanilla, compile_exp_vanilla env e ^^ - Tagged.branch env [I32Type] ( + Tagged.branch env (ValBlockType (Some I32Type)) ( [ Tagged.Object, Object.load_idx env name ] @ (if E.mode env = DfinityMode then [ Tagged.Reference, actor_fake_object_idx env {name with it = n} ] @@ -3014,7 +3018,7 @@ and compile_exp (env : E.t) exp = match exp.it with StackRep.unit, compile_exp_vanilla env e1 ^^ BoxedInt.unbox env ^^ - G.if_ [] G.nop (G.i (Unreachable @@ exp.at)) + G.if_ (ValBlockType None) G.nop (G.i (Unreachable @@ exp.at)) | UnE (op, e1) -> StackRep.Vanilla, compile_exp_vanilla env e1 ^^ @@ -3036,7 +3040,7 @@ and compile_exp (env : E.t) exp = match exp.it with let code2 = compile_exp_vanilla env e2 in let code3 = compile_exp_vanilla env e3 in code1 ^^ BoxedInt.unbox env ^^ - G.if_ (Lib.List.make 1 I32Type) code2 code3 + G.if_ (StackRep.to_block_type env StackRep.Vanilla) code2 code3 | IsE (e1, e2) -> StackRep.Vanilla, let code1 = compile_exp_vanilla env e1 in @@ -3049,7 +3053,7 @@ and compile_exp (env : E.t) exp = match exp.it with set_j ^^ get_i ^^ - Tagged.branch env [I32Type] + Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Array, G.i_ Drop ^^ BoxedInt.lit_false env ; Tagged.Reference, @@ -3063,7 +3067,7 @@ and compile_exp (env : E.t) exp = match exp.it with (* Equal? *) get_j ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [I32Type] + G.if_ (ValBlockType (Some I32Type)) (BoxedInt.lit_true env) (* Static function id? *) ( get_i ^^ @@ -3080,11 +3084,10 @@ and compile_exp (env : E.t) exp = match exp.it with | LabelE (name, _ty, e) -> (* The value here can come from many places -- the expression, or any of the nested returns. Hard to tell which is the best - stack representation here. Also, our wasm encoder does not - handle multi-value stack returns yet, it seems. + stack representation here. So let’s go with Vanialla. *) StackRep.Vanilla, - G.block_ (StackRep.to_wasm_type StackRep.Vanilla) ( + G.block_ (StackRep.to_block_type env StackRep.Vanilla) ( G.with_current_depth (fun depth -> let env1 = E.add_label env name depth in compile_exp_vanilla env1 e @@ -3097,24 +3100,24 @@ and compile_exp (env : E.t) exp = match exp.it with G.branch_to_ d | LoopE (e, None) -> StackRep.Unreachable, - G.loop_ [] (compile_exp_unit env e ^^ G.i_ (Br (nr 0l)) + G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i_ (Br (nr 0l)) ) ^^ G.i_ Unreachable | LoopE (e1, Some e2) -> StackRep.unit, - G.loop_ [] ( + G.loop_ (ValBlockType None) ( compile_exp_unit env e1 ^^ compile_exp_vanilla env e2 ^^ BoxedInt.unbox env ^^ - G.if_ [] (G.i_ (Br (nr 1l))) G.nop + G.if_ (ValBlockType None) (G.i_ (Br (nr 1l))) G.nop ) | WhileE (e1, e2) -> StackRep.unit, - G.loop_ [] ( + G.loop_ (ValBlockType None) ( compile_exp_vanilla env e1 ^^ BoxedInt.unbox env ^^ - G.if_ [] ( + G.if_ (ValBlockType None) ( compile_exp_unit env e2 ^^ G.i_ (Br (nr 1l)) ) G.nop @@ -3195,7 +3198,7 @@ and compile_exp (env : E.t) exp = match exp.it with code1 ^^ set_i ^^ - G.loop_ [] ( + G.loop_ (ValBlockType None) ( get_i ^^ Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ get_i ^^ @@ -3208,7 +3211,7 @@ and compile_exp (env : E.t) exp = match exp.it with get_oi ^^ compile_null ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [] + G.if_ (ValBlockType None) G.nop ( alloc_code ^^ get_oi ^^ Opt.project ^^ code2 ^^ code3 ^^ G.i_ (Br (nr 1l)) @@ -3305,7 +3308,7 @@ and fill_pat env pat : patternCode = match pat.it with get_i ^^ compile_null ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ [] fail_code + G.if_ (ValBlockType None) fail_code ( get_i ^^ Opt.project ^^ with_fail fail_code code1 @@ -3314,7 +3317,7 @@ and fill_pat env pat : patternCode = match pat.it with | LitP l -> CanFail (fun fail_code -> compile_lit_pat env l ^^ - G.if_ [] G.nop fail_code) + G.if_ (ValBlockType None) G.nop fail_code) | VarP name -> CannotFail (Var.set_val env name.it) | TupP ps -> diff --git a/src/instrList.ml b/src/instrList.ml index fbd618cb60f..c325aa08f27 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -7,7 +7,6 @@ features are * Some simple peephole optimizations. *) -open Wasm_copy.Types open Wasm_copy.Ast open Wasm.Source @@ -65,15 +64,15 @@ let table n f = List.fold_right (^^) (Lib.List.table n f) nop (* Depths-managing combinators *) -let if_ (ty : stack_type) (thn : t) (els : t) : t = +let if_ (ty : block_type) (thn : t) (els : t) : t = fun d rest -> nr (If (ty, to_nested_list d thn, to_nested_list d els)) :: rest -let block_ (ty : stack_type) (body : t) : t = +let block_ (ty : block_type) (body : t) : t = fun d rest -> nr (Block (ty, to_nested_list d body)) :: rest -let loop_ (ty : stack_type) (body : t) : t = +let loop_ (ty : block_type) (body : t) : t = fun d rest -> nr (Loop (ty, to_nested_list d body)) :: rest @@ -100,5 +99,5 @@ let branch_to_ (p : depth) : t = (* Convenience combinations *) -let labeled_block_ (ty : stack_type) depth (body : t) : t = +let labeled_block_ (ty : block_type) depth (body : t) : t = block_ ty (remember_depth depth body) diff --git a/src/wasm_copy/ast.ml b/src/wasm_copy/ast.ml index 0d382e6e0af..bd3c279f5af 100644 --- a/src/wasm_copy/ast.ml +++ b/src/wasm_copy/ast.ml @@ -67,15 +67,17 @@ type var = int32 Wasm.Source.phrase type literal = Wasm.Values.value Wasm.Source.phrase type name = int list +type block_type = VarBlockType of var | ValBlockType of value_type option + type instr = instr' Wasm.Source.phrase and instr' = | Unreachable (* trap unconditionally *) | Nop (* do nothing *) | Drop (* forget a value *) | Select (* branchless conditional *) - | Block of stack_type * instr list (* execute in sequence *) - | Loop of stack_type * instr list (* loop header *) - | If of stack_type * instr list * instr list (* conditional *) + | Block of block_type * instr list (* execute in sequence *) + | Loop of block_type * instr list (* loop header *) + | If of block_type * instr list * instr list (* conditional *) | Br of var (* break to n-th surrounding label *) | BrIf of var (* conditional break *) | BrTable of var list * var (* indexed break *) diff --git a/src/wasm_copy/encodeMap.ml b/src/wasm_copy/encodeMap.ml index ae687771ddd..021eee03674 100644 --- a/src/wasm_copy/encodeMap.ml +++ b/src/wasm_copy/encodeMap.ml @@ -100,6 +100,7 @@ let encode m = let vu32 i = vu64 Int64.(logand (of_int32 i) 0xffffffffL) let vs7 i = vs64 (Int64.of_int i) let vs32 i = vs64 (Int64.of_int32 i) + let vs33 i = vs64 (Wasm.I64_convert.extend_s_i32 i) let f32 x = u32 (Wasm.F32.to_bits x) let f64 x = u64 (Wasm.F64.to_bits x) @@ -139,15 +140,9 @@ let encode m = let elem_type = function | AnyFuncType -> vs7 (-0x10) - let stack_type = function - | [] -> vs7 (-0x40) - | [t] -> value_type t - | _ -> - Code.error Wasm.Source.no_region - "cannot encode stack type with arity > 1 (yet)" - + let stack_type = vec value_type let func_type = function - | FuncType (ins, out) -> vs7 (-0x20); vec value_type ins; vec value_type out + | FuncType (ins, out) -> vs7 (-0x20); stack_type ins; stack_type out let limits vu {min; max} = bool (max <> None); vu min; opt vu max @@ -179,6 +174,11 @@ let encode m = let var x = vu32 x.it + let block_type = function + | VarBlockType x -> vs33 x.it + | ValBlockType None -> vs7 (-0x40) + | ValBlockType (Some t) -> value_type t + let rec instr e = if e.at <> no_region then add_to_map e.at.left.file e.at.left.line e.at.left.column 0 (pos s); @@ -186,10 +186,10 @@ let encode m = | Unreachable -> op 0x00 | Nop -> op 0x01 - | Block (ts, es) -> op 0x02; stack_type ts; list instr es; end_ () - | Loop (ts, es) -> op 0x03; stack_type ts; list instr es; end_ () + | Block (ts, es) -> op 0x02; block_type ts; list instr es; end_ () + | Loop (ts, es) -> op 0x03; block_type ts; list instr es; end_ () | If (ts, es1, es2) -> - op 0x04; stack_type ts; list instr es1; + op 0x04; block_type ts; list instr es1; if es2 <> [] then op 0x05; list instr es2; end_ () From 6be25b1ced6e323b6e7ff216c70da738a2073170 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 10:54:38 +0100 Subject: [PATCH 13/41] Join the stack representations of the branches of an if which leads to nicer code. This needs multi-value support in the Wasm AST. --- src/compile.ml | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 72108627f19..25eb9f3b424 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2809,6 +2809,16 @@ module StackRep = struct | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n | Unreachable -> "Unreachable" + let join (sr1 : t) (sr2 : t) = match sr1, sr2 with + | Unreachable, sr2 -> sr2 + | sr1, Unreachable -> sr1 + | UnboxedTuple n, UnboxedTuple m when n = m -> sr1 + | UnboxedTuple n, UnboxedTuple m -> + Printf.eprintf "Invalid stack rep join (%s, %s)\n" + (to_string sr1) (to_string sr2); sr1 + | _, Vanilla -> Vanilla + | Vanilla, _ -> Vanilla + let drop env (sr_in : t) = match sr_in with | Vanilla -> G.i_ Drop @@ -3033,14 +3043,17 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_vanilla env e1 ^^ compile_exp_vanilla env e2 ^^ compile_relop env op - | IfE (e1, e2, e3) -> - (* Todo: Somehow “join” the stack representations *) - StackRep.Vanilla, - let code1 = compile_exp_vanilla env e1 in - let code2 = compile_exp_vanilla env e2 in - let code3 = compile_exp_vanilla env e3 in - code1 ^^ BoxedInt.unbox env ^^ - G.if_ (StackRep.to_block_type env StackRep.Vanilla) code2 code3 + | IfE (scrut, e1, e2) -> + let code_scrut = compile_exp_vanilla env scrut in + let sr1, code1 = compile_exp env e1 in + let sr2, code2 = compile_exp env e2 in + let sr = StackRep.join sr1 sr2 in + sr, + code_scrut ^^ BoxedInt.unbox env ^^ + G.if_ + (StackRep.to_block_type env sr) + (code1 ^^ StackRep.adjust env sr1 sr) + (code2 ^^ StackRep.adjust env sr2 sr) | IsE (e1, e2) -> StackRep.Vanilla, let code1 = compile_exp_vanilla env e1 in From 9ca47b9958c19edb0628e459266a012b8aaab753 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:07:30 +0100 Subject: [PATCH 14/41] New StackRep: UnboxedInt this means that the compiler produces much less boxing of integers (naturals, booleans) immediately followed by such boxing. --- src/compile.ml | 69 +++++++++++++++++++++++--------------------------- 1 file changed, 32 insertions(+), 37 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 25eb9f3b424..d9f42f08989 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2773,7 +2773,7 @@ module StackRep = struct there are various ways of putting a value onto the stack -- unboxed, tupled etc. *) - type t = Vanilla | UnboxedTuple of int | Unreachable + type t = Vanilla | UnboxedTuple of int | UnboxedInt | Unreachable let unit = UnboxedTuple 0 @@ -2785,13 +2785,6 @@ module StackRep = struct But the users of compile_exp usually want a specific form as well. So they use compile_exp_as, indicating the form they expect. compile_exp_as then does the necessary coercions. - - So far, the stack representations is merely an integer, the arity: - arity = 0: Expression is of type () and nothing is put on the stack - arity = 1: The generic case. Returns a single value (pointer or unboxed - scalar) on the stack - arity > 1: Expression is of tuple types. Puts elements on the stack - To add: Unreachable, Unboxed Int *) let of_arity n = @@ -2799,6 +2792,7 @@ module StackRep = struct let to_block_type env = function | Vanilla -> ValBlockType (Some I32Type) + | UnboxedInt -> ValBlockType (Some I32Type) | UnboxedTuple 0 -> ValBlockType None | UnboxedTuple 1 -> ValBlockType (Some I32Type) | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) @@ -2806,22 +2800,25 @@ module StackRep = struct let to_string = function | Vanilla -> "Vanilla" + | UnboxedInt -> "UnboxedInt" | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n | Unreachable -> "Unreachable" let join (sr1 : t) (sr2 : t) = match sr1, sr2 with | Unreachable, sr2 -> sr2 | sr1, Unreachable -> sr1 + | UnboxedInt, UnboxedInt -> UnboxedInt | UnboxedTuple n, UnboxedTuple m when n = m -> sr1 - | UnboxedTuple n, UnboxedTuple m -> - Printf.eprintf "Invalid stack rep join (%s, %s)\n" - (to_string sr1) (to_string sr2); sr1 | _, Vanilla -> Vanilla | Vanilla, _ -> Vanilla + | _, _ -> + Printf.eprintf "Invalid stack rep join (%s, %s)\n" + (to_string sr1) (to_string sr2); sr1 let drop env (sr_in : t) = match sr_in with | Vanilla -> G.i_ Drop + | UnboxedInt -> G.i_ Drop | UnboxedTuple n -> G.table n (fun _ -> G.i_ Drop) | Unreachable -> G.nop @@ -2832,6 +2829,8 @@ module StackRep = struct | Unreachable, _ -> G.nop | UnboxedTuple n, Vanilla -> Array.from_stack env n | Vanilla, UnboxedTuple n -> Array.to_stack env n + | UnboxedInt, Vanilla -> BoxedInt.box env + | Vanilla, UnboxedInt -> BoxedInt.unbox env | _, _ -> Printf.eprintf "Unknown stack_rep conversion %s -> %s\n" (to_string sr_in) (to_string sr_out); @@ -2896,20 +2895,24 @@ open PatCode (* The actual compiler code that looks at the AST *) let compile_lit env lit = Syntax.(match lit with - | BoolLit false -> BoxedInt.lit_false env - | BoolLit true -> BoxedInt.lit_true env + | BoolLit false -> StackRep.UnboxedInt, compile_unboxed_false + | BoolLit true -> StackRep.UnboxedInt, compile_unboxed_true (* This maps int to int32, instead of a proper arbitrary precision library *) - | IntLit n -> - (try BoxedInt.lit env (Big_int.int32_of_big_int n) + | IntLit n -> StackRep.UnboxedInt, + (try compile_unboxed_const (Big_int.int32_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i_ Unreachable) - | NatLit n -> - (try BoxedInt.lit env (Big_int.int32_of_big_int n) + | NatLit n -> StackRep.UnboxedInt, + (try compile_unboxed_const (Big_int.int32_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i_ Unreachable) - | NullLit -> compile_null - | TextLit t -> Text.lit env t - | _ -> todo "compile_lit" (Arrange.lit lit) G.i_ Unreachable + | NullLit -> StackRep.Vanilla, compile_null + | TextLit t -> StackRep.Vanilla, Text.lit env t + | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Unreachable, G.i_ Unreachable) ) +let compile_lit_as env sr_out lit = + let sr_in, code = compile_lit env lit in + code ^^ StackRep.adjust env sr_in sr_out + let compile_unop env op = Syntax.(match op with | NegOp -> BoxedInt.lift_unboxed_unary env ( set_tmp env ^^ @@ -2949,8 +2952,7 @@ let rec compile_lexp (env : E.t) exp = match exp.it with Var.set_val env var.it | IdxE (e1,e2) -> compile_exp_vanilla env e1 ^^ (* offset to array *) - compile_exp_vanilla env e2 ^^ (* idx *) - BoxedInt.unbox env ^^ + compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) Array.idx env, store_ptr | DotE (e, n) -> @@ -2964,8 +2966,7 @@ and compile_exp (env : E.t) exp = match exp.it with | IdxE (e1, e2) -> StackRep.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to array *) - compile_exp_vanilla env e2 ^^ (* idx *) - BoxedInt.unbox env ^^ + compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) Array.idx env ^^ load_ptr | DotE (e, ({it = Syntax.Name n;_} as name)) -> @@ -3022,12 +3023,10 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_vanilla env e2 ^^ store_code | LitE l -> - StackRep.Vanilla, compile_lit env l | AssertE e1 -> StackRep.unit, - compile_exp_vanilla env e1 ^^ - BoxedInt.unbox env ^^ + compile_exp_as env StackRep.UnboxedInt e1 ^^ G.if_ (ValBlockType None) G.nop (G.i (Unreachable @@ exp.at)) | UnE (op, e1) -> StackRep.Vanilla, @@ -3044,13 +3043,12 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_vanilla env e2 ^^ compile_relop env op | IfE (scrut, e1, e2) -> - let code_scrut = compile_exp_vanilla env scrut in + let code_scrut = compile_exp_as env StackRep.UnboxedInt scrut in let sr1, code1 = compile_exp env e1 in let sr2, code2 = compile_exp env e2 in let sr = StackRep.join sr1 sr2 in sr, - code_scrut ^^ BoxedInt.unbox env ^^ - G.if_ + code_scrut ^^ G.if_ (StackRep.to_block_type env sr) (code1 ^^ StackRep.adjust env sr1 sr) (code2 ^^ StackRep.adjust env sr2 sr) @@ -3121,15 +3119,13 @@ and compile_exp (env : E.t) exp = match exp.it with StackRep.unit, G.loop_ (ValBlockType None) ( compile_exp_unit env e1 ^^ - compile_exp_vanilla env e2 ^^ - BoxedInt.unbox env ^^ + compile_exp_as env StackRep.UnboxedInt e2 ^^ G.if_ (ValBlockType None) (G.i_ (Br (nr 1l))) G.nop ) | WhileE (e1, e2) -> StackRep.unit, G.loop_ (ValBlockType None) ( - compile_exp_vanilla env e1 ^^ - BoxedInt.unbox env ^^ + compile_exp_as env StackRep.UnboxedInt e1 ^^ G.if_ (ValBlockType None) ( compile_exp_unit env e2 ^^ G.i_ (Br (nr 1l)) @@ -3299,12 +3295,11 @@ enabled mutual recursion. and compile_lit_pat env l = match l with | Syntax.NullLit -> - compile_lit env l ^^ + compile_lit_as env StackRep.Vanilla l ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(NatLit _ | IntLit _ | BoolLit _) -> BoxedInt.unbox env ^^ - compile_lit env l ^^ - BoxedInt.unbox env ^^ + compile_lit_as env StackRep.UnboxedInt l ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(TextLit t) -> Text.lit env t ^^ From 1e74dc93295b51ed0623ce226db01211d4d8ab24 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:11:02 +0100 Subject: [PATCH 15/41] Less boxing around IsE --- src/compile.ml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index d9f42f08989..68703975598 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -979,9 +979,6 @@ module BoxedInt = struct let lit env n = compile_unboxed_const n ^^ box env - let lit_false env = lit env 0l - let lit_true env = lit env 1l - let lift_unboxed_unary env op_is = (* unbox argument *) unbox env ^^ @@ -3053,7 +3050,7 @@ and compile_exp (env : E.t) exp = match exp.it with (code1 ^^ StackRep.adjust env sr1 sr) (code2 ^^ StackRep.adjust env sr2 sr) | IsE (e1, e2) -> - StackRep.Vanilla, + StackRep.UnboxedInt, let code1 = compile_exp_vanilla env e1 in let code2 = compile_exp_vanilla env e2 in let (set_i, get_i) = new_local env "is_lhs" in @@ -3066,10 +3063,10 @@ and compile_exp (env : E.t) exp = match exp.it with get_i ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Array, - G.i_ Drop ^^ BoxedInt.lit_false env + G.i_ Drop ^^ compile_unboxed_false ; Tagged.Reference, (* TODO: Implement IsE for actor references? *) - G.i_ Drop ^^ BoxedInt.lit_false env + G.i_ Drop ^^ compile_unboxed_false ; Tagged.Object, (* There are two cases: Either the class is a pointer to the object on the RHS, or it is -- mangled -- the @@ -3079,7 +3076,7 @@ and compile_exp (env : E.t) exp = match exp.it with get_j ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) - (BoxedInt.lit_true env) + compile_unboxed_true (* Static function id? *) ( get_i ^^ Heap.load_field Object.class_position ^^ From 0f5b08e0afed8f7b927d7ca11d481c2590204f36 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:15:24 +0100 Subject: [PATCH 16/41] Less boxing/unboxing around binary operations --- src/compile.ml | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 68703975598..370a9ef4456 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2920,14 +2920,18 @@ let compile_unop env op = Syntax.(match op with | _ -> todo "compile_unop" (Arrange.unop op) G.i_ Unreachable ) +(* This returns a single StackRep, to be used for both arguments and the + result. One could imagine operators that require or produce different StackReps, + but none of these do, so a single value is fine. +*) let compile_binop env op = Syntax.(match op with - | AddOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add))) - | SubOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub))) - | MulOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul))) - | DivOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU))) - | ModOp -> BoxedInt.lift_unboxed_binary env (G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU))) - | CatOp -> Text.concat env - | _ -> todo "compile_binop" (Arrange.binop op) G.i_ Unreachable + | AddOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + | SubOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + | MulOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) + | DivOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) + | ModOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) + | CatOp -> StackRep.Vanilla, Text.concat env + | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Unreachable, G.i_ Unreachable) ) let compile_relop env op = Syntax.(BoxedInt.lift_unboxed_binary env (match op with @@ -3030,10 +3034,11 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_vanilla env e1 ^^ compile_unop env op | BinE (e1, op, e2) -> - StackRep.Vanilla, - compile_exp_vanilla env e1 ^^ - compile_exp_vanilla env e2 ^^ - compile_binop env op + let (sr, code) = compile_binop env op in + sr, + compile_exp_as env sr e1 ^^ + compile_exp_as env sr e2 ^^ + code | RelE (e1, op, e2) -> StackRep.Vanilla, compile_exp_vanilla env e1 ^^ From 08458d2e41581261bfb23cfe609c7c24d7309247 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:18:58 +0100 Subject: [PATCH 17/41] Less unboxing around binary relations --- src/compile.ml | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 370a9ef4456..968ad78e965 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -987,16 +987,6 @@ module BoxedInt = struct (* box result *) box env - let lift_unboxed_binary env op_is = - let (set_i, get_i) = new_local env "n" in - (* unbox both arguments *) - set_i ^^ unbox env ^^ - get_i ^^ unbox env ^^ - (* apply operator *) - op_is ^^ - (* box result *) - box env - end (* BoxedInt *) (* Primitive functions *) @@ -2934,7 +2924,7 @@ let compile_binop env op = Syntax.(match op with | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Unreachable, G.i_ Unreachable) ) -let compile_relop env op = Syntax.(BoxedInt.lift_unboxed_binary env (match op with +let compile_relop env op = Syntax.(StackRep.UnboxedInt, match op with | EqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | NeqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) compile_unboxed_false compile_unboxed_true @@ -2942,7 +2932,7 @@ let compile_relop env op = Syntax.(BoxedInt.lift_unboxed_binary env (match op wi | GtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) | LeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) | LtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) - )) + ) (* compile_lexp is used for expressions on the left of an @@ -3040,10 +3030,11 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_as env sr e2 ^^ code | RelE (e1, op, e2) -> - StackRep.Vanilla, - compile_exp_vanilla env e1 ^^ - compile_exp_vanilla env e2 ^^ - compile_relop env op + let (sr, code) = compile_relop env op in + StackRep.UnboxedInt, + compile_exp_as env sr e1 ^^ + compile_exp_as env sr e2 ^^ + code | IfE (scrut, e1, e2) -> let code_scrut = compile_exp_as env StackRep.UnboxedInt scrut in let sr1, code1 = compile_exp env e1 in From 4f89398698fe72f1ee2cbc1acd3262c59785e767 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:21:23 +0100 Subject: [PATCH 18/41] Less unboxing around unary operations --- src/compile.ml | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 968ad78e965..e8323d3882e 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -979,14 +979,6 @@ module BoxedInt = struct let lit env n = compile_unboxed_const n ^^ box env - let lift_unboxed_unary env op_is = - (* unbox argument *) - unbox env ^^ - (* apply operator *) - op_is ^^ - (* box result *) - box env - end (* BoxedInt *) (* Primitive functions *) @@ -2893,7 +2885,7 @@ let compile_lit env lit = Syntax.(match lit with with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i_ Unreachable) | NullLit -> StackRep.Vanilla, compile_null | TextLit t -> StackRep.Vanilla, Text.lit env t - | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Unreachable, G.i_ Unreachable) + | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Vanilla, G.i_ Unreachable) ) let compile_lit_as env sr_out lit = @@ -2901,13 +2893,16 @@ let compile_lit_as env sr_out lit = code ^^ StackRep.adjust env sr_in sr_out let compile_unop env op = Syntax.(match op with - | NegOp -> BoxedInt.lift_unboxed_unary env ( + | NegOp -> + StackRep.UnboxedInt, set_tmp env ^^ compile_unboxed_zero ^^ get_tmp env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub))) - | PosOp -> G.nop - | _ -> todo "compile_unop" (Arrange.unop op) G.i_ Unreachable + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + | PosOp -> + StackRep.UnboxedInt, + G.nop + | _ -> todo "compile_unop" (Arrange.unop op) (StackRep.Vanilla, G.i_ Unreachable) ) (* This returns a single StackRep, to be used for both arguments and the @@ -2921,7 +2916,7 @@ let compile_binop env op = Syntax.(match op with | DivOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) | ModOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) | CatOp -> StackRep.Vanilla, Text.concat env - | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Unreachable, G.i_ Unreachable) + | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Vanilla, G.i_ Unreachable) ) let compile_relop env op = Syntax.(StackRep.UnboxedInt, match op with @@ -3020,17 +3015,18 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_as env StackRep.UnboxedInt e1 ^^ G.if_ (ValBlockType None) G.nop (G.i (Unreachable @@ exp.at)) | UnE (op, e1) -> - StackRep.Vanilla, - compile_exp_vanilla env e1 ^^ - compile_unop env op + let sr, code = compile_unop env op in + sr, + compile_exp_as env sr e1 ^^ + code | BinE (e1, op, e2) -> - let (sr, code) = compile_binop env op in + let sr, code = compile_binop env op in sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ code | RelE (e1, op, e2) -> - let (sr, code) = compile_relop env op in + let sr, code = compile_relop env op in StackRep.UnboxedInt, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ From f13e13efb6483e14fb9aa995a7b0d422a5919fa2 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:33:13 +0100 Subject: [PATCH 19/41] Correctly drop scrutinee if compile_n_ary_pat encounters `WildP` --- src/compile.ml | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index e8323d3882e..d55cafb10d5 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2762,8 +2762,8 @@ module StackRep = struct the form it chose. But the users of compile_exp usually want a specific form as well. - So they use compile_exp_as, indicating the form they expect. compile_exp_as - then does the necessary coercions. + So they use compile_exp_as, indicating the form they expect. + compile_exp_as then does the necessary coercions. *) let of_arity n = @@ -3247,6 +3247,13 @@ and compile_exp_as env sr_out e = let sr_in, code = compile_exp env e in code ^^ StackRep.adjust env sr_in sr_out +and compile_exp_as_opt env sr_out_o e = + let sr_in, code = compile_exp env e in + code ^^ + match sr_out_o with + | None -> StackRep.drop env sr_in + | Some sr_out -> StackRep.adjust env sr_in sr_out + and compile_exp_vanilla (env : E.t) exp = compile_exp_as env StackRep.Vanilla exp @@ -3369,17 +3376,18 @@ and compile_n_ary_pat env how pat = let arity, fill_code = match pat.it with (* Nothing to match: Do not even put something on the stack *) - | WildP -> StackRep.unit, G.nop + | WildP -> None, G.nop (* The good case: We have a tuple pattern *) | TupP ps when List.length ps <> 1 -> - let sr = StackRep.UnboxedTuple (List.length ps) in + Some (StackRep.UnboxedTuple (List.length ps)), (* We have to fill the pattern in reverse order, to take things off the stack. This is only ok as long as patterns have no side effects. *) - sr, G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) + G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) (* The general case: Create a single value, match that. *) | _ -> - StackRep.Vanilla, orTrap (fill_pat env1 pat) + Some StackRep.Vanilla, + orTrap (fill_pat env1 pat) in (env1, alloc_code, arity, fill_code) (* Used for function patterns @@ -3417,7 +3425,7 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = matc let (pre_env1, alloc_code, pat_arity, fill_code) = compile_n_ary_pat pre_env how p in ( pre_env1, alloc_code, fun env -> StackRep.unit, - compile_exp_as env pat_arity e ^^ + compile_exp_as_opt env pat_arity e ^^ fill_code ) | VarD (name, e) -> From 751f92e7ab042bb34a93dc75e485524b611ce432 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:41:30 +0100 Subject: [PATCH 20/41] Throw in some extra Unreachable to make the Wasm validator happy. E.g. even if two branches of an `IfE` end with a `return`, the wasm validator needs to be told that the code after the `IfE` is unreachable. --- src/compile.ml | 4 +++- test/run/mutrec.as | 10 ++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index d55cafb10d5..95c339d8e80 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2805,7 +2805,9 @@ module StackRep = struct if sr_in = sr_out then G.nop else match sr_in, sr_out with - | Unreachable, _ -> G.nop + | Unreachable, Unreachable -> G.nop + | Unreachable, _ -> G.i_ Unreachable + | UnboxedTuple n, Vanilla -> Array.from_stack env n | Vanilla, UnboxedTuple n -> Array.to_stack env n | UnboxedInt, Vanilla -> BoxedInt.box env diff --git a/test/run/mutrec.as b/test/run/mutrec.as index 24efdffb32c..6ac8014d91c 100644 --- a/test/run/mutrec.as +++ b/test/run/mutrec.as @@ -1,16 +1,18 @@ func even(n : Nat) : Bool { if (n == 0) { return true; - } else + } else { return odd(n-1); - }; + } +}; func odd(n : Nat) : Bool { if (n == 0) { return false; - } else + } else { return even(n-1); - }; + } +}; assert(even(0)); assert(even(2)); From 05e76b0b6a9ad90e11e19f340c04aaf1755342dd Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:47:29 +0100 Subject: [PATCH 21/41] Delete more dead Wasm code in `instrList.optimize`. --- src/instrList.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/instrList.ml b/src/instrList.ml index c325aa08f27..da636d5e35c 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -29,8 +29,9 @@ let optimize : instr list -> instr list = fun is -> (* Eliminate TeeLocal followed by Drop (good for confluence) *) | ({ it = TeeLocal n; _} as i) :: l', { it = Drop; _ } :: r' -> go l' ({i with it = SetLocal n } :: r') - (* Code after Return is dead *) - | _, ({ it = Return; _ } as i) :: _ -> List.rev (i::l) + (* Code after Return, Br or Unreachable is dead *) + | _, ({ it = Return | Br _ | Unreachable; _ } as i) :: _ -> + List.rev (i::l) (* Look further *) | _, i::r' -> go (i::l) r' (* Done looking *) From 16aee16a22206e32538751989a0ab7f05569ed88 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 11:59:34 +0100 Subject: [PATCH 22/41] Remove Binary-Drop-eliminiation in `instrList.optimize` it can change the behaviour. Instead, just unbox in `Bittagged.if_unboxed` if not asked for, and leave it to the user. Actually makes the code a tad easier to understand. --- src/compile.ml | 109 ++++++++++++++++++++++------------------------- src/instrList.ml | 3 -- 2 files changed, 51 insertions(+), 61 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 95c339d8e80..5448d6c13f2 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -606,20 +606,17 @@ module BitTagged = struct Otherwise, leaves it on the stack and executes the second sequence. *) let if_unboxed env retty is1 is2 = - let (set_i, get_i) = new_local env "bittagged" in - set_i ^^ - (* Check bit *) - get_i ^^ + (* Get bit *) compile_unboxed_const 1l ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ + (* Check bit *) compile_unboxed_const 1l ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ retty - ( get_i ^^ - compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) ^^ - is1) - ( get_i ^^ is2) + G.if_ retty is1 is2 + + let untag_scalar env = + compile_unboxed_const 1l ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) let tag = compile_unboxed_const 1l ^^ @@ -677,18 +674,18 @@ module Tagged = struct (* Branches based on the tag of the object pointed to, leaving the object on the stack afterwards. *) let branch_default env retty def (cases : (tag * G.t) list) : G.t = - let (set_i, get_i) = new_local env "tagged" in + let (set_tag, get_tag) = new_local env "tag" in let rec go = function | [] -> def | ((tag, code) :: cases) -> - get_i ^^ - load ^^ + get_tag ^^ compile_unboxed_const (int_of_tag tag) ^^ G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ retty (get_i ^^ code) (go cases) + G.if_ retty code (go cases) in - set_i ^^ + load ^^ + set_tag ^^ go cases let branch env retty (cases : (tag * G.t) list) : G.t = @@ -696,7 +693,8 @@ module Tagged = struct let obj env tag element_instructions : G.t = Heap.obj env (compile_unboxed_const (int_of_tag tag) :: element_instructions) -end + +end (* Tagged *) module Var = struct @@ -973,8 +971,8 @@ module BoxedInt = struct let get_n = G.i_ (GetLocal (nr 0l)) in get_n ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - G.nop - (Heap.load_field payload_field) + (get_n ^^ BitTagged.untag_scalar env) + (get_n ^^ Heap.load_field payload_field) ) let lit env n = compile_unboxed_const n ^^ box env @@ -1815,30 +1813,26 @@ module Serialization = struct get_x ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - ( (* Tagged unboxed value, can be left alone *) - G.i_ Drop ^^ get_x - ) - ( Tagged.branch env (ValBlockType (Some I32Type)) + ( get_x ) + ( get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - (* x still on the stack *) + get_x ^^ Heap.alloc env 2l ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ Heap.memcpy env ^^ get_copy ; Tagged.Reference, - (* x still on the stack *) + get_x ^^ Heap.alloc env 2l ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ Heap.memcpy env ^^ get_copy ; Tagged.Some, - G.i_ Drop ^^ Opt.inject env ( get_x ^^ Opt.project ^^ G.i_ (Call (nr (E.built_in env "serialize_go"))) ) ; Tagged.ObjInd, - G.i_ Drop ^^ Tagged.obj env Tagged.ObjInd [ get_x ^^ Heap.load_field 1l ^^ G.i_ (Call (nr (E.built_in env "serialize_go"))) @@ -1846,6 +1840,7 @@ module Serialization = struct ; Tagged.Array, begin let (set_len, get_len) = new_local env "len" in + get_x ^^ Heap.load_field Array.len_field ^^ set_len ^^ @@ -1879,6 +1874,7 @@ module Serialization = struct ; Tagged.Text, begin let (set_len, get_len) = new_local env "len" in + get_x ^^ Heap.load_field Text.len_field ^^ (* get length in words *) compile_add_const 3l ^^ @@ -1902,6 +1898,7 @@ module Serialization = struct ; Tagged.Object, begin let (set_len, get_len) = new_local env "len" in + get_x ^^ Heap.load_field Object.size_field ^^ set_len ^^ @@ -1973,12 +1970,12 @@ module Serialization = struct let get_ptr_offset = G.i_ (GetLocal (nr 1l)) in get_loc ^^ load_ptr ^^ + set_tmp env ^^ + get_tmp env ^^ BitTagged.if_unboxed env (ValBlockType None) (* nothing to do *) - ( G.i_ Drop ) - ( set_tmp env ^^ - - get_loc ^^ + ( G.nop ) + ( get_loc ^^ get_tmp env ^^ get_ptr_offset ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ @@ -1993,40 +1990,35 @@ module Serialization = struct get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.Reference, - G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.Some, - G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.ObjInd, - G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.MutBox, - G.i_ Drop ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.Array, - (* x still on the stack *) + get_x ^^ Heap.load_field Array.len_field ^^ compile_add_const Array.header_size ^^ compile_mul_const Heap.word_size ; Tagged.Text, - (* x still on the stack *) + get_x ^^ Heap.load_field Text.len_field ^^ compile_add_const 3l ^^ compile_divU_const Heap.word_size ^^ compile_add_const Text.header_size ^^ compile_mul_const Heap.word_size ; Tagged.Object, - (* x still on the stack *) + get_x ^^ Heap.load_field Object.size_field ^^ compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ; Tagged.Closure, - (* x still on the stack *) + get_x ^^ Heap.load_field Closure.len_field ^^ compile_add_const Closure.header_size ^^ compile_mul_const Heap.word_size @@ -2057,19 +2049,22 @@ module Serialization = struct get_x ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.MutBox, + get_x ^^ compile_add_const (Int32.mul Heap.word_size Var.mutbox_field) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ; Tagged.Some, + get_x ^^ compile_add_const (Int32.mul Heap.word_size Opt.payload_field) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ; Tagged.ObjInd, + get_x ^^ compile_add_const (Int32.mul Heap.word_size 1l) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ; Tagged.Array, - (* x still on the stack *) + get_x ^^ Heap.load_field Array.len_field ^^ (* Adjust fields *) from_0_to_n env (fun get_i -> @@ -2080,7 +2075,7 @@ module Serialization = struct mk_code get_ptr_loc ) ; Tagged.Object, - (* x still on the stack *) + get_x ^^ Heap.load_field Object.size_field ^^ from_0_to_n env (fun get_i -> @@ -2095,7 +2090,7 @@ module Serialization = struct mk_code get_ptr_loc ) ; Tagged.Closure, - (* x still on the stack *) + get_x ^^ Heap.load_field Closure.len_field ^^ from_0_to_n env (fun get_i -> @@ -2137,9 +2132,6 @@ module Serialization = struct get_x ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, - (* x still on the stack *) - G.i_ Drop ^^ - (* Adjust reference *) get_tbl_area ^^ get_i ^^ compile_mul_const Heap.word_size ^^ @@ -2171,8 +2163,7 @@ module Serialization = struct get_x ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, - (* x still on the stack *) - + get_x ^^ (* Adjust reference *) get_x ^^ Heap.load_field 1l ^^ @@ -2207,8 +2198,7 @@ module Serialization = struct (* We have a bit-tagged raw value. Put this into a singleton databuf, which will be recognized as such by its size. *) - ( G.i_ Drop ^^ - Heap.alloc env 1l ^^ + ( Heap.alloc env 1l ^^ get_x ^^ store_ptr ^^ @@ -2220,7 +2210,8 @@ module Serialization = struct compile_unboxed_const 0l ^^ set_tbl_size ) (* We have real data on the heap. Copy. *) - ( serialize_go env ^^ + ( get_x ^^ + serialize_go env ^^ G.i_ Drop ^^ (* Remember the end *) @@ -2384,7 +2375,7 @@ module GC = struct get_obj ^^ (* If this is an unboxed scalar, ignore it *) - BitTagged.if_unboxed env (ValBlockType None) (G.i_ Drop ^^ get_end_to_space ^^ G.i_ Return) (G.i_ Drop) ^^ + BitTagged.if_unboxed env (ValBlockType None) (get_end_to_space ^^ G.i_ Return) G.nop ^^ (* If this is static, ignore it *) get_obj ^^ @@ -2396,8 +2387,6 @@ module GC = struct get_obj ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Indirection, - G.i_ Drop ^^ - (* Update pointer *) get_ptr_loc ^^ get_ptr_loc ^^ load_ptr ^^ Heap.load_field 1l ^^ @@ -2960,14 +2949,17 @@ and compile_exp (env : E.t) exp = match exp.it with | DotE (e, ({it = Syntax.Name n;_} as name)) -> StackRep.Vanilla, compile_exp_vanilla env e ^^ + let (set_o, get_o) = new_local env "o" in + set_o ^^ + get_o ^^ Tagged.branch env (ValBlockType (Some I32Type)) ( - [ Tagged.Object, Object.load_idx env name ] @ + [ Tagged.Object, get_o ^^ Object.load_idx env name ] @ (if E.mode env = DfinityMode - then [ Tagged.Reference, actor_fake_object_idx env {name with it = n} ] + then [ Tagged.Reference, get_o ^^ actor_fake_object_idx env {name with it = n} ] else []) @ match Array.fake_object_idx env n with | None -> [] - | Some code -> [ Tagged.Array, code ] + | Some code -> [ Tagged.Array, get_o ^^ code ] ) (* We only allow prims of certain shapes, as they occur in the prelude *) (* Binary prims *) @@ -3057,14 +3049,15 @@ and compile_exp (env : E.t) exp = match exp.it with get_i ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Array, - G.i_ Drop ^^ compile_unboxed_false + compile_unboxed_false ; Tagged.Reference, (* TODO: Implement IsE for actor references? *) - G.i_ Drop ^^ compile_unboxed_false + compile_unboxed_false ; Tagged.Object, (* There are two cases: Either the class is a pointer to the object on the RHS, or it is -- mangled -- the function id stored therein *) + get_i ^^ Heap.load_field Object.class_position ^^ (* Equal? *) get_j ^^ diff --git a/src/instrList.ml b/src/instrList.ml index da636d5e35c..a953e8b58ac 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -20,9 +20,6 @@ let optimize : instr list -> instr list = fun is -> (* The following is not semantics preserving for general Wasm (due to out-of-memory) but should be fine for the code that we create *) | { it = Load _; _} :: l', { it = Drop; _ } :: _ -> go l' r - (* This can erase the arguments in a cascading manner. *) - | { it = Binary _; _} :: l', ({ it = Drop; _ } as i) :: r' -> - go l' (i :: i :: r') (* Introduce TeeLocal *) | { it = SetLocal n1; _} :: l', ({ it = GetLocal n2; _ } as i) :: r' when n1 = n2 -> go l' ({i with it = TeeLocal n2 } :: r') From 81cc2c9b2013ae23a0b30b1f642aa16cd74c98eb Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 20 Dec 2018 14:35:36 +0100 Subject: [PATCH 23/41] Get rid of `tmp` local in all functions and always create new named locals when needed --- src/compile.ml | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 5448d6c13f2..69d41e36500 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -126,7 +126,6 @@ module E = struct let mode (e : t) = e.mode (* Indices of local variables *) - let tmp_local env : var = nr (env.n_param) (* first local after the params *) let unary_closure_local env : var = nr 0l (* first param *) (* The initial global environment *) @@ -161,8 +160,8 @@ module E = struct (* Resetting the environment for a new function *) let mk_fun_env env n_param n_res = { env with - locals = ref [I32Type]; (* the first tmp local *) - local_names = ref [ n_param , "tmp" ]; + locals = ref []; + local_names = ref []; n_param; n_res; (* We keep all local vars that are bound to known functions or globals *) @@ -330,9 +329,6 @@ let compile_divU_const = compile_op_const Wasm_copy.Ast.I32Op.DivU (* Locals *) -let set_tmp env = G.i_ (SetLocal (E.tmp_local env)) -let get_tmp env = G.i_ (GetLocal (E.tmp_local env)) - let new_local_ env name = let i = E.add_anon_local env I32Type in E.add_local_name env i name; @@ -1341,7 +1337,7 @@ module Array = struct Object.lit_raw env1 [ (nr_ (Syntax.Name "next"), - fun _ -> Var.field_box env get_ni) ] + fun _ -> Var.field_box env1 get_ni) ] ) in E.define_built_in env "array_keys_next" @@ -1355,7 +1351,7 @@ module Array = struct (fun () -> mk_next_fun (fun env1 get_array get_boxed_i get_i -> get_array ^^ get_i ^^ - idx env ^^ + idx env1 ^^ load_ptr )); E.define_built_in env "array_vals" @@ -1968,15 +1964,16 @@ module Serialization = struct Func.share_code env "shift_pointer_at" ["loc"; "ptr_offset"] [] (fun env -> let get_loc = G.i_ (GetLocal (nr 0l)) in let get_ptr_offset = G.i_ (GetLocal (nr 1l)) in + let (set_ptr, get_ptr) = new_local env "ptr" in get_loc ^^ load_ptr ^^ - set_tmp env ^^ - get_tmp env ^^ + set_ptr ^^ + get_ptr ^^ BitTagged.if_unboxed env (ValBlockType None) (* nothing to do *) ( G.nop ) ( get_loc ^^ - get_tmp env ^^ + get_ptr ^^ get_ptr_offset ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ store_ptr @@ -2886,10 +2883,12 @@ let compile_lit_as env sr_out lit = let compile_unop env op = Syntax.(match op with | NegOp -> StackRep.UnboxedInt, - set_tmp env ^^ - compile_unboxed_zero ^^ - get_tmp env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + Func.share_code env "neg" ["n"] [I32Type] (fun env -> + let get_n = G.i_ (GetLocal (nr 0l)) in + compile_unboxed_zero ^^ + get_n ^^ + G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + ) | PosOp -> StackRep.UnboxedInt, G.nop From 82cae9bd14cb479a96e19738115a65db74894b10 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 22 Dec 2018 17:04:57 +0100 Subject: [PATCH 24/41] More systematic handling of source locations in the compiler by adding an appropriate combinator to the `InstrList` module, and setting it at crucial positions in `Compile`. Makes the code in `compile.ml` actually nicer (no `G.i_` / `G.i` any more), and should produce a much more detailed and comprehensive source map than before. In that sense, a little Christmas present for @paulyoung. --- src/compile.ml | 640 ++++++++++++++++++++++++----------------------- src/instrList.ml | 54 ++-- 2 files changed, 360 insertions(+), 334 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 69d41e36500..b345f9c2cad 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3,6 +3,8 @@ open Wasm_copy.Types open Source open Ir +(* Re-shadow Source.(@@), to get Pervasives.(@@) *) +let (@@) = Pervasives.(@@) open Wasm_copy.CustomModule @@ -12,18 +14,9 @@ let (^^) = G.(^^) (* is this how we do that? *) (* Helper functions to produce annotated terms *) let nr x = { Wasm.Source.it = x; Wasm.Source.at = Wasm.Source.no_region } -let (@@) x at = - let left = { Wasm.Source.file = at.left.file; - Wasm.Source.line = at.left.line; - Wasm.Source.column = at.left.column } in - let right = { Wasm.Source.file = at.right.file; - Wasm.Source.line = at.right.line; - Wasm.Source.column = at.right.column } in - let at = { Wasm.Source.left = left; Wasm.Source.right = right } in - { Wasm.Source.it = x; Wasm.Source.at = at } +(* Convert between region representations *) let nr_ x = { it = x; at = no_region; note = () } - let todo fn se x = Printf.eprintf "%s: %s" fn (Wasm.Sexpr.to_string 80 se); x (* The compiler environment. @@ -310,7 +303,7 @@ end (* Function called compile_* return a list of instructions (and maybe other stuff) *) -let compile_unboxed_const i = G.i_ (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) +let compile_unboxed_const i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) let compile_unboxed_true = compile_unboxed_const 1l let compile_unboxed_false = compile_unboxed_const 0l let compile_unboxed_zero = compile_unboxed_const 0l @@ -321,7 +314,7 @@ let compile_null = compile_unboxed_const 3l (* Some common arithmetic *) let compile_op_const op i = compile_unboxed_const i ^^ - G.i_ (Binary (Wasm.Values.I32 op)) + G.i (Binary (Wasm.Values.I32 op)) let compile_add_const = compile_op_const Wasm_copy.Ast.I32Op.Add let compile_sub_const = compile_op_const Wasm_copy.Ast.I32Op.Sub let compile_mul_const = compile_op_const Wasm_copy.Ast.I32Op.Mul @@ -332,8 +325,8 @@ let compile_divU_const = compile_op_const Wasm_copy.Ast.I32Op.DivU let new_local_ env name = let i = E.add_anon_local env I32Type in E.add_local_name env i name; - ( G.i_ (SetLocal (nr i)) - , G.i_ (GetLocal (nr i)) + ( G.i (SetLocal (nr i)) + , G.i (GetLocal (nr i)) , i ) @@ -346,7 +339,7 @@ let new_local env name = (* expects a number on the stack. Iterates from zero t below that number *) let compile_while cond body = G.loop_ (ValBlockType None) ( - cond ^^ G.if_ (ValBlockType None) (body ^^ G.i_ (Br (nr 1l))) G.nop + cond ^^ G.if_ (ValBlockType None) (body ^^ G.i (Br (nr 1l))) G.nop ) let from_0_to_n env mk_body = @@ -359,7 +352,7 @@ let from_0_to_n env mk_body = compile_while ( get_i ^^ get_n ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ) ( mk_body get_i ^^ @@ -372,10 +365,10 @@ let from_0_to_n env mk_body = (* Heap and allocations *) let load_ptr : G.t = - G.i_ (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) + G.i (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) let store_ptr : G.t = - G.i_ (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) + G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) module Func = struct @@ -395,7 +388,7 @@ module Func = struct (* (Almost) transparently lift code into a function and call this function. *) let share_code env name params retty mk_body = define_built_in env name params retty mk_body; - G.i_ (Call (nr (E.built_in env name))) + G.i (Call (nr (E.built_in env name))) end (* Func *) @@ -415,24 +408,24 @@ module Heap = struct let dyn_alloc_words env = Func.share_code env "alloc_words" ["n"] [I32Type] (fun env -> - let get_n = G.i_ (GetLocal (nr 0l)) in + let get_n = G.i (GetLocal (nr 0l)) in (* expect the size (in words), returns the pointer *) - G.i_ (GetGlobal (nr heap_ptr)) ^^ + G.i (GetGlobal (nr heap_ptr)) ^^ (* Update heap pointer *) get_n ^^ compile_mul_const word_size ^^ (* Add to old heap value *) - G.i_ (GetGlobal (nr heap_ptr)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (SetGlobal (nr heap_ptr)) + G.i (GetGlobal (nr heap_ptr)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (SetGlobal (nr heap_ptr)) ) let dyn_alloc_bytes env = Func.share_code env "alloc_bytes" ["n"] [I32Type] (fun env -> - let get_n = G.i_ (GetLocal (nr 0l)) in + let get_n = G.i (GetLocal (nr 0l)) in get_n ^^ (* Round up to next multiple of the word size and convert to words *) @@ -451,10 +444,10 @@ module Heap = struct (* Heap objects *) let load_field (i : int32) : G.t = - G.i_ (Load {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + G.i (Load {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) let store_field (i : int32) : G.t = - G.i_ (Store {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + G.i (Store {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) (* Create a heap object with instructions that fill in each word *) let obj env element_instructions : G.t = @@ -479,21 +472,21 @@ module Heap = struct let memcpy env = Func.share_code env "memcpy" ["from"; "two"; "n"] [] (fun env -> - let get_from = G.i_ (GetLocal (nr 0l)) in - let get_to = G.i_ (GetLocal (nr 1l)) in - let get_n = G.i_ (GetLocal (nr 2l)) in + let get_from = G.i (GetLocal (nr 0l)) in + let get_to = G.i (GetLocal (nr 1l)) in + let get_n = G.i (GetLocal (nr 2l)) in get_n ^^ from_0_to_n env (fun get_i -> get_to ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_from ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ - G.i_ (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ) ) @@ -513,28 +506,28 @@ module ElemHeap = struct reference table *) let remember_reference env : G.t = Func.share_code env "remember_reference" ["ref"] [I32Type] (fun env -> - let get_ref = G.i_ (GetLocal (nr 0l)) in + let get_ref = G.i (GetLocal (nr 0l)) in (* Return index *) - G.i_ (GetGlobal (nr ref_counter)) ^^ + G.i (GetGlobal (nr ref_counter)) ^^ (* Store reference *) - G.i_ (GetGlobal (nr ref_counter)) ^^ + G.i (GetGlobal (nr ref_counter)) ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ store_ptr ^^ (* Bump counter *) - G.i_ (GetGlobal (nr ref_counter)) ^^ + G.i (GetGlobal (nr ref_counter)) ^^ compile_add_const 1l ^^ - G.i_ (SetGlobal (nr ref_counter)) + G.i (SetGlobal (nr ref_counter)) ) (* Assumes a index into the table on the stack, and replaces it with the reference *) let recall_reference env : G.t = Func.share_code env "recall_reference" ["ref_idx"] [I32Type] (fun env -> - let get_ref_idx = G.i_ (GetLocal (nr 0l)) in + let get_ref_idx = G.i (GetLocal (nr 0l)) in get_ref_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ @@ -560,7 +553,7 @@ module ClosureTable = struct reference table *) let remember_closure env : G.t = Func.share_code env "remember_closure" ["ptr"] [I32Type] (fun env -> - let get_ptr = G.i_ (GetLocal (nr 0l)) in + let get_ptr = G.i (GetLocal (nr 0l)) in (* Return index *) get_counter ^^ @@ -583,7 +576,7 @@ module ClosureTable = struct (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) let recall_closure env : G.t = Func.share_code env "recall_closure" ["closure_idx"] [I32Type] (fun env -> - let get_closure_idx = G.i_ (GetLocal (nr 0l)) in + let get_closure_idx = G.i (GetLocal (nr 0l)) in get_closure_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ @@ -604,21 +597,21 @@ module BitTagged = struct let if_unboxed env retty is1 is2 = (* Get bit *) compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ (* Check bit *) compile_unboxed_const 1l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ retty is1 is2 let untag_scalar env = compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) let tag = compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Shl)) ^^ compile_unboxed_const 1l ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Or)) + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Or)) end (* BitTagged *) @@ -677,7 +670,7 @@ module Tagged = struct | ((tag, code) :: cases) -> get_tag ^^ compile_unboxed_const (int_of_tag tag) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ retty code (go cases) in load ^^ @@ -685,7 +678,7 @@ module Tagged = struct go cases let branch env retty (cases : (tag * G.t) list) : G.t = - branch_default env retty (G.i_ Unreachable) cases + branch_default env retty (G.i Unreachable) cases let obj env tag element_instructions : G.t = Heap.obj env (compile_unboxed_const (int_of_tag tag) :: element_instructions) @@ -722,11 +715,11 @@ module Var = struct (* Stores the payload *) let set_val env var = match E.lookup_var env var with | Some (Local i) -> - G.i_ (SetLocal (nr i)) + G.i (SetLocal (nr i)) | Some (HeapInd (i, off)) -> let (set_new_val, get_new_val) = new_local env "new_val" in set_new_val ^^ - G.i_ (GetLocal (nr i)) ^^ + G.i (GetLocal (nr i)) ^^ get_new_val ^^ Heap.store_field off | Some (Static i) -> @@ -735,45 +728,45 @@ module Var = struct compile_unboxed_const i ^^ get_new_val ^^ store_ptr - | Some (Deferred d) -> G.i_ Unreachable - | None -> G.i_ Unreachable + | Some (Deferred d) -> G.i Unreachable + | None -> G.i Unreachable (* Returns the payload *) let get_val env var = match E.lookup_var env var with - | Some (Local i) -> G.i_ (GetLocal (nr i)) - | Some (HeapInd (i, off)) -> G.i_ (GetLocal (nr i)) ^^ Heap.load_field off + | Some (Local i) -> G.i (GetLocal (nr i)) + | Some (HeapInd (i, off)) -> G.i (GetLocal (nr i)) ^^ Heap.load_field off | Some (Static i) -> compile_unboxed_const i ^^ load_ptr | Some (Deferred d) -> d.allocate env - | None -> G.i_ Unreachable + | None -> G.i Unreachable (* Returns the value to put in the closure, and code to restore it, including adding to the environment *) let capture env var : G.t * (E.t -> (E.t * G.t)) = match E.lookup_var env var with | Some (Local i) -> - ( G.i_ (GetLocal (nr i)) + ( G.i (GetLocal (nr i)) , fun env1 -> let (env2, j) = E.add_direct_local env1 var in - let restore_code = G.i_ (SetLocal (nr j)) + let restore_code = G.i (SetLocal (nr j)) in (env2, restore_code) ) | Some (HeapInd (i, off)) -> - ( G.i_ (GetLocal (nr i)) + ( G.i (GetLocal (nr i)) , fun env1 -> let (env2, j) = E.add_local_with_offset env1 var off in - let restore_code = G.i_ (SetLocal (nr j)) + let restore_code = G.i (SetLocal (nr j)) in (env2, restore_code) ) | Some (Static i) -> - ( compile_null , fun env1 -> (E.add_local_static env1 var i, G.i_ Drop)) + ( compile_null , fun env1 -> (E.add_local_static env1 var i, G.i Drop)) | Some (Deferred d) -> - ( compile_null , fun env1 -> (E.add_local_deferred env1 var d, G.i_ Drop)) - | None -> (G.i_ Unreachable, fun env1 -> (env1, G.i_ Unreachable)) + ( compile_null , fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) + | None -> (G.i Unreachable, fun env1 -> (env1, G.i Unreachable)) (* Returns a pointer to a heap allocated box for this. (either a mutbox, if already mutable, or a freshly allocated box *) let get_val_ptr env var = match E.lookup_var env var with - | Some (HeapInd (i, 1l)) -> G.i_ (GetLocal (nr i)) + | Some (HeapInd (i, 1l)) -> G.i (GetLocal (nr i)) | _ -> field_box env (get_val env var) end (* Var *) @@ -893,7 +886,7 @@ module AllocHow = struct let (env1, i) = E.add_local_with_offset env name 1l in let alloc_code = Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i_ (SetLocal (nr i)) in + G.i (SetLocal (nr i)) in (env1, alloc_code) | _ -> (env, G.nop) @@ -915,7 +908,7 @@ module Closure = struct let first_captured = header_size - let load_the_closure = G.i_ (GetLocal (nr 0l)) + let load_the_closure = G.i (GetLocal (nr 0l)) let load_closure i = load_the_closure ^^ Heap.load_field (Int32.add first_captured i) @@ -934,7 +927,7 @@ module Closure = struct (* get the table index *) Heap.load_field funptr_field ^^ (* All done: Call! *) - G.i_ (CallIndirect (nr (ty env cc))) + G.i (CallIndirect (nr (ty env cc))) let fixed_closure env fi fields = Tagged.obj env Tagged.Closure @@ -956,15 +949,15 @@ module BoxedInt = struct let payload_field = Int32.add Tagged.header_size 0l let box env = Func.share_code env "box_int" ["n"] [I32Type] (fun env -> - let get_n = G.i_ (GetLocal (nr 0l)) in + let get_n = G.i (GetLocal (nr 0l)) in get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 5)) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ G.if_ (ValBlockType (Some I32Type)) (get_n ^^ BitTagged.tag) - (Tagged.obj env Tagged.Int [ G.i_ (GetLocal (nr 0l)) ]) + (Tagged.obj env Tagged.Int [ G.i (GetLocal (nr 0l)) ]) ) let unbox env = Func.share_code env "unbox_int" ["n"] [I32Type] (fun env -> - let get_n = G.i_ (GetLocal (nr 0l)) in + let get_n = G.i (GetLocal (nr 0l)) in get_n ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) (get_n ^^ BitTagged.untag_scalar env) @@ -984,12 +977,12 @@ module Prim = struct get_i ^^ BoxedInt.unbox env ^^ compile_unboxed_zero ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ^^ G.if_ (ValBlockType (Some I32Type)) ( compile_unboxed_zero ^^ get_i ^^ BoxedInt.unbox env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ BoxedInt.box env ) ( get_i ) @@ -1069,8 +1062,8 @@ module Object = struct (* Returns a pointer to the object field *) let idx_hash env = Func.share_code env "obj_idx" ["x"; "hash"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in - let get_hash = G.i_ (GetLocal (nr 1l)) in + let get_x = G.i (GetLocal (nr 0l)) in + let get_hash = G.i (GetLocal (nr 1l)) in let (set_f, get_f) = new_local env "f" in let (set_r, get_r) = new_local env "r" in @@ -1083,13 +1076,13 @@ module Object = struct compile_add_const header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_f ^^ get_f ^^ Heap.load_field 0l ^^ (* the hash field *) get_hash ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType None) ( get_f ^^ compile_add_const Heap.word_size ^^ @@ -1136,8 +1129,8 @@ module Text = struct (* Two strings on stack *) let concat env = Func.share_code env "concat" ["x"; "y"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in - let get_y = G.i_ (GetLocal (nr 1l)) in + let get_x = G.i (GetLocal (nr 0l)) in + let get_y = G.i (GetLocal (nr 1l)) in let (set_z, get_z) = new_local env "z" in let (set_len1, get_len1) = new_local env "len1" in let (set_len2, get_len2) = new_local env "len2" in @@ -1149,8 +1142,8 @@ module Text = struct compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ get_len2 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ Heap.dyn_alloc_bytes env ^^ set_z ^^ @@ -1161,7 +1154,7 @@ module Text = struct get_z ^^ get_len1 ^^ get_len2 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ Heap.store_field len_field ^^ (* Copy first string *) @@ -1182,7 +1175,7 @@ module Text = struct get_z ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_len2 ^^ @@ -1194,8 +1187,8 @@ module Text = struct (* Two strings on stack *) let compare env = Func.share_code env "Text.compare" ["x"; "y"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in - let get_y = G.i_ (GetLocal (nr 1l)) in + let get_x = G.i (GetLocal (nr 0l)) in + let get_y = G.i (GetLocal (nr 1l)) in let (set_len1, get_len1) = new_local env "len1" in let (set_len2, get_len2) = new_local env "len2" in @@ -1204,8 +1197,8 @@ module Text = struct get_len1 ^^ get_len2 ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i_ Return) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i Return) ^^ (* We could do word-wise comparisons if we know that the trailing bytes are zeroed *) @@ -1214,17 +1207,17 @@ module Text = struct get_x ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ get_y ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i_ Return) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i Return) ) ^^ compile_unboxed_true ) @@ -1239,22 +1232,22 @@ module Array = struct (* Dynamic array access. Returns the address of the field. Does bounds checking *) let idx env = Func.share_code env "Array.idx" ["array"; "idx"] [I32Type] (fun env -> - let get_array = G.i_ (GetLocal (nr 0l)) in - let get_idx = G.i_ (GetLocal (nr 1l)) in + let get_array = G.i (GetLocal (nr 0l)) in + let get_idx = G.i (GetLocal (nr 1l)) in (* No need to check the lower bound, we interpret is as unsigned *) (* Check the upper bound *) get_idx ^^ get_array ^^ Heap.load_field len_field ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ - G.if_ (ValBlockType None) G.nop (G.i_ Unreachable) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ get_idx ^^ compile_add_const header_size ^^ compile_mul_const element_size ^^ get_array ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ) (* Expects on the stack the pointer to the array. *) @@ -1264,8 +1257,8 @@ module Array = struct let common_funcs env = let get_array_object = Closure.load_closure 0l in - let get_first_arg = G.i_ (GetLocal (nr 1l)) in - let get_second_arg = G.i_ (GetLocal (nr 2l)) in + let get_first_arg = G.i (GetLocal (nr 1l)) in + let get_second_arg = G.i (GetLocal (nr 2l)) in E.define_built_in env "array_get" (fun () -> Func.of_body env ["clos"; "idx"] [I32Type] (fun env1 -> @@ -1308,7 +1301,7 @@ module Array = struct Closure.load_closure 1l ^^ (* Get length *) Heap.load_field len_field ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (* Then *) compile_null @@ -1453,16 +1446,16 @@ module Array = struct let name = Printf.sprintf "to_%i_tuple" n in let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in Func.share_code env name args [I32Type] (fun env -> - lit env (Lib.List.table n (fun i -> G.i_ (GetLocal (nr (Int32.of_int i))))) + lit env (Lib.List.table n (fun i -> G.i (GetLocal (nr (Int32.of_int i))))) ) (* Takes an argument tuple and puts the elements on the stack: *) let to_stack env n = - if n = 0 then G.i_ Drop else + if n = 0 then G.i Drop else let name = Printf.sprintf "from_%i_tuple" n in let retty = Lib.List.make n I32Type in Func.share_code env name ["tup"] retty (fun env -> - let get_tup = G.i_ (GetLocal (nr 0l)) in + let get_tup = G.i (GetLocal (nr 0l)) in G.table n (fun i -> get_tup ^^ load_n (Int32.of_int i)) ) @@ -1603,7 +1596,7 @@ module Dfinity = struct let compile_databuf_of_text env = Func.share_code env "databuf_of_text" ["string"] [I32Type] (fun env -> - let get_i = G.i_ (GetLocal (nr 0l)) in + let get_i = G.i (GetLocal (nr 0l)) in (* Calculate the offset *) get_i ^^ @@ -1613,7 +1606,7 @@ module Dfinity = struct Heap.load_field (Text.len_field) ^^ (* Externalize *) - G.i_ (Call (nr (data_externalize_i env))) + G.i (Call (nr (data_externalize_i env))) ) let compile_databuf_of_bytes env (bytes : string) = @@ -1622,29 +1615,29 @@ module Dfinity = struct (* For debugging *) let _compile_static_print env s = compile_databuf_of_bytes env s ^^ - G.i_ (Call (nr (test_print_i env))) + G.i (Call (nr (test_print_i env))) let _compile_print_int env = - G.i_ (Call (nr (test_show_i32_i env))) ^^ - G.i_ (Call (nr (test_print_i env))) ^^ + G.i (Call (nr (test_show_i32_i env))) ^^ + G.i (Call (nr (test_print_i env))) ^^ _compile_static_print env "\n" let prim_printInt env = if E.mode env = DfinityMode then BoxedInt.unbox env ^^ - G.i_ (Call (nr (test_show_i32_i env))) ^^ - G.i_ (Call (nr (test_print_i env))) + G.i (Call (nr (test_show_i32_i env))) ^^ + G.i (Call (nr (test_print_i env))) else - G.i_ Unreachable + G.i Unreachable let prim_print env = if E.mode env = DfinityMode then compile_databuf_of_text env ^^ (* Call print *) - G.i_ (Call (nr (test_print_i env))) + G.i (Call (nr (test_print_i env))) else - G.i_ Unreachable + G.i Unreachable let default_exports env = (* these export seems to be wanted by the hypervisor/v8 *) @@ -1661,11 +1654,11 @@ module Dfinity = struct (* Create an empty message *) let empty_f = Func.of_body env [] [] (fun env1 -> (* Set up memory *) - G.i_ (Call (nr (E.built_in env "restore_mem"))) ^^ + G.i (Call (nr (E.built_in env "restore_mem"))) ^^ (* Collect garbage *) - G.i_ (Call (nr (E.built_in env "collect"))) ^^ + G.i (Call (nr (E.built_in env "collect"))) ^^ (* Save memory *) - G.i_ (Call (nr (E.built_in env "save_mem"))) + G.i (Call (nr (E.built_in env "save_mem"))) ) in let fi = E.add_fun env empty_f "start_stub" in E.add_export env (nr { @@ -1709,61 +1702,61 @@ module OrthogonalPersistence = struct Func.define_built_in env "restore_mem" [] [] (fun env1 -> let (set_i, get_i) = new_local env1 "len" in - G.i_ (GetGlobal (nr mem_global)) ^^ - G.i_ (Call (nr (Dfinity.data_length_i env1))) ^^ + G.i (GetGlobal (nr mem_global)) ^^ + G.i (Call (nr (Dfinity.data_length_i env1))) ^^ set_i ^^ get_i ^^ compile_unboxed_const 0l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType None) (* First run, call the start function *) - ( G.i_ (Call (nr start_funid)) ) + ( G.i (Call (nr start_funid)) ) (* Subsequent run *) ( (* Set heap pointer based on databuf length *) get_i ^^ compile_add_const ElemHeap.table_end ^^ - G.i_ (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (SetGlobal (nr Heap.heap_ptr)) ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ get_i ^^ - G.i_ (GetGlobal (nr mem_global)) ^^ + G.i (GetGlobal (nr mem_global)) ^^ compile_unboxed_zero ^^ - G.i_ (Call (nr (Dfinity.data_internalize_i env1))) ^^ + G.i (Call (nr (Dfinity.data_internalize_i env1))) ^^ (* Load reference counter *) - G.i_ (GetGlobal (nr elem_global)) ^^ - G.i_ (Call (nr (Dfinity.elem_length_i env1))) ^^ - G.i_ (SetGlobal (nr ElemHeap.ref_counter)) ^^ + G.i (GetGlobal (nr elem_global)) ^^ + G.i (Call (nr (Dfinity.elem_length_i env1))) ^^ + G.i (SetGlobal (nr ElemHeap.ref_counter)) ^^ (* Load references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i_ (GetGlobal (nr ElemHeap.ref_counter)) ^^ - G.i_ (GetGlobal (nr elem_global)) ^^ + G.i (GetGlobal (nr ElemHeap.ref_counter)) ^^ + G.i (GetGlobal (nr elem_global)) ^^ compile_unboxed_zero ^^ - G.i_ (Call (nr (Dfinity.elem_internalize_i env1))) + G.i (Call (nr (Dfinity.elem_internalize_i env1))) ) ); Func.define_built_in env "save_mem" [] [] (fun env1 -> (* Store memory *) compile_unboxed_const ElemHeap.table_end ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ compile_unboxed_const ElemHeap.table_end ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ - G.i_ (Call (nr (Dfinity.data_externalize_i env))) ^^ - G.i_ (SetGlobal (nr mem_global)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ + G.i (SetGlobal (nr mem_global)) ^^ (* Store references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i_ (GetGlobal (nr ElemHeap.ref_counter)) ^^ - G.i_ (Call (nr (Dfinity.elem_externalize_i env))) ^^ - G.i_ (SetGlobal (nr elem_global)) + G.i (GetGlobal (nr ElemHeap.ref_counter)) ^^ + G.i (Call (nr (Dfinity.elem_externalize_i env))) ^^ + G.i (SetGlobal (nr elem_global)) ) - let save_mem env = G.i_ (Call (nr (E.built_in env "save_mem"))) - let restore_mem env = G.i_ (Call (nr (E.built_in env "restore_mem"))) + let save_mem env = G.i (Call (nr (E.built_in env "save_mem"))) + let restore_mem env = G.i (Call (nr (E.built_in env "restore_mem"))) end (* OrthogonalPersistence *) @@ -1801,10 +1794,10 @@ module Serialization = struct let serialize_go env = Func.share_code env "serialize_go" ["x"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in + let get_x = G.i (GetLocal (nr 0l)) in let (set_copy, get_copy) = new_local env "x" in - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_copy ^^ get_x ^^ @@ -1826,12 +1819,12 @@ module Serialization = struct ; Tagged.Some, Opt.inject env ( get_x ^^ Opt.project ^^ - G.i_ (Call (nr (E.built_in env "serialize_go"))) + G.i (Call (nr (E.built_in env "serialize_go"))) ) ; Tagged.ObjInd, Tagged.obj env Tagged.ObjInd [ get_x ^^ Heap.load_field 1l ^^ - G.i_ (Call (nr (E.built_in env "serialize_go"))) + G.i (Call (nr (E.built_in env "serialize_go"))) ] ; Tagged.Array, begin @@ -1843,7 +1836,7 @@ module Serialization = struct get_len ^^ compile_add_const Array.header_size ^^ Heap.dyn_alloc_words env ^^ - G.i_ Drop ^^ + G.i Drop ^^ (* Copy header *) get_x ^^ @@ -1862,7 +1855,7 @@ module Serialization = struct get_i ^^ Array.idx env ^^ load_ptr ^^ - G.i_ (Call (nr (E.built_in env "serialize_go"))) ^^ + G.i (Call (nr (E.built_in env "serialize_go"))) ^^ store_ptr ) ^^ get_copy @@ -1880,7 +1873,7 @@ module Serialization = struct get_len ^^ Heap.dyn_alloc_words env ^^ - G.i_ Drop ^^ + G.i Drop ^^ (* Copy header and data *) get_x ^^ @@ -1902,7 +1895,7 @@ module Serialization = struct compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ Heap.dyn_alloc_words env ^^ - G.i_ Drop ^^ + G.i Drop ^^ (* Copy header *) get_x ^^ @@ -1919,14 +1912,14 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_i ^^ compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ load_ptr ^^ @@ -1939,7 +1932,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ get_i ^^ @@ -1947,11 +1940,11 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ load_ptr ^^ - G.i_ (Call (nr (E.built_in env "serialize_go"))) ^^ + G.i (Call (nr (E.built_in env "serialize_go"))) ^^ store_ptr ) ^^ get_copy @@ -1962,8 +1955,8 @@ module Serialization = struct let shift_pointer_at env = Func.share_code env "shift_pointer_at" ["loc"; "ptr_offset"] [] (fun env -> - let get_loc = G.i_ (GetLocal (nr 0l)) in - let get_ptr_offset = G.i_ (GetLocal (nr 1l)) in + let get_loc = G.i (GetLocal (nr 0l)) in + let get_ptr_offset = G.i (GetLocal (nr 1l)) in let (set_ptr, get_ptr) = new_local env "ptr" in get_loc ^^ load_ptr ^^ @@ -1975,7 +1968,7 @@ module Serialization = struct ( get_loc ^^ get_ptr ^^ get_ptr_offset ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ store_ptr ) ) @@ -1983,7 +1976,7 @@ module Serialization = struct (* Returns the object size (in bytes) *) let object_size env = Func.share_code env "object_size" ["x"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in + let get_x = G.i (GetLocal (nr 0l)) in get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, @@ -2030,12 +2023,12 @@ module Serialization = struct (* While we have not reached the end of the area *) ( get_x ^^ compile_to ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ) ( mk_code get_x ^^ get_x ^^ get_x ^^ object_size env ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_x ) @@ -2082,7 +2075,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) @@ -2095,7 +2088,7 @@ module Serialization = struct compile_add_const Closure.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) @@ -2103,9 +2096,9 @@ module Serialization = struct let shift_pointers env = Func.share_code env "shift_pointers" ["start"; "to"; "ptr_offset"] [] (fun env -> - let get_start = G.i_ (GetLocal (nr 0l)) in - let get_to = G.i_ (GetLocal (nr 1l)) in - let get_ptr_offset = G.i_ (GetLocal (nr 2l)) in + let get_start = G.i (GetLocal (nr 0l)) in + let get_to = G.i (GetLocal (nr 1l)) in + let get_ptr_offset = G.i (GetLocal (nr 2l)) in walk_heap_from_to env get_start get_to (fun get_x -> for_each_pointer env get_x (fun get_ptr_loc -> @@ -2118,9 +2111,9 @@ module Serialization = struct let extract_references env = Func.share_code env "extract_references" ["start"; "to"; "tbl_area"] [I32Type] (fun env -> - let get_start = G.i_ (GetLocal (nr 0l)) in - let get_to = G.i_ (GetLocal (nr 1l)) in - let get_tbl_area = G.i_ (GetLocal (nr 2l)) in + let get_start = G.i (GetLocal (nr 0l)) in + let get_to = G.i (GetLocal (nr 1l)) in + let get_tbl_area = G.i (GetLocal (nr 2l)) in let (set_i, get_i) = new_local env "i" in compile_unboxed_const 0l ^^ set_i ^^ @@ -2132,7 +2125,7 @@ module Serialization = struct (* Adjust reference *) get_tbl_area ^^ get_i ^^ compile_mul_const Heap.word_size ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_x ^^ Heap.load_field 1l ^^ ElemHeap.recall_reference env ^^ @@ -2152,9 +2145,9 @@ module Serialization = struct let intract_references env = Func.share_code env "intract_references" ["start"; "to"; "tbl_area"] [] (fun env -> - let get_start = G.i_ (GetLocal (nr 0l)) in - let get_to = G.i_ (GetLocal (nr 1l)) in - let get_tbl_area = G.i_ (GetLocal (nr 2l)) in + let get_start = G.i (GetLocal (nr 0l)) in + let get_to = G.i (GetLocal (nr 1l)) in + let get_tbl_area = G.i (GetLocal (nr 2l)) in walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ @@ -2166,7 +2159,7 @@ module Serialization = struct Heap.load_field 1l ^^ compile_mul_const Heap.word_size ^^ get_tbl_area ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ load_ptr ^^ ElemHeap.remember_reference env ^^ Heap.store_field 1l @@ -2176,9 +2169,9 @@ module Serialization = struct let serialize env = if E.mode env <> DfinityMode - then Func.share_code env "serialize" ["x"] [I32Type] (fun env -> G.i_ Unreachable) + then Func.share_code env "serialize" ["x"] [I32Type] (fun env -> G.i Unreachable) else Func.share_code env "serialize" ["x"] [I32Type] (fun env -> - let get_x = G.i_ (GetLocal (nr 0l)) in + let get_x = G.i (GetLocal (nr 0l)) in let (set_start, get_start) = new_local env "old_heap" in let (set_end, get_end) = new_local env "end" in @@ -2186,7 +2179,7 @@ module Serialization = struct let (set_databuf, get_databuf) = new_local env "databuf" in (* Remember where we start to copy to *) - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_start ^^ (* Copy data *) @@ -2200,7 +2193,7 @@ module Serialization = struct store_ptr ^^ (* Remember the end *) - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_end ^^ (* Empty table of references *) @@ -2209,16 +2202,16 @@ module Serialization = struct (* We have real data on the heap. Copy. *) ( get_x ^^ serialize_go env ^^ - G.i_ Drop ^^ + G.i Drop ^^ (* Remember the end *) - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_end ^^ (* Adjust pointers *) get_start ^^ get_end ^^ - compile_unboxed_zero ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ shift_pointers env ^^ (* Extract references, and remember how many there were *) @@ -2231,14 +2224,14 @@ module Serialization = struct (* Create databuf *) get_start ^^ - get_end ^^ get_start ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ - G.i_ (Call (nr (Dfinity.data_externalize_i env))) ^^ + get_end ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ set_databuf ^^ (* Append this reference at the end of the extracted references *) get_end ^^ get_tbl_size ^^ compile_mul_const Heap.word_size ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ get_databuf ^^ store_ptr ^^ (* And bump table end *) @@ -2246,12 +2239,12 @@ module Serialization = struct (* Reset the heap counter, to free some space *) get_start ^^ - G.i_ (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (SetGlobal (nr Heap.heap_ptr)) ^^ (* Finally, create elembuf *) get_end ^^ get_tbl_size ^^ - G.i_ (Call (nr (Dfinity.elem_externalize_i env))) + G.i (Call (nr (Dfinity.elem_externalize_i env))) ) let serialize_n env n = match n with @@ -2263,23 +2256,23 @@ module Serialization = struct let retty = Lib.List.make n I32Type in Func.share_code env name args retty (fun env -> G.table n (fun i -> - G.i_ (GetLocal (nr (Int32.of_int i))) ^^ serialize env + G.i (GetLocal (nr (Int32.of_int i))) ^^ serialize env ) ) let deserialize env = Func.share_code env "deserialize" ["ref"] [I32Type] (fun env -> - let get_elembuf = G.i_ (GetLocal (nr 0l)) in + let get_elembuf = G.i (GetLocal (nr 0l)) in let (set_databuf, get_databuf) = new_local env "databuf" in let (set_start, get_start) = new_local env "start" in let (set_data_len, get_data_len) = new_local env "data_len" in let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in (* new positions *) - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_start ^^ - get_elembuf ^^ G.i_ (Call (nr (Dfinity.elem_length_i env))) ^^ + get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ set_tbl_size ^^ (* First load databuf (last entry) at the heap position somehow *) @@ -2287,11 +2280,11 @@ module Serialization = struct compile_unboxed_const 1l ^^ get_elembuf ^^ get_tbl_size ^^ compile_sub_const 1l ^^ - G.i_ (Call (nr (Dfinity.elem_internalize_i env))) ^^ + G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ get_start ^^ load_ptr ^^ set_databuf ^^ - get_databuf ^^ G.i_ (Call (nr (Dfinity.data_length_i env))) ^^ + get_databuf ^^ G.i (Call (nr (Dfinity.data_length_i env))) ^^ set_data_len ^^ (* Load data from databuf *) @@ -2299,12 +2292,12 @@ module Serialization = struct get_data_len ^^ get_databuf ^^ compile_unboxed_const 0l ^^ - G.i_ (Call (nr (Dfinity.data_internalize_i env))) ^^ + G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ (* Check if we got something unboxed (data buf size 1 word) *) get_data_len ^^ compile_unboxed_const Heap.word_size ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (* Yes, we got something unboxed. Return it, and do _not_ bump the heap pointer *) ( get_start ^^ load_ptr ) @@ -2312,27 +2305,27 @@ module Serialization = struct ( (* update heap pointer *) get_start ^^ get_data_len ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (SetGlobal (nr Heap.heap_ptr)) ^^ (* Fix pointers *) get_start ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ get_start ^^ shift_pointers env ^^ (* Load references *) - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ get_tbl_size ^^ compile_sub_const 1l ^^ get_elembuf ^^ compile_unboxed_const 0l ^^ - G.i_ (Call (nr (Dfinity.elem_internalize_i env))) ^^ + G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ (* Fix references *) (* Extract references *) get_start ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ intract_references env ^^ (* return allocated thing *) @@ -2361,10 +2354,10 @@ module GC = struct the object will be finally. *) (* Invariant: Must not be called on the same pointer twice. *) let evacuate env = Func.share_code env "evaucate" ["begin_from_space"; "begin_to_space"; "end_to_space"; "ptr_loc"] [I32Type] (fun env -> - let get_begin_from_space = G.i_ (GetLocal (nr 0l)) in - let get_begin_to_space = G.i_ (GetLocal (nr 1l)) in - let get_end_to_space = G.i_ (GetLocal (nr 2l)) in - let get_ptr_loc = G.i_ (GetLocal (nr 3l)) in + let get_begin_from_space = G.i (GetLocal (nr 0l)) in + let get_begin_to_space = G.i (GetLocal (nr 1l)) in + let get_end_to_space = G.i (GetLocal (nr 2l)) in + let get_ptr_loc = G.i (GetLocal (nr 3l)) in let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2372,13 +2365,13 @@ module GC = struct get_obj ^^ (* If this is an unboxed scalar, ignore it *) - BitTagged.if_unboxed env (ValBlockType None) (get_end_to_space ^^ G.i_ Return) G.nop ^^ + BitTagged.if_unboxed env (ValBlockType None) (get_end_to_space ^^ G.i Return) G.nop ^^ (* If this is static, ignore it *) get_obj ^^ get_begin_from_space ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ - G.if_ (ValBlockType None) (get_end_to_space ^^ G.i_ Return) G.nop ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + G.if_ (ValBlockType None) (get_end_to_space ^^ G.i Return) G.nop ^^ (* If this is an indirection, just use that value *) get_obj ^^ @@ -2390,7 +2383,7 @@ module GC = struct store_ptr ^^ get_end_to_space ^^ - G.i_ Return + G.i Return ] ^^ (* Copy the referenced object to to space *) @@ -2401,9 +2394,9 @@ module GC = struct (* Calculate new pointer *) get_end_to_space ^^ get_begin_to_space ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ get_begin_from_space ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ set_new_ptr ^^ (* Set indirection *) @@ -2421,7 +2414,7 @@ module GC = struct (* Calculate new end of to space *) get_end_to_space ^^ get_len ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ) let register env (end_of_static_space : int32) = Func.define_built_in env "collect" [] [] (fun env -> @@ -2431,8 +2424,8 @@ module GC = struct let (set_end_to_space, get_end_to_space) = new_local env "end_to_space" in compile_unboxed_const end_of_static_space ^^ set_begin_from_space ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ set_begin_to_space ^^ - G.i_ (GetGlobal (nr Heap.heap_ptr)) ^^ set_end_to_space ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_begin_to_space ^^ + G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_end_to_space ^^ (* Common arguments for evalcuate *) @@ -2468,14 +2461,14 @@ module GC = struct (* Copy the to-space to the beginning of memory. *) get_begin_to_space ^^ get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ Heap.memcpy env ^^ (* Reset the heap pointer *) get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i_ (SetGlobal (nr Heap.heap_ptr)) + get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (SetGlobal (nr Heap.heap_ptr)) ) @@ -2495,25 +2488,25 @@ module FuncDec = struct (* Expects all arguments on the stack, in serialized form. *) let call_funcref env cc get_ref = - if E.mode env <> DfinityMode then G.i_ Unreachable else + if E.mode env <> DfinityMode then G.i Unreachable else compile_unboxed_const tmp_table_slot ^^ (* slot number *) get_ref ^^ (* the boxed funcref table id *) Heap.load_field 1l ^^ ElemHeap.recall_reference env ^^ - G.i_ (Call (nr (Dfinity.func_internalize_i env))) ^^ + G.i (Call (nr (Dfinity.func_internalize_i env))) ^^ compile_unboxed_const tmp_table_slot ^^ - G.i_ (CallIndirect (nr (message_ty env cc))) + G.i (CallIndirect (nr (message_ty env cc))) let export_self_message env = Func.share_code env "export_self_message" ["name"] [I32Type] (fun env -> - let get_name = G.i_ (GetLocal (nr 0l)) in + let get_name = G.i (GetLocal (nr 0l)) in Tagged.obj env Tagged.Reference [ (* Create a funcref for the message *) - G.i_ (Call (nr (Dfinity.actor_self_i env))) ^^ + G.i (Call (nr (Dfinity.actor_self_i env))) ^^ get_name ^^ (* the databuf with the message name *) - G.i_ (Call (nr (Dfinity.actor_export_i env))) ^^ + G.i (Call (nr (Dfinity.actor_export_i env))) ^^ ElemHeap.remember_reference env ] ) @@ -2528,8 +2521,8 @@ module FuncDec = struct let compile_local_function env cc restore_env mk_pat mk_body at = let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in let retty = Lib.List.make cc.Value.n_res I32Type in - Func.of_body env (["clos"] @ args) retty (fun env1 -> - let get_closure = G.i (GetLocal (E.unary_closure_local env1) @@ at) in + Func.of_body env (["clos"] @ args) retty (fun env1 -> G.with_region at ( + let get_closure = G.i (GetLocal (E.unary_closure_local env1)) in let (env2, closure_code) = restore_env env1 get_closure in @@ -2538,9 +2531,10 @@ module FuncDec = struct closure_code ^^ alloc_args_code ^^ - let get i = G.i_ (GetLocal (nr (Int32.(add 1l (of_int i))))) in + let get i = G.i (GetLocal (nr (Int32.(add 1l (of_int i))))) in destruct_args_code get ^^ - mk_body env3) + mk_body env3 + )) (* Similar, but for shared functions aka messages. Differences are: - The closure is actually an index into the closure table @@ -2553,13 +2547,13 @@ module FuncDec = struct let compile_message env cc restore_env mk_pat mk_body at = let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in assert (cc.Value.n_res = 0); - Func.of_body env (["clos"] @ args) [] (fun env1 -> + Func.of_body env (["clos"] @ args) [] (fun env1 -> G.with_region at ( (* Restore memory *) OrthogonalPersistence.restore_mem env1 ^^ (* Look up closure *) let (set_closure, get_closure) = new_local env1 "closure" in - G.i (nr (GetLocal (nr 0l))) ^^ + G.i (GetLocal (nr 0l)) ^^ ClosureTable.recall_closure env1 ^^ set_closure ^^ @@ -2571,17 +2565,17 @@ module FuncDec = struct closure_code ^^ alloc_args_code ^^ let get i = - G.i_ (GetLocal (nr (Int32.(add 1l (of_int i))))) ^^ + G.i (GetLocal (nr (Int32.(add 1l (of_int i))))) ^^ Serialization.deserialize env in destruct_args_code get ^^ mk_body env3 ^^ (* Collect garbage *) - G.i_ (Call (nr (E.built_in env3 "collect"))) ^^ + G.i (Call (nr (E.built_in env3 "collect"))) ^^ (* Save memory *) OrthogonalPersistence.save_mem env1 - ) + )) (* A static message, from a public actor field *) (* Like compile__message, but no closure *) @@ -2599,13 +2593,13 @@ module FuncDec = struct alloc_args_code ^^ let get i = - G.i_ (GetLocal (nr (Int32.(add 0l (of_int i))))) ^^ + G.i (GetLocal (nr (Int32.(add 0l (of_int i))))) ^^ Serialization.deserialize env in destruct_args_code get ^^ mk_body env2 ^^ (* Collect memory *) - G.i_ (Call (nr (E.built_in env "collect"))) ^^ + G.i (Call (nr (E.built_in env "collect"))) ^^ (* Save memory *) OrthogonalPersistence.save_mem env @@ -2703,10 +2697,10 @@ module FuncDec = struct else Tagged.obj env Tagged.Reference [ compile_unboxed_const fi ^^ - G.i_ (Call (nr (Dfinity.func_externalize_i env))) ^^ + G.i (Call (nr (Dfinity.func_externalize_i env))) ^^ get_li ^^ ClosureTable.remember_closure env ^^ - G.i_ (Call (nr (Dfinity.func_bind_i env))) ^^ + G.i (Call (nr (Dfinity.func_bind_i env))) ^^ ElemHeap.remember_reference env ] end ^^ @@ -2720,7 +2714,7 @@ module FuncDec = struct if not is_local && E.mode pre_env <> DfinityMode then let (pre_env1, _) = Var.add_local pre_env name.it in - ( pre_env1, G.i_ Unreachable, fun env -> G.i_ Unreachable) + ( pre_env1, G.i Unreachable, fun env -> G.i Unreachable) else match AllocHow.M.find_opt name.it how with | None -> assert is_local; @@ -2782,9 +2776,9 @@ module StackRep = struct let drop env (sr_in : t) = match sr_in with - | Vanilla -> G.i_ Drop - | UnboxedInt -> G.i_ Drop - | UnboxedTuple n -> G.table n (fun _ -> G.i_ Drop) + | Vanilla -> G.i Drop + | UnboxedInt -> G.i Drop + | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) | Unreachable -> G.nop let adjust env (sr_in : t) sr_out = @@ -2792,7 +2786,7 @@ module StackRep = struct then G.nop else match sr_in, sr_out with | Unreachable, Unreachable -> G.nop - | Unreachable, _ -> G.i_ Unreachable + | Unreachable, _ -> G.i Unreachable | UnboxedTuple n, Vanilla -> Array.from_stack env n | Vanilla, UnboxedTuple n -> Array.to_stack env n @@ -2854,7 +2848,11 @@ module PatCode = struct let orTrap : patternCode -> G.t = function | CannotFail is -> is - | CanFail is -> is (G.i_ Unreachable) + | CanFail is -> is (G.i Unreachable) + + let with_region at = function + | CannotFail is -> CannotFail (G.with_region at is) + | CanFail is -> CanFail (fun k -> G.with_region at (is k)) end (* PatCode *) open PatCode @@ -2867,13 +2865,13 @@ let compile_lit env lit = Syntax.(match lit with (* This maps int to int32, instead of a proper arbitrary precision library *) | IntLit n -> StackRep.UnboxedInt, (try compile_unboxed_const (Big_int.int32_of_big_int n) - with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i_ Unreachable) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) | NatLit n -> StackRep.UnboxedInt, (try compile_unboxed_const (Big_int.int32_of_big_int n) - with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i_ Unreachable) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) | NullLit -> StackRep.Vanilla, compile_null | TextLit t -> StackRep.Vanilla, Text.lit env t - | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Vanilla, G.i_ Unreachable) + | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Vanilla, G.i Unreachable) ) let compile_lit_as env sr_out lit = @@ -2884,15 +2882,15 @@ let compile_unop env op = Syntax.(match op with | NegOp -> StackRep.UnboxedInt, Func.share_code env "neg" ["n"] [I32Type] (fun env -> - let get_n = G.i_ (GetLocal (nr 0l)) in + let get_n = G.i (GetLocal (nr 0l)) in compile_unboxed_zero ^^ get_n ^^ - G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ) | PosOp -> StackRep.UnboxedInt, G.nop - | _ -> todo "compile_unop" (Arrange.unop op) (StackRep.Vanilla, G.i_ Unreachable) + | _ -> todo "compile_unop" (Arrange.unop op) (StackRep.Vanilla, G.i Unreachable) ) (* This returns a single StackRep, to be used for both arguments and the @@ -2900,29 +2898,31 @@ let compile_unop env op = Syntax.(match op with but none of these do, so a single value is fine. *) let compile_binop env op = Syntax.(match op with - | AddOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) - | SubOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) - | MulOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) - | DivOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) - | ModOp -> StackRep.UnboxedInt, G.i_ (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) + | AddOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + | SubOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + | MulOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) + | DivOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) + | ModOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) | CatOp -> StackRep.Vanilla, Text.concat env - | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Vanilla, G.i_ Unreachable) + | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Vanilla, G.i Unreachable) ) let compile_relop env op = Syntax.(StackRep.UnboxedInt, match op with - | EqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) - | NeqOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + | EqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + | NeqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) compile_unboxed_false compile_unboxed_true - | GeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) - | GtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) - | LeOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) - | LtOp -> G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + | GeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) + | GtOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) + | LeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) + | LtOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ) (* compile_lexp is used for expressions on the left of an assignment operator, produces some code (with sideffect), and some pure code *) -let rec compile_lexp (env : E.t) exp = match exp.it with +let rec compile_lexp (env : E.t) exp = + (fun (sr,code) -> (sr, G.with_region exp.at code)) @@ + match exp.it with | VarE var -> G.nop, Var.set_val env var.it @@ -2936,9 +2936,11 @@ let rec compile_lexp (env : E.t) exp = match exp.it with (* Only real objects have mutable fields, no need to branch on the tag *) Object.idx env n, store_ptr - | _ -> todo "compile_lexp" (Arrange_ir.exp exp) (G.i_ Unreachable, G.nop) + | _ -> todo "compile_lexp" (Arrange_ir.exp exp) (G.i Unreachable, G.nop) -and compile_exp (env : E.t) exp = match exp.it with +and compile_exp (env : E.t) exp = + (fun (sr,code) -> (sr, G.with_region exp.at code)) @@ + match exp.it with | IdxE (e1, e2) -> StackRep.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to array *) @@ -2954,7 +2956,10 @@ and compile_exp (env : E.t) exp = match exp.it with Tagged.branch env (ValBlockType (Some I32Type)) ( [ Tagged.Object, get_o ^^ Object.load_idx env name ] @ (if E.mode env = DfinityMode - then [ Tagged.Reference, get_o ^^ actor_fake_object_idx env {name with it = n} ] + then [ Tagged.Reference, + get_o ^^ + actor_fake_object_idx env {name with it = n} exp.at + ] else []) @ match Array.fake_object_idx env n with | None -> [] @@ -2970,7 +2975,7 @@ and compile_exp (env : E.t) exp = match exp.it with match p with | "Array.init" -> Array.init env | "Array.tabulate" -> Array.tabulate env - | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) + | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end (* Unary prims *) | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> @@ -2990,7 +2995,7 @@ and compile_exp (env : E.t) exp = match exp.it with Dfinity.prim_print env | _ -> StackRep.Unreachable, - todo "compile_exp" (Arrange_ir.exp pe) (G.i_ Unreachable) + todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end | VarE var -> StackRep.Vanilla, @@ -3006,7 +3011,7 @@ and compile_exp (env : E.t) exp = match exp.it with | AssertE e1 -> StackRep.unit, compile_exp_as env StackRep.UnboxedInt e1 ^^ - G.if_ (ValBlockType None) G.nop (G.i (Unreachable @@ exp.at)) + G.if_ (ValBlockType None) G.nop (G.i Unreachable) | UnE (op, e1) -> let sr, code = compile_unop env op in sr, @@ -3060,7 +3065,7 @@ and compile_exp (env : E.t) exp = match exp.it with Heap.load_field Object.class_position ^^ (* Equal? *) get_j ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) compile_unboxed_true (* Static function id? *) @@ -3070,7 +3075,7 @@ and compile_exp (env : E.t) exp = match exp.it with Heap.load_field 0l ^^ (* get the function id *) compile_mul_const Heap.word_size ^^ compile_add_const 1l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ) ] | BlockE decs -> @@ -3094,16 +3099,16 @@ and compile_exp (env : E.t) exp = match exp.it with G.branch_to_ d | LoopE (e, None) -> StackRep.Unreachable, - G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i_ (Br (nr 0l)) + G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i (Br (nr 0l)) ) ^^ - G.i_ Unreachable + G.i Unreachable | LoopE (e1, Some e2) -> StackRep.unit, G.loop_ (ValBlockType None) ( compile_exp_unit env e1 ^^ compile_exp_as env StackRep.UnboxedInt e2 ^^ - G.if_ (ValBlockType None) (G.i_ (Br (nr 1l))) G.nop + G.if_ (ValBlockType None) (G.i (Br (nr 1l))) G.nop ) | WhileE (e1, e2) -> StackRep.unit, @@ -3111,13 +3116,13 @@ and compile_exp (env : E.t) exp = match exp.it with compile_exp_as env StackRep.UnboxedInt e1 ^^ G.if_ (ValBlockType None) ( compile_exp_unit env e2 ^^ - G.i_ (Br (nr 1l)) + G.i (Br (nr 1l)) ) G.nop ) | RetE e -> StackRep.Unreachable, compile_exp_as env (StackRep.of_arity (E.get_n_res env)) e ^^ - G.i (Return @@ exp.at) + G.i Return | OptE e -> StackRep.Vanilla, Opt.inject env (compile_exp_vanilla env e) @@ -3135,15 +3140,15 @@ and compile_exp (env : E.t) exp = match exp.it with let captured = Freevars_ir.exp exp in let prelude_names = find_prelude_names env in if Freevars_ir.M.is_empty (Freevars_ir.diff captured prelude_names) - then actor_lit env name fs - else todo "non-closed actor" (Arrange_ir.exp exp) G.i_ Unreachable + then actor_lit env name fs exp.at + else todo "non-closed actor" (Arrange_ir.exp exp) G.i Unreachable | CallE (cc, e1, _, e2) -> StackRep.of_arity (cc.Value.n_res), begin match isDirectCall env e1, cc.Value.sort with | Some fi, _ -> compile_null ^^ (* A dummy closure *) compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ (* the args *) - G.i (Call (nr fi) @@ exp.at) + G.i (Call (nr fi)) | None, (Type.Call Type.Local | Type.Construct) -> let (set_clos, get_clos) = new_local env "clos" in compile_exp_vanilla env e1 ^^ @@ -3202,11 +3207,11 @@ and compile_exp (env : E.t) exp = match exp.it with (* Check for null *) get_oi ^^ compile_null ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType None) G.nop ( alloc_code ^^ get_oi ^^ Opt.project ^^ - code2 ^^ code3 ^^ G.i_ (Br (nr 1l)) + code2 ^^ code3 ^^ G.i (Br (nr 1l)) ) ) (* Async-wait lowering support features *) @@ -3215,7 +3220,7 @@ and compile_exp (env : E.t) exp = match exp.it with let sr, code = compile_exp env1 e in sr, Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i_ (SetLocal (nr i)) ^^ + G.i (SetLocal (nr i)) ^^ code | DefineE (name, _, e) -> StackRep.unit, @@ -3227,7 +3232,7 @@ and compile_exp (env : E.t) exp = match exp.it with (fun (name, id) -> (name, fun env -> Var.get_val_ptr env id.it)) fs in Object.lit_raw env fs' - | _ -> StackRep.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i_ Unreachable) + | _ -> StackRep.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i Unreachable) and isDirectCall env e = match e.it with | VarE var -> @@ -3239,14 +3244,18 @@ and isDirectCall env e = match e.it with and compile_exp_as env sr_out e = let sr_in, code = compile_exp env e in - code ^^ StackRep.adjust env sr_in sr_out + G.with_region e.at ( + code ^^ StackRep.adjust env sr_in sr_out + ) and compile_exp_as_opt env sr_out_o e = let sr_in, code = compile_exp env e in - code ^^ - match sr_out_o with - | None -> StackRep.drop env sr_in - | Some sr_out -> StackRep.adjust env sr_in sr_out + G.with_region e.at ( + code ^^ + match sr_out_o with + | None -> StackRep.drop env sr_in + | Some sr_out -> StackRep.adjust env sr_in sr_out + ) and compile_exp_vanilla (env : E.t) exp = compile_exp_as env StackRep.Vanilla exp @@ -3283,21 +3292,24 @@ enabled mutual recursion. *) -and compile_lit_pat env l = match l with +and compile_lit_pat env l = + match l with | Syntax.NullLit -> compile_lit_as env StackRep.Vanilla l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(NatLit _ | IntLit _ | BoolLit _) -> BoxedInt.unbox env ^^ compile_lit_as env StackRep.UnboxedInt l ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | Syntax.(TextLit t) -> Text.lit env t ^^ Text.compare env - | _ -> todo "compile_lit_pat" (Arrange.lit l) (G.i_ Unreachable) + | _ -> todo "compile_lit_pat" (Arrange.lit l) (G.i Unreachable) -and fill_pat env pat : patternCode = match pat.it with - | WildP -> CannotFail (G.i_ Drop) +and fill_pat env pat : patternCode = + PatCode.with_region pat.at @@ + match pat.it with + | WildP -> CannotFail (G.i Drop) | OptP p -> let code1 = fill_pat env p in let (set_i, get_i) = new_local env "opt_scrut" in @@ -3305,7 +3317,7 @@ and fill_pat env pat : patternCode = match pat.it with set_i ^^ get_i ^^ compile_null ^^ - G.i_ (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType None) fail_code ( get_i ^^ Opt.project ^^ @@ -3338,6 +3350,7 @@ and fill_pat env pat : patternCode = match pat.it with (CannotFail get_i ^^^ code2) and alloc_pat env how pat = + (fun (env,code) -> (env, G.with_region pat.at code)) @@ let (_,d) = Freevars_ir.pat pat in AllocHow.S.fold (fun v (env,code0) -> let (env1, code1) = AllocHow.add_local_default env how AllocHow.LocalImmut v @@ -3368,6 +3381,7 @@ and compile_mono_pat env how pat = and compile_n_ary_pat env how pat = let (env1, alloc_code) = alloc_pat env how pat in let arity, fill_code = + (fun (sr,code) -> (sr, G.with_region pat.at code)) @@ match pat.it with (* Nothing to match: Do not even put something on the stack *) | WildP -> None, G.nop @@ -3394,6 +3408,7 @@ and compile_n_ary_pat env how pat = and compile_func_pat env cc pat = let (env1, alloc_code) = alloc_pat env AllocHow.M.empty pat in let fill_code get = + G.with_region pat.at @@ if cc.Value.n_args = 1 then (* Easy case: unary *) @@ -3412,7 +3427,11 @@ and compile_func_pat env cc pat = orTrap (fill_pat env1 pat) in (env1, alloc_code, fill_code) -and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = match dec.it with +and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = + (fun (pre_env,alloc_code,mk_code) -> + (pre_env, G.with_region dec.at alloc_code, fun env -> + (fun (sr, code) -> (sr, G.with_region dec.at code)) (mk_code env))) @@ + match dec.it with | TypD _ -> (pre_env, G.nop, fun _ -> StackRep.unit, G.nop) | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env e) | LetD (p, e) -> @@ -3484,16 +3503,17 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = let rec go env = function | [] -> G.nop | (prog::progs) -> - let (env1, (sr, code1)) = compile_decs_block env prog.it in - let code2 = go env1 progs in - code1 ^^ StackRep.drop env1 sr ^^ code2 in + G.with_region prog.at @@ + let (env1, (sr, code1)) = compile_decs_block env prog.it in + let code2 = go env1 progs in + code1 ^^ StackRep.drop env1 sr ^^ code2 in go env1 progs ) and compile_private_actor_field pre_env (f : Ir.exp_field) = let ptr = E.reserve_static_memory pre_env (Int32.mul 2l Heap.word_size) in let pre_env1 = E.add_local_static pre_env f.it.id.it (Int32.add Heap.word_size ptr) in - ( pre_env1, fun env -> + ( pre_env1, fun env -> G.with_region f.at @@ compile_unboxed_const ptr ^^ Tagged.store Tagged.MutBox ^^ @@ -3505,15 +3525,11 @@ and compile_private_actor_field pre_env (f : Ir.exp_field) = and compile_public_actor_field pre_env (f : Ir.exp_field) = let (cc, name, _, pat, _rt, exp) = let find_func exp = match exp.it with - | BlockE [{it = FuncD (cc, name, ty_args, pat, rt, exp); _ }] -> (cc, name, ty_args, pat, rt, exp) + | BlockE [{it = FuncD (cc, name, ty_args, pat, rt, exp); _ }] -> + (cc, name, ty_args, pat, rt, exp) | _ -> assert false (* "public actor field not a function" *) in find_func f.it.exp in - (* Which name to use? f.it.id or name? Can they differ? *) - (* crusso: use name for the name of the field, access by projection; id for the bound name. - They can differ after alpha-renaming of id due to CPS conversion, but are initially the same after the parsing - I have not reviewed/fixed the code below. - *) let (fi, fill) = E.reserve_fun pre_env name.it in E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args Wasm_copy.CustomSections.ElemBuf); E.add_export pre_env (nr { @@ -3523,7 +3539,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = let d = { allocate = FuncDec.static_self_message_pointer name; is_direct_call = None } in let pre_env1 = E.add_local_deferred pre_env name.it d in - ( pre_env1, fun env -> + ( pre_env1, fun env -> G.with_region f.at @@ let mk_pat inner_env = compile_func_pat inner_env cc pat in let mk_body inner_env = compile_exp_as inner_env (StackRep.of_arity cc.Value.n_res) exp in let f = FuncDec.compile_static_message env cc mk_pat mk_body f.at in @@ -3547,10 +3563,8 @@ and compile_actor_fields env fs = let (env1, mk_code2) = go env fs in (env1, mk_code2 env1) - - -and actor_lit outer_env name fs = - if E.mode outer_env <> DfinityMode then G.i_ Unreachable else +and actor_lit outer_env name fs at = + if E.mode outer_env <> DfinityMode then G.i Unreachable else let wasm = let env = E.mk_global (E.mode outer_env) (E.get_prelude outer_env) ClosureTable.table_end in @@ -3558,7 +3572,7 @@ and actor_lit outer_env name fs = if E.mode env = DfinityMode then Dfinity.system_imports env; Array.common_funcs env; - let start_fun = Func.of_body env [] [] (fun env3 -> + let start_fun = Func.of_body env [] [] (fun env3 -> G.with_region at @@ (* Compile stuff here *) let (env4, prelude_code) = compile_prelude env3 in let (env5, init_code) = compile_actor_fields env4 fs in @@ -3571,18 +3585,18 @@ and actor_lit outer_env name fs = let (_map, wasm) = Wasm_copy.CustomModule.encode m in wasm in - let code = + let code = G.with_region at @@ Dfinity.compile_databuf_of_bytes outer_env wasm ^^ (* Create actorref *) - G.i_ (Call (nr (Dfinity.module_new_i outer_env))) ^^ - G.i_ (Call (nr (Dfinity.actor_new_i outer_env))) ^^ + G.i (Call (nr (Dfinity.module_new_i outer_env))) ^^ + G.i (Call (nr (Dfinity.actor_new_i outer_env))) ^^ ElemHeap.remember_reference outer_env in (* Wrap it in a tagged heap object *) Tagged.obj outer_env Tagged.Reference [ code ] -and actor_fake_object_idx env name = +and actor_fake_object_idx env name at = G.with_region at @@ let (set_i, get_i) = new_local env "ref" in (* The wrapped actor table entry is on the stack *) Heap.load_field 1l ^^ @@ -3593,7 +3607,7 @@ and actor_fake_object_idx env name = Tagged.obj env Tagged.Reference [ get_i ^^ Dfinity.compile_databuf_of_bytes env (name.it) ^^ - G.i_ (Call (nr (Dfinity.actor_export_i env))) ^^ + G.i (Call (nr (Dfinity.actor_export_i env))) ^^ ElemHeap.remember_reference env ] diff --git a/src/instrList.ml b/src/instrList.ml index a953e8b58ac..28e5322bbad 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -10,7 +10,7 @@ features are open Wasm_copy.Ast open Wasm.Source -(* Some simpl peephole optimizations, to make the output code look less stupid *) +(* Some simple peephole optimizations, to make the output code look less stupid *) (* This uses a zipper.*) let optimize : instr list -> instr list = fun is -> let rec go l r = match l, r with @@ -35,44 +35,56 @@ let optimize : instr list -> instr list = fun is -> | l, [] -> List.rev l in go [] is -(* When we do not care about the generate source region *) -let nr x = x @@ Wasm.Source.no_region - -(* The main type of this module *) -type t = int32 -> instr list -> instr list +(* The main type of this module: + Arguments for the current depth and the current source region, + and producing a difference list *) +type t = int32 -> Wasm.Source.region -> instr list -> instr list let to_instr_list (is : t) : instr list = - optimize (is 0l []) + optimize (is 0l Wasm.Source.no_region []) -let to_nested_list d is = - optimize (is Int32.(add d 1l) []) +let to_nested_list d pos is = + optimize (is Int32.(add d 1l) pos []) (* The concatenation operator *) -let nop : t = fun _ rest -> rest -let (^^) (is1 : t) (is2 : t) : t = fun d rest -> is1 d (is2 d rest) +let nop : t = fun _ _ rest -> rest +let (^^) (is1 : t) (is2 : t) : t = fun d pos rest -> is1 d pos (is2 d pos rest) (* Singletons *) -let i (instr : instr) : t = fun _ rest -> instr :: rest -let i_ (instr : instr') = i (instr @@ Wasm.Source.no_region) +let i (instr : instr') : t = fun _ pos rest -> (instr @@ pos) :: rest (* map and concat *) let concat_map f xs = List.fold_right (^^) (List.map f xs) nop let concat_mapi f xs = List.fold_right (^^) (List.mapi f xs) nop let table n f = List.fold_right (^^) (Lib.List.table n f) nop +(* Region-managing combinabor *) + +let cr at = + let left = { Wasm.Source.file = at.Source.left.Source.file; + Wasm.Source.line = at.Source.left.Source.line; + Wasm.Source.column = at.Source.left.Source.column } in + let right = { Wasm.Source.file = at.Source.right.Source.file; + Wasm.Source.line = at.Source.right.Source.line; + Wasm.Source.column = at.Source.right.Source.column } in + { Wasm.Source.left = left; Wasm.Source.right = right } + +let with_region (pos : Source.region) (body : t) : t = + fun d _pos rest -> body d (cr pos) rest + (* Depths-managing combinators *) let if_ (ty : block_type) (thn : t) (els : t) : t = - fun d rest -> - nr (If (ty, to_nested_list d thn, to_nested_list d els)) :: rest + fun d pos rest -> + (If (ty, to_nested_list d pos thn, to_nested_list d pos els) @@ pos) :: rest let block_ (ty : block_type) (body : t) : t = - fun d rest -> - nr (Block (ty, to_nested_list d body)) :: rest + fun d pos rest -> + (Block (ty, to_nested_list d pos body) @@ pos) :: rest let loop_ (ty : block_type) (body : t) : t = - fun d rest -> - nr (Loop (ty, to_nested_list d body)) :: rest + fun d pos rest -> + (Loop (ty, to_nested_list d pos body) @@ pos) :: rest (* Remember depth *) type depth = int32 Lib.Promise.t @@ -92,8 +104,8 @@ let with_current_depth' (k : depth -> ('a * t)) : ('a * t) = (x, remember_depth depth is) let branch_to_ (p : depth) : t = - fun d rest -> - nr (Br (nr Int32.(sub d (Lib.Promise.value p)))) :: rest + fun d pos rest -> + (Br (Int32.(sub d (Lib.Promise.value p)) @@ pos) @@ pos) :: rest (* Convenience combinations *) From f232d0271e4dc1a5524306032b2b7f122cf02650 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 10:23:42 +0100 Subject: [PATCH 25/41] Resolve operator overloading in desugarer and do not pass boolean values through `box`/`unbox`. This is in preparation of using proper WebAssembly types for the various number types. --- src/arrange_ir.ml | 6 +- src/compile.ml | 143 +++++++++++------- src/desugar.ml | 17 ++- src/freevars_ir.ml | 6 +- src/ir.ml | 6 +- src/type.ml | 2 +- .../ok/counter-class.wasm.stderr.ok | 2 +- test/run-dfinity/ok/nary-async.dvm-run.ok | 9 +- test/run/ok/account.wasm.stderr.ok | 7 +- test/run/ok/bank-example.wasm.stderr.ok | 7 +- test/run/ok/bit-ops.wasm.stderr.ok | 56 +++++++ test/run/ok/numeric-ops.wasm.stderr.ok | 78 ++++++++-- test/run/ok/relational-ops.wasm.stderr.ok | 72 +++++++++ 13 files changed, 324 insertions(+), 87 deletions(-) create mode 100644 test/run/ok/relational-ops.wasm.stderr.ok diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 99b4882f7ea..a9b5d35e4c0 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -7,9 +7,9 @@ let ($$) head inner = Node (head, inner) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] | LitE l -> "LitE" $$ [Arrange.lit l] - | UnE (uo, e) -> "UnE" $$ [Arrange.unop uo; exp e] - | BinE (e1, bo, e2) -> "BinE" $$ [exp e1; Arrange.binop bo; exp e2] - | RelE (e1, ro, e2) -> "RelE" $$ [exp e1; Arrange.relop ro; exp e2] + | UnE (t, uo, e) -> "UnE" $$ [Arrange.prim t; Arrange.unop uo; exp e] + | BinE (t, e1, bo, e2)-> "BinE" $$ [Arrange.prim t; exp e1; Arrange.binop bo; exp e2] + | RelE (t, e1, ro, e2)-> "RelE" $$ [Arrange.prim t; exp e1; Arrange.relop ro; exp e2] | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | ActorE (i, efs) -> "ActorE" $$ [id i] @ List.map exp_field efs diff --git a/src/compile.ml b/src/compile.ml index cfb318a6c77..ddf560dbd70 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -304,8 +304,6 @@ end (* Function called compile_* return a list of instructions (and maybe other stuff) *) let compile_unboxed_const i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) -let compile_unboxed_true = compile_unboxed_const 1l -let compile_unboxed_false = compile_unboxed_const 0l let compile_unboxed_zero = compile_unboxed_const 0l let compile_unit = compile_unboxed_const 1l (* This needs to be disjoint from all pointers *) @@ -490,14 +488,16 @@ module Heap = struct ) ) - - end (* Heap *) module ElemHeap = struct let ref_counter = 3l let max_references = 1024l + + (* By placing the ElemHeap at memory location 0, we incidentally make sure that + the 0l pointer is never a valid pointer. + *) let ref_location = 0l let table_end : int32 = Int32.(add ref_location (mul max_references Heap.word_size)) @@ -588,19 +588,26 @@ end (* ClosureTable *) module BitTagged = struct (* Raw values x are stored as ( x << 1 | 1), i.e. with the LSB set. Pointers are stored as is (and should be aligned to have a zero there). + Special case: The zero pointer is considered a pointer. *) - (* Expect a possibly bit-tagged pointer on the stack. - If taged, untags it and executes the first sequest. - Otherwise, leaves it on the stack and executes the second sequence. - *) let if_unboxed env retty is1 is2 = - (* Get bit *) - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ - (* Check bit *) - compile_unboxed_const 1l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + Func.share_code env "is_unboxed" ["x"] [I32Type] (fun env -> + let get_x = G.i (GetLocal (nr 0l)) in + (* Get bit *) + get_x ^^ + compile_unboxed_const 1l ^^ + G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ + (* Check bit *) + compile_unboxed_const 1l ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.if_ (ValBlockType None) + (compile_unboxed_const 1l ^^ G.i Return) G.nop ^^ + (* Also check if it is the null-pointer *) + get_x ^^ + compile_unboxed_const 0l ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + ) ^^ G.if_ retty is1 is2 let untag_scalar env = @@ -1103,6 +1110,19 @@ module Object = struct end (* Object *) +module Bool = struct + (* Boolean literals are either 0 or 1 + The 1 is recognized as a unboxed scalar anyways, + while the 0 is special. This allows us + to use the result of the WebAssembly comparison operators + directly. + *) + let lit = function + | false -> compile_unboxed_const 0l + | true -> compile_unboxed_const 1l + +end (* Bool *) + module Text = struct let header_size = Int32.add Tagged.header_size 1l @@ -1198,7 +1218,7 @@ module Text = struct get_len1 ^^ get_len2 ^^ G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i Return) ^^ + G.if_ (ValBlockType None) G.nop (Bool.lit false ^^ G.i Return) ^^ (* We could do word-wise comparisons if we know that the trailing bytes are zeroed *) @@ -1217,9 +1237,9 @@ module Text = struct G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (compile_unboxed_false ^^ G.i Return) + G.if_ (ValBlockType None) G.nop (Bool.lit false ^^ G.i Return) ) ^^ - compile_unboxed_true + Bool.lit true ) end (* String *) @@ -1370,7 +1390,7 @@ module Array = struct | _ -> None (* The primitive operations *) - (* No need to wrap them in RTS functions: They occurr only once, in the prelude. *) + (* No need to wrap them in RTS functions: They occur only once, in the prelude. *) let init env = let (set_len, get_len) = new_local env "len" in let (set_x, get_x) = new_local env "x" in @@ -2744,6 +2764,8 @@ module StackRep = struct let unit = UnboxedTuple 0 + let bool = Vanilla + (* Most expression have a “preferred”, most optimal, form. Hence, compile_exp put them on the stack in that form, and also returns @@ -2757,6 +2779,14 @@ module StackRep = struct let of_arity n = if n = 1 then Vanilla else UnboxedTuple n + (* The stack rel of a primitive type, i.e. what the binary operators expect *) + let of_prim : Type.prim -> t = function + | Type.Bool -> bool + | Type.Nat -> UnboxedInt + | Type.Int -> UnboxedInt + | Type.Text -> Vanilla + | p -> todo "of_prim" (Arrange.prim p) Vanilla + let to_block_type env = function | Vanilla -> ValBlockType (Some I32Type) | UnboxedInt -> ValBlockType (Some I32Type) @@ -2843,14 +2873,14 @@ module PatCode = struct | CanFail is1 -> function | CanFail is2 -> CanFail (fun fail_code -> let inner_fail = G.new_depth_label () in - let inner_fail_code = compile_unboxed_false ^^ G.branch_to_ inner_fail in - G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ + let inner_fail_code = Bool.lit false ^^ G.branch_to_ inner_fail in + G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ Bool.lit true) ^^ G.if_ (ValBlockType None) G.nop (is2 fail_code) ) | CannotFail is2 -> CannotFail ( let inner_fail = G.new_depth_label () in - let inner_fail_code = compile_unboxed_false ^^ G.branch_to_ inner_fail in - G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ compile_unboxed_true) ^^ + let inner_fail_code = Bool.lit false ^^ G.branch_to_ inner_fail in + G.labeled_block_ (ValBlockType (Some I32Type)) inner_fail (is1 inner_fail_code ^^ Bool.lit true) ^^ G.if_ (ValBlockType None) G.nop is2 ) @@ -2868,8 +2898,9 @@ open PatCode (* The actual compiler code that looks at the AST *) let compile_lit env lit = Syntax.(match lit with - | BoolLit false -> StackRep.UnboxedInt, compile_unboxed_false - | BoolLit true -> StackRep.UnboxedInt, compile_unboxed_true + (* Booleans are directly in Vanilla representation *) + | BoolLit false -> StackRep.bool, Bool.lit false + | BoolLit true -> StackRep.bool, Bool.lit true (* This maps int to int32, instead of a proper arbitrary precision library *) | IntLit n -> StackRep.UnboxedInt, (try compile_unboxed_const (Big_int.int32_of_big_int n) @@ -2886,7 +2917,7 @@ let compile_lit_as env sr_out lit = let sr_in, code = compile_lit env lit in code ^^ StackRep.adjust env sr_in sr_out -let compile_unop env op = Syntax.(match op with +let compile_unop env t op = Syntax.(match op with | NegOp -> StackRep.UnboxedInt, Func.share_code env "neg" ["n"] [I32Type] (fun env -> @@ -2905,20 +2936,25 @@ let compile_unop env op = Syntax.(match op with result. One could imagine operators that require or produce different StackReps, but none of these do, so a single value is fine. *) -let compile_binop env op = Syntax.(match op with - | AddOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) - | SubOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) - | MulOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) - | DivOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) - | ModOp -> StackRep.UnboxedInt, G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) - | CatOp -> StackRep.Vanilla, Text.concat env - | _ -> todo "compile_binop" (Arrange.binop op) (StackRep.Vanilla, G.i Unreachable) +let compile_binop env t op = + StackRep.of_prim t, + Syntax.(match op with + | AddOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + | SubOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + | MulOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) + | DivOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) + | ModOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) + | CatOp -> Text.concat env + | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) ) -let compile_relop env op = Syntax.(StackRep.UnboxedInt, match op with +let compile_relop env t op = + StackRep.of_prim t, + Syntax.(match op with | EqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) | NeqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ - G.if_ (ValBlockType (Some I32Type)) compile_unboxed_false compile_unboxed_true + G.if_ (StackRep.to_block_type env StackRep.bool) + (Bool.lit false) (Bool.lit true) | GeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) | GtOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) | LeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) @@ -3018,27 +3054,27 @@ and compile_exp (env : E.t) exp = compile_lit env l | AssertE e1 -> StackRep.unit, - compile_exp_as env StackRep.UnboxedInt e1 ^^ + compile_exp_as env StackRep.bool e1 ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) - | UnE (op, e1) -> - let sr, code = compile_unop env op in + | UnE (t, op, e1) -> + let sr, code = compile_unop env t op in sr, compile_exp_as env sr e1 ^^ code - | BinE (e1, op, e2) -> - let sr, code = compile_binop env op in + | BinE (t, e1, op, e2) -> + let sr, code = compile_binop env t op in sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ code - | RelE (e1, op, e2) -> - let sr, code = compile_relop env op in - StackRep.UnboxedInt, + | RelE (t, e1, op, e2) -> + let sr, code = compile_relop env t op in + StackRep.bool, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ code | IfE (scrut, e1, e2) -> - let code_scrut = compile_exp_as env StackRep.UnboxedInt scrut in + let code_scrut = compile_exp_as env StackRep.bool scrut in let sr1, code1 = compile_exp env e1 in let sr2, code2 = compile_exp env e2 in let sr = StackRep.join sr1 sr2 in @@ -3048,7 +3084,7 @@ and compile_exp (env : E.t) exp = (code1 ^^ StackRep.adjust env sr1 sr) (code2 ^^ StackRep.adjust env sr2 sr) | IsE (e1, e2) -> - StackRep.UnboxedInt, + StackRep.bool, let code1 = compile_exp_vanilla env e1 in let code2 = compile_exp_vanilla env e2 in let (set_i, get_i) = new_local env "is_lhs" in @@ -3061,10 +3097,10 @@ and compile_exp (env : E.t) exp = get_i ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Array, - compile_unboxed_false + Bool.lit false ; Tagged.Reference, (* TODO: Implement IsE for actor references? *) - compile_unboxed_false + Bool.lit false ; Tagged.Object, (* There are two cases: Either the class is a pointer to the object on the RHS, or it is -- mangled -- the @@ -3075,7 +3111,7 @@ and compile_exp (env : E.t) exp = get_j ^^ G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) - compile_unboxed_true + (Bool.lit true) (* Static function id? *) ( get_i ^^ Heap.load_field Object.class_position ^^ @@ -3115,13 +3151,13 @@ and compile_exp (env : E.t) exp = StackRep.unit, G.loop_ (ValBlockType None) ( compile_exp_unit env e1 ^^ - compile_exp_as env StackRep.UnboxedInt e2 ^^ + compile_exp_as env StackRep.bool e2 ^^ G.if_ (ValBlockType None) (G.i (Br (nr 1l))) G.nop ) | WhileE (e1, e2) -> StackRep.unit, G.loop_ (ValBlockType None) ( - compile_exp_as env StackRep.UnboxedInt e1 ^^ + compile_exp_as env StackRep.bool e1 ^^ G.if_ (ValBlockType None) ( compile_exp_unit env e2 ^^ G.i (Br (nr 1l)) @@ -3305,7 +3341,12 @@ and compile_lit_pat env l = | Syntax.NullLit -> compile_lit_as env StackRep.Vanilla l ^^ G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) - | Syntax.(NatLit _ | IntLit _ | BoolLit _) -> + | Syntax.BoolLit true -> + G.nop + | Syntax.BoolLit false -> + Bool.lit false ^^ + G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + | Syntax.(NatLit _ | IntLit _) -> BoxedInt.unbox env ^^ compile_lit_as env StackRep.UnboxedInt l ^^ G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) diff --git a/src/desugar.ml b/src/desugar.ml index e7e50b8740a..4dc0848a8ae 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -15,6 +15,11 @@ let apply_sign op l = Syntax.(match op, l with | _, _ -> raise (Invalid_argument "Invalid signed pattern") ) +let prim_of_type = function + | Type.Prim p -> p + | Type.Mut (Type.Prim p) -> p + | Type.Non -> Type.Nat (* dead code anyways *) + | t -> raise (Invalid_argument ("non-primitive operator type: " ^ Type.string_of_typ t)) let phrase f x = f x.it @@ x.at let phrase' f x = f x.at x.note x.it @@ x.at @@ -26,9 +31,15 @@ let | S.PrimE p -> I.PrimE p | S.VarE i -> I.VarE i | S.LitE l -> I.LitE !l - | S.UnE (o, e) -> I.UnE (o, exp e) - | S.BinE (e1, o, e2) -> I.BinE (exp e1, o, exp e2) - | S.RelE (e1, o, e2) -> I.RelE (exp e1, o, exp e2) + | S.UnE (o, e) -> + let p = prim_of_type (e.Source.note.S.note_typ) in + I.UnE (p , o, exp e) + | S.BinE (e1, o, e2) -> + let p = prim_of_type (e1.Source.note.S.note_typ) in + I.BinE (p, exp e1, o, exp e2) + | S.RelE (e1, o, e2) -> + let p = prim_of_type (e1.Source.note.S.note_typ) in + I.RelE (p, exp e1, o, exp e2) | S.TupE es -> I.TupE (exps es) | S.ProjE (e, i) -> I.ProjE (exp e, i) | S.OptE e -> I.OptE (exp e) diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index ece1d12f02e..acd6dc2cfef 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -62,9 +62,9 @@ let rec exp e : f = match e.it with | VarE i -> M.singleton i.it {captured = false} | LitE l -> M.empty | PrimE _ -> M.empty - | UnE (uo, e) -> exp e - | BinE (e1, bo, e2) -> exps [e1; e2] - | RelE (e1, ro, e2) -> exps [e1; e2] + | UnE (_, uo, e) -> exp e + | BinE (_, e1, bo, e2)-> exps [e1; e2] + | RelE (_, e1, ro, e2)-> exps [e1; e2] | TupE es -> exps es | ProjE (e, i) -> exp e | ActorE (i, efs) -> close (exp_fields efs) // i.it diff --git a/src/ir.ml b/src/ir.ml index 8f6e38dc0ea..154b7b5bf3b 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -16,9 +16,9 @@ and exp' = | PrimE of string (* primitive *) | VarE of Syntax.id (* variable *) | LitE of Syntax.lit (* literal *) - | UnE of Syntax.unop * exp (* unary operator *) - | BinE of exp * Syntax.binop * exp (* binary operator *) - | RelE of exp * Syntax.relop * exp (* relational operator *) + | UnE of Type.prim * Syntax.unop * exp (* unary operator *) + | BinE of Type.prim * exp * Syntax.binop * exp (* binary operator *) + | RelE of Type.prim * exp * Syntax.relop * exp (* relational operator *) | TupE of exp list (* tuple *) | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) diff --git a/src/type.ml b/src/type.ml index eeb7e5af1a7..27d7f9f5b20 100644 --- a/src/type.ml +++ b/src/type.ml @@ -595,7 +595,7 @@ let string_of_func_sort = function let rec string_of_typ_nullary vs = function | Pre -> "???" | Any -> "Any" - | Non -> "None" + | Non -> "Non" | Shared -> "Shared" | Class -> "Class" | Prim p -> string_of_prim p diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index b9058ffaf5b..4a8a2f469a6 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -11,7 +11,7 @@ non-closed actor: (ActorE (TupT) (BlockE (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) - (ExpD (AssignE (VarE c) (BinE (VarE c) SubOp (LitE (IntLit 1))))) + (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) ) ) ) diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index 5b2baf03eb2..b999990c6f7 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,11 +1,4 @@ 0_0 1_0 2_0 -3_0 -0_0 -0_1 -0_2 -0_3 -!! -<()> -<(Int,Bool)> +dvm: user error (Uncaught RuntimeError: unreachable diff --git a/test/run/ok/account.wasm.stderr.ok b/test/run/ok/account.wasm.stderr.ok index 8b08e7f9c72..9f8f70f418a 100644 --- a/test/run/ok/account.wasm.stderr.ok +++ b/test/run/ok/account.wasm.stderr.ok @@ -71,7 +71,7 @@ non-closed actor: (ActorE (ExpD (AssignE (VarE balance) - (BinE (VarE balance) SubOp (VarE amount)) + (BinE Int (VarE balance) SubOp (VarE amount)) ) ) (ExpD @@ -140,7 +140,10 @@ non-closed actor: (ActorE (BlockE (ExpD (AssertE (IsE (VarE this) (VarE caller)))) (ExpD - (AssignE (VarE balance) (BinE (VarE balance) AddOp (VarE amount))) + (AssignE + (VarE balance) + (BinE Int (VarE balance) AddOp (VarE amount)) + ) ) ) ) diff --git a/test/run/ok/bank-example.wasm.stderr.ok b/test/run/ok/bank-example.wasm.stderr.ok index aa95d4eae3e..f457c77ea70 100644 --- a/test/run/ok/bank-example.wasm.stderr.ok +++ b/test/run/ok/bank-example.wasm.stderr.ok @@ -171,7 +171,7 @@ non-closed actor: (ActorE (ExpD (AssignE (VarE balance) - (BinE (VarE balance) SubOp (VarE amount)) + (BinE Int (VarE balance) SubOp (VarE amount)) ) ) (ExpD @@ -240,7 +240,10 @@ non-closed actor: (ActorE (BlockE (ExpD (AssertE (IsE (VarE self) (VarE caller)))) (ExpD - (AssignE (VarE balance) (BinE (VarE balance) AddOp (VarE amount))) + (AssignE + (VarE balance) + (BinE Int (VarE balance) AddOp (VarE amount)) + ) ) ) ) diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok index 8bc1dd83f40..f1401236c8e 100644 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ b/test/run/ok/bit-ops.wasm.stderr.ok @@ -1,64 +1,120 @@ compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp +of_prim: Word8 compile_binop: OrOp +of_prim: Word8 compile_binop: AndOp +of_prim: Word8 compile_binop: AndOp +of_prim: Word8 compile_binop: XorOp +of_prim: Word8 compile_binop: XorOp +of_prim: Word8 compile_binop: ShiftLOp +of_prim: Word8 compile_binop: ShiftLOp +of_prim: Word8 compile_binop: ShiftROp +of_prim: Word8 compile_binop: ShiftROp +of_prim: Word8 compile_binop: RotLOp +of_prim: Word8 compile_binop: RotLOp +of_prim: Word8 compile_binop: RotROp +of_prim: Word8 compile_binop: RotROp +of_prim: Word8 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp +of_prim: Word16 compile_binop: OrOp +of_prim: Word16 compile_binop: AndOp +of_prim: Word16 compile_binop: AndOp +of_prim: Word16 compile_binop: XorOp +of_prim: Word16 compile_binop: XorOp +of_prim: Word16 compile_binop: ShiftLOp +of_prim: Word16 compile_binop: ShiftLOp +of_prim: Word16 compile_binop: ShiftROp +of_prim: Word16 compile_binop: ShiftROp +of_prim: Word16 compile_binop: RotLOp +of_prim: Word16 compile_binop: RotLOp +of_prim: Word16 compile_binop: RotROp +of_prim: Word16 compile_binop: RotROp +of_prim: Word16 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp +of_prim: Word32 compile_binop: OrOp +of_prim: Word32 compile_binop: AndOp +of_prim: Word32 compile_binop: AndOp +of_prim: Word32 compile_binop: XorOp +of_prim: Word32 compile_binop: XorOp +of_prim: Word32 compile_binop: ShiftLOp +of_prim: Word32 compile_binop: ShiftLOp +of_prim: Word32 compile_binop: ShiftROp +of_prim: Word32 compile_binop: ShiftROp +of_prim: Word32 compile_binop: RotLOp +of_prim: Word32 compile_binop: RotLOp +of_prim: Word32 compile_binop: RotROp +of_prim: Word32 compile_binop: RotROp +of_prim: Word32 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp +of_prim: Word64 compile_binop: OrOp +of_prim: Word64 compile_binop: AndOp +of_prim: Word64 compile_binop: AndOp +of_prim: Word64 compile_binop: XorOp +of_prim: Word64 compile_binop: XorOp +of_prim: Word64 compile_binop: ShiftLOp +of_prim: Word64 compile_binop: ShiftLOp +of_prim: Word64 compile_binop: ShiftROp +of_prim: Word64 compile_binop: ShiftROp +of_prim: Word64 compile_binop: RotLOp +of_prim: Word64 compile_binop: RotLOp +of_prim: Word64 compile_binop: RotROp +of_prim: Word64 compile_binop: RotROp +of_prim: Word64 diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index bccbe186234..66be92a9c1f 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -4,13 +4,71 @@ compile_binop: PowOp compile_binop: PowOp compile_binop: PowOp compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: PowOp +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +compile_binop: PowOp +of_prim: Float +compile_binop: PowOp +of_prim: Float +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +compile_binop: PowOp +of_prim: Word8 +compile_binop: PowOp +of_prim: Word8 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +compile_binop: PowOp +of_prim: Word16 +compile_binop: PowOp +of_prim: Word16 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +compile_binop: PowOp +of_prim: Word32 +compile_binop: PowOp +of_prim: Word32 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +compile_binop: PowOp +of_prim: Word64 +compile_binop: PowOp +of_prim: Word64 diff --git a/test/run/ok/relational-ops.wasm.stderr.ok b/test/run/ok/relational-ops.wasm.stderr.ok new file mode 100644 index 00000000000..b018b665cd4 --- /dev/null +++ b/test/run/ok/relational-ops.wasm.stderr.ok @@ -0,0 +1,72 @@ +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Float +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word8 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word16 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word32 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Word64 +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char +of_prim: Char From 8a0960be130d103e69d4ebbdfc6f820ae3c37999 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 10:38:00 +0100 Subject: [PATCH 26/41] Correctly implement == on Text --- src/compile.ml | 6 +++++- test/run-dfinity/ok/nary-async.dvm-run.ok | 9 ++++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index ddf560dbd70..313343884bb 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2951,7 +2951,11 @@ let compile_binop env t op = let compile_relop env t op = StackRep.of_prim t, Syntax.(match op with - | EqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + | EqOp -> + begin match t with + | Type.Text -> Text.compare env + | _ -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + end | NeqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ G.if_ (StackRep.to_block_type env StackRep.bool) (Bool.lit false) (Bool.lit true) diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index b999990c6f7..5b2baf03eb2 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,4 +1,11 @@ 0_0 1_0 2_0 -dvm: user error (Uncaught RuntimeError: unreachable +3_0 +0_0 +0_1 +0_2 +0_3 +!! +<()> +<(Int,Bool)> From a431331c0426736e681e528dcca0351d19be0bce Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 11:45:24 +0100 Subject: [PATCH 27/41] Numbers are now 64 bits! Not that this is very useful, but it was a good oportunity to add more needed structure to the compiler, e.g. operator overloading (for example, booleans are still 32 bit). This now traps upon `0-1:Nat`. --- src/compile.ml | 353 ++++++++++++++----------- test/run/ok/numeric-ops.wasm.stderr.ok | 48 ++++ test/run/ok/overflow.wasm.stderr.ok | 11 - 3 files changed, 252 insertions(+), 160 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 313343884bb..154ac888c0d 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -304,6 +304,7 @@ end (* Function called compile_* return a list of instructions (and maybe other stuff) *) let compile_unboxed_const i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) +let compile_const_64 i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I64 i))) let compile_unboxed_zero = compile_unboxed_const 0l let compile_unit = compile_unboxed_const 1l (* This needs to be disjoint from all pointers *) @@ -313,15 +314,15 @@ let compile_null = compile_unboxed_const 3l let compile_op_const op i = compile_unboxed_const i ^^ G.i (Binary (Wasm.Values.I32 op)) -let compile_add_const = compile_op_const Wasm_copy.Ast.I32Op.Add -let compile_sub_const = compile_op_const Wasm_copy.Ast.I32Op.Sub -let compile_mul_const = compile_op_const Wasm_copy.Ast.I32Op.Mul -let compile_divU_const = compile_op_const Wasm_copy.Ast.I32Op.DivU +let compile_add_const = compile_op_const I32Op.Add +let compile_sub_const = compile_op_const I32Op.Sub +let compile_mul_const = compile_op_const I32Op.Mul +let compile_divU_const = compile_op_const I32Op.DivU (* Locals *) -let new_local_ env name = - let i = E.add_anon_local env I32Type in +let new_local_ env t name = + let i = E.add_anon_local env t in E.add_local_name env i name; ( G.i (SetLocal (nr i)) , G.i (GetLocal (nr i)) @@ -329,7 +330,11 @@ let new_local_ env name = ) let new_local env name = - let (set_i, get_i, _) = new_local_ env name + let (set_i, get_i, _) = new_local_ env I32Type name + in (set_i, get_i) + +let _new_local64 env name = + let (set_i, get_i, _) = new_local_ env I64Type name in (set_i, get_i) (* Some code combinators *) @@ -350,7 +355,7 @@ let from_0_to_n env mk_body = compile_while ( get_i ^^ get_n ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ) ( mk_body get_i ^^ @@ -372,8 +377,8 @@ module Func = struct let of_body env params retty mk_body = let env1 = E.mk_fun_env env (Int32.of_int (List.length params)) (List.length retty) in - List.iteri (fun i n -> E.add_local_name env1 (Int32.of_int i) n) params; - let ty = FuncType (List.map (fun _ -> I32Type) params, retty) in + List.iteri (fun i (n,_t) -> E.add_local_name env1 (Int32.of_int i) n) params; + let ty = FuncType (List.map snd params, retty) in let body = G.to_instr_list (mk_body env1) in (nr { ftype = nr (E.func_type env ty); locals = E.get_locals env1; @@ -405,7 +410,7 @@ module Heap = struct (* Dynamic allocation *) let dyn_alloc_words env = - Func.share_code env "alloc_words" ["n"] [I32Type] (fun env -> + Func.share_code env "alloc_words" ["n", I32Type] [I32Type] (fun env -> let get_n = G.i (GetLocal (nr 0l)) in (* expect the size (in words), returns the pointer *) @@ -417,12 +422,12 @@ module Heap = struct (* Add to old heap value *) G.i (GetGlobal (nr heap_ptr)) ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (SetGlobal (nr heap_ptr)) ) let dyn_alloc_bytes env = - Func.share_code env "alloc_bytes" ["n"] [I32Type] (fun env -> + Func.share_code env "alloc_bytes" ["n", I32Type] [I32Type] (fun env -> let get_n = G.i (GetLocal (nr 0l)) in get_n ^^ @@ -444,11 +449,17 @@ module Heap = struct let load_field (i : int32) : G.t = G.i (Load {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let load_field64 (i : int32) : G.t = + G.i (Load {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let store_field (i : int32) : G.t = G.i (Store {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let store_field64 (i : int32) : G.t = + G.i (Store {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + (* Create a heap object with instructions that fill in each word *) - let obj env element_instructions : G.t = + let obj env element_instructions : G.t = let n = List.length element_instructions in let (set_i, get_i) = new_local env "heap_object" in @@ -469,7 +480,7 @@ module Heap = struct (* Convenience functions around memory *) let memcpy env = - Func.share_code env "memcpy" ["from"; "two"; "n"] [] (fun env -> + Func.share_code env "memcpy" ["from", I32Type; "two", I32Type; "n", I32Type] [] (fun env -> let get_from = G.i (GetLocal (nr 0l)) in let get_to = G.i (GetLocal (nr 1l)) in let get_n = G.i (GetLocal (nr 2l)) in @@ -477,11 +488,11 @@ module Heap = struct from_0_to_n env (fun get_i -> get_to ^^ get_i ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_from ^^ get_i ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) @@ -505,7 +516,7 @@ module ElemHeap = struct (* Assumes a reference on the stack, and replaces it with an index into the reference table *) let remember_reference env : G.t = - Func.share_code env "remember_reference" ["ref"] [I32Type] (fun env -> + Func.share_code env "remember_reference" ["ref", I32Type] [I32Type] (fun env -> let get_ref = G.i (GetLocal (nr 0l)) in (* Return index *) @@ -526,7 +537,7 @@ module ElemHeap = struct (* Assumes a index into the table on the stack, and replaces it with the reference *) let recall_reference env : G.t = - Func.share_code env "recall_reference" ["ref_idx"] [I32Type] (fun env -> + Func.share_code env "recall_reference" ["ref_idx", I32Type] [I32Type] (fun env -> let get_ref_idx = G.i (GetLocal (nr 0l)) in get_ref_idx ^^ compile_mul_const Heap.word_size ^^ @@ -552,7 +563,7 @@ module ClosureTable = struct (* Assumes a reference on the stack, and replaces it with an index into the reference table *) let remember_closure env : G.t = - Func.share_code env "remember_closure" ["ptr"] [I32Type] (fun env -> + Func.share_code env "remember_closure" ["ptr", I32Type] [I32Type] (fun env -> let get_ptr = G.i (GetLocal (nr 0l)) in (* Return index *) @@ -575,7 +586,7 @@ module ClosureTable = struct (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) let recall_closure env : G.t = - Func.share_code env "recall_closure" ["closure_idx"] [I32Type] (fun env -> + Func.share_code env "recall_closure" ["closure_idx", I32Type] [I32Type] (fun env -> let get_closure_idx = G.i (GetLocal (nr 0l)) in get_closure_idx ^^ compile_mul_const Heap.word_size ^^ @@ -592,33 +603,35 @@ module BitTagged = struct *) let if_unboxed env retty is1 is2 = - Func.share_code env "is_unboxed" ["x"] [I32Type] (fun env -> + Func.share_code env "is_unboxed" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in (* Get bit *) get_x ^^ compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.And)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^ (* Check bit *) compile_unboxed_const 1l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) (compile_unboxed_const 1l ^^ G.i Return) G.nop ^^ (* Also check if it is the null-pointer *) get_x ^^ compile_unboxed_const 0l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ) ^^ G.if_ retty is1 is2 let untag_scalar env = compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.ShrU)) + G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) let tag = + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Or)) + G.i (Binary (Wasm.Values.I32 I32Op.Or)) end (* BitTagged *) @@ -677,7 +690,7 @@ module Tagged = struct | ((tag, code) :: cases) -> get_tag ^^ compile_unboxed_const (int_of_tag tag) ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ retty code (go cases) in load ^^ @@ -946,7 +959,7 @@ end (* Closure *) module BoxedInt = struct - (* We store large nats and ints in immutable boxed 32bit heap objects. + (* We store large nats and ints in immutable boxed 64bit heap objects. Eventually, this should contain the bigint implementation. Small values (<2^5, so that both paths are tested) are stored unboxed, @@ -955,23 +968,32 @@ module BoxedInt = struct let payload_field = Int32.add Tagged.header_size 0l - let box env = Func.share_code env "box_int" ["n"] [I32Type] (fun env -> + let compile_box env compile_elem : G.t = + let (set_i, get_i) = new_local env "boxed_int" in + Heap.alloc env 3l ^^ + set_i ^^ + get_i ^^ Tagged.store Tagged.Int ^^ + get_i ^^ compile_elem ^^ Heap.store_field64 1l ^^ + get_i + + let box env = Func.share_code env "box_int" ["n", I64Type] [I32Type] (fun env -> let get_n = G.i (GetLocal (nr 0l)) in - get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 5)) ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + get_n ^^ compile_const_64 (Int64.of_int (1 lsl 5)) ^^ + G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ G.if_ (ValBlockType (Some I32Type)) (get_n ^^ BitTagged.tag) - (Tagged.obj env Tagged.Int [ G.i (GetLocal (nr 0l)) ]) + (compile_box env get_n) ) - let unbox env = Func.share_code env "unbox_int" ["n"] [I32Type] (fun env -> + + let unbox env = Func.share_code env "unbox_int" ["n", I32Type] [I64Type] (fun env -> let get_n = G.i (GetLocal (nr 0l)) in get_n ^^ - BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - (get_n ^^ BitTagged.untag_scalar env) - (get_n ^^ Heap.load_field payload_field) + BitTagged.if_unboxed env (ValBlockType (Some I64Type)) + ( get_n ^^ BitTagged.untag_scalar env) + ( get_n ^^ Heap.load_field64 payload_field) ) - let lit env n = compile_unboxed_const n ^^ box env + let lit env n = compile_const_64 n ^^ box env end (* BoxedInt *) @@ -983,13 +1005,13 @@ module Prim = struct set_i ^^ get_i ^^ BoxedInt.unbox env ^^ - compile_unboxed_zero ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) ^^ + compile_const_64 0L ^^ + G.i (Compare (Wasm.Values.I64 I64Op.LtS)) ^^ G.if_ (ValBlockType (Some I32Type)) - ( compile_unboxed_zero ^^ + ( compile_const_64 0L ^^ get_i ^^ BoxedInt.unbox env ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.Sub)) ^^ BoxedInt.box env ) ( get_i ) @@ -1025,7 +1047,7 @@ module Object = struct let sz = Int32.of_int (FieldEnv.cardinal name_pos_map) in (* Allocate memory *) - let (set_ri, get_ri, ri) = new_local_ env "obj" in + let (set_ri, get_ri, ri) = new_local_ env I32Type "obj" in Heap.alloc env (Int32.add header_size (Int32.mul 2l sz)) ^^ set_ri ^^ @@ -1068,7 +1090,7 @@ module Object = struct (* Returns a pointer to the object field *) let idx_hash env = - Func.share_code env "obj_idx" ["x"; "hash"] [I32Type] (fun env -> + Func.share_code env "obj_idx" ["x", I32Type; "hash", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in let get_hash = G.i (GetLocal (nr 1l)) in let (set_f, get_f) = new_local env "f" in @@ -1083,13 +1105,13 @@ module Object = struct compile_add_const header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_f ^^ get_f ^^ Heap.load_field 0l ^^ (* the hash field *) get_hash ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) ( get_f ^^ compile_add_const Heap.word_size ^^ @@ -1148,7 +1170,7 @@ module Text = struct compile_unboxed_const ptr (* Two strings on stack *) - let concat env = Func.share_code env "concat" ["x"; "y"] [I32Type] (fun env -> + let concat env = Func.share_code env "concat" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in let get_y = G.i (GetLocal (nr 1l)) in let (set_z, get_z) = new_local env "z" in @@ -1162,8 +1184,8 @@ module Text = struct compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ get_len2 ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.dyn_alloc_bytes env ^^ set_z ^^ @@ -1174,7 +1196,7 @@ module Text = struct get_z ^^ get_len1 ^^ get_len2 ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.store_field len_field ^^ (* Copy first string *) @@ -1195,7 +1217,7 @@ module Text = struct get_z ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_len2 ^^ @@ -1206,7 +1228,7 @@ module Text = struct ) (* Two strings on stack *) - let compare env = Func.share_code env "Text.compare" ["x"; "y"] [I32Type] (fun env -> + let compare env = Func.share_code env "Text.compare" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in let get_y = G.i (GetLocal (nr 1l)) in let (set_len1, get_len1) = new_local env "len1" in @@ -1217,7 +1239,7 @@ module Text = struct get_len1 ^^ get_len2 ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) G.nop (Bool.lit false ^^ G.i Return) ^^ (* We could do word-wise comparisons if we know that the trailing bytes @@ -1227,16 +1249,16 @@ module Text = struct get_x ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ get_y ^^ compile_add_const (Int32.mul Heap.word_size header_size) ^^ get_i ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) G.nop (Bool.lit false ^^ G.i Return) ) ^^ Bool.lit true @@ -1251,7 +1273,7 @@ module Array = struct (* Dynamic array access. Returns the address of the field. Does bounds checking *) - let idx env = Func.share_code env "Array.idx" ["array"; "idx"] [I32Type] (fun env -> + let idx env = Func.share_code env "Array.idx" ["array", I32Type; "idx", I32Type] [I32Type] (fun env -> let get_array = G.i (GetLocal (nr 0l)) in let get_idx = G.i (GetLocal (nr 1l)) in @@ -1260,14 +1282,14 @@ module Array = struct get_idx ^^ get_array ^^ Heap.load_field len_field ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ get_idx ^^ compile_add_const header_size ^^ compile_mul_const element_size ^^ get_array ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ) (* Expects on the stack the pointer to the array. *) @@ -1281,47 +1303,51 @@ module Array = struct let get_second_arg = G.i (GetLocal (nr 2l)) in E.define_built_in env "array_get" - (fun () -> Func.of_body env ["clos"; "idx"] [I32Type] (fun env1 -> + (fun () -> Func.of_body env ["clos", I32Type; "idx", I32Type] [I32Type] (fun env1 -> get_array_object ^^ get_first_arg ^^ (* the index *) BoxedInt.unbox env1 ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ idx env ^^ load_ptr )); E.define_built_in env "array_set" - (fun () -> Func.of_body env ["clos"; "idx"; "val"] [] (fun env1 -> + (fun () -> Func.of_body env ["clos", I32Type; "idx", I32Type; "val", I32Type] [] (fun env1 -> get_array_object ^^ get_first_arg ^^ (* the index *) BoxedInt.unbox env1 ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ idx env ^^ get_second_arg ^^ (* the value *) store_ptr )); E.define_built_in env "array_len" - (fun () -> Func.of_body env ["clos"] [I32Type] (fun env1 -> + (fun () -> Func.of_body env ["clos", I32Type] [I32Type] (fun env1 -> get_array_object ^^ Heap.load_field len_field ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) ^^ BoxedInt.box env1 )); - let mk_next_fun mk_code : E.func_with_names = Func.of_body env ["clos"] [I32Type] (fun env1 -> + let mk_next_fun mk_code : E.func_with_names = Func.of_body env ["clos", I32Type] [I32Type] (fun env1 -> let (set_boxed_i, get_boxed_i) = new_local env1 "boxed_n" in let (set_i, get_i) = new_local env1 "n" in (* Get pointer to counter from closure *) Closure.load_closure 0l ^^ - (* Read pointer *) + (* Get current counter (boxed) *) Var.load ^^ set_boxed_i ^^ + + (* Get current counter (unboxed) *) get_boxed_i ^^ BoxedInt.unbox env1 ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ set_i ^^ get_i ^^ - (* Get pointer to array from closure *) - Closure.load_closure 1l ^^ (* Get length *) - Heap.load_field len_field ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + Closure.load_closure 1l ^^ Heap.load_field len_field ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (* Then *) compile_null @@ -1331,6 +1357,7 @@ module Array = struct (* Store increased counter *) get_i ^^ compile_add_const 1l ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) ^^ BoxedInt.box env1 ^^ Var.store ^^ (* Return stuff *) @@ -1339,11 +1366,11 @@ module Array = struct ) ) ) in - let mk_iterator next_funid = Func.of_body env ["clos"] [I32Type] (fun env1 -> + let mk_iterator next_funid = Func.of_body env ["clos", I32Type] [I32Type] (fun env1 -> (* next function *) let (set_ni, get_ni) = new_local env1 "next" in Closure.fixed_closure env1 next_funid - [ Tagged.obj env1 Tagged.MutBox [ BoxedInt.lit env1 0l ] + [ Tagged.obj env1 Tagged.MutBox [ BoxedInt.lit env1 0L ] ; get_array_object ] ^^ set_ni ^^ @@ -1397,6 +1424,7 @@ module Array = struct let (set_r, get_r) = new_local env "r" in set_x ^^ BoxedInt.unbox env ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ set_len ^^ (* Allocate *) @@ -1429,6 +1457,7 @@ module Array = struct let (set_r, get_r) = new_local env "r" in set_f ^^ BoxedInt.unbox env ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ set_len ^^ (* Allocate *) @@ -1450,7 +1479,10 @@ module Array = struct (* The closure *) get_r ^^ get_i ^^ idx env ^^ (* The arg *) - get_f ^^ get_i ^^ BoxedInt.box env ^^ + get_f ^^ + get_i ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) ^^ + BoxedInt.box env ^^ (* The closure again *) get_r ^^ get_i ^^ idx env ^^ (* Call *) @@ -1464,7 +1496,7 @@ module Array = struct if n = 0 then compile_unit else let name = Printf.sprintf "to_%i_tuple" n in - let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in Func.share_code env name args [I32Type] (fun env -> lit env (Lib.List.table n (fun i -> G.i (GetLocal (nr (Int32.of_int i))))) ) @@ -1474,7 +1506,7 @@ module Array = struct if n = 0 then G.i Drop else let name = Printf.sprintf "from_%i_tuple" n in let retty = Lib.List.make n I32Type in - Func.share_code env name ["tup"] retty (fun env -> + Func.share_code env name ["tup", I32Type] retty (fun env -> let get_tup = G.i (GetLocal (nr 0l)) in G.table n (fun i -> get_tup ^^ load_n (Int32.of_int i)) ) @@ -1615,7 +1647,7 @@ module Dfinity = struct let compile_databuf_of_text env = - Func.share_code env "databuf_of_text" ["string"] [I32Type] (fun env -> + Func.share_code env "databuf_of_text" ["string", I32Type] [I32Type] (fun env -> let get_i = G.i (GetLocal (nr 0l)) in (* Calculate the offset *) @@ -1645,6 +1677,7 @@ module Dfinity = struct if E.mode env = DfinityMode then BoxedInt.unbox env ^^ + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ G.i (Call (nr (test_show_i32_i env))) ^^ G.i (Call (nr (test_print_i env))) else @@ -1736,7 +1769,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_unboxed_const 0l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) (* First run, call the start function *) ( G.i (Call (nr start_funid)) ) @@ -1772,7 +1805,7 @@ module OrthogonalPersistence = struct compile_unboxed_const ElemHeap.table_end ^^ G.i (GetGlobal (nr Heap.heap_ptr)) ^^ compile_unboxed_const ElemHeap.table_end ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ G.i (SetGlobal (nr mem_global)) ^^ @@ -1821,7 +1854,7 @@ module Serialization = struct let serialize_go env = - Func.share_code env "serialize_go" ["x"] [I32Type] (fun env -> + Func.share_code env "serialize_go" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in let (set_copy, get_copy) = new_local env "x" in @@ -1940,14 +1973,14 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_i ^^ compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ load_ptr ^^ @@ -1960,7 +1993,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_copy ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ get_i ^^ @@ -1968,7 +2001,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ compile_add_const Heap.word_size ^^ load_ptr ^^ @@ -1982,7 +2015,7 @@ module Serialization = struct ) let shift_pointer_at env = - Func.share_code env "shift_pointer_at" ["loc"; "ptr_offset"] [] (fun env -> + Func.share_code env "shift_pointer_at" ["loc", I32Type; "ptr_offset", I32Type] [] (fun env -> let get_loc = G.i (GetLocal (nr 0l)) in let get_ptr_offset = G.i (GetLocal (nr 1l)) in let (set_ptr, get_ptr) = new_local env "ptr" in @@ -1996,19 +2029,19 @@ module Serialization = struct ( get_loc ^^ get_ptr ^^ get_ptr_offset ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ store_ptr ) ) (* Returns the object size (in bytes) *) let object_size env = - Func.share_code env "object_size" ["x"] [I32Type] (fun env -> + Func.share_code env "object_size" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const (Int32.mul 3l Heap.word_size) ; Tagged.Reference, compile_unboxed_const (Int32.mul 2l Heap.word_size) ; Tagged.Some, @@ -2051,12 +2084,12 @@ module Serialization = struct (* While we have not reached the end of the area *) ( get_x ^^ compile_to ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ) ( mk_code get_x ^^ get_x ^^ get_x ^^ object_size env ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_x ) @@ -2103,7 +2136,7 @@ module Serialization = struct compile_add_const Object.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) @@ -2116,14 +2149,14 @@ module Serialization = struct compile_add_const Closure.header_size ^^ compile_mul_const Heap.word_size ^^ get_x ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr_loc ^^ mk_code get_ptr_loc ) ] let shift_pointers env = - Func.share_code env "shift_pointers" ["start"; "to"; "ptr_offset"] [] (fun env -> + Func.share_code env "shift_pointers" ["start", I32Type; "to", I32Type; "ptr_offset", I32Type] [] (fun env -> let get_start = G.i (GetLocal (nr 0l)) in let get_to = G.i (GetLocal (nr 1l)) in let get_ptr_offset = G.i (GetLocal (nr 2l)) in @@ -2138,7 +2171,7 @@ module Serialization = struct ) let extract_references env = - Func.share_code env "extract_references" ["start"; "to"; "tbl_area"] [I32Type] (fun env -> + Func.share_code env "extract_references" ["start", I32Type; "to", I32Type; "tbl_area", I32Type] [I32Type] (fun env -> let get_start = G.i (GetLocal (nr 0l)) in let get_to = G.i (GetLocal (nr 1l)) in let get_tbl_area = G.i (GetLocal (nr 2l)) in @@ -2153,7 +2186,7 @@ module Serialization = struct (* Adjust reference *) get_tbl_area ^^ get_i ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_x ^^ Heap.load_field 1l ^^ ElemHeap.recall_reference env ^^ @@ -2172,7 +2205,7 @@ module Serialization = struct ) let intract_references env = - Func.share_code env "intract_references" ["start"; "to"; "tbl_area"] [] (fun env -> + Func.share_code env "intract_references" ["start", I32Type; "to", I32Type; "tbl_area", I32Type] [] (fun env -> let get_start = G.i (GetLocal (nr 0l)) in let get_to = G.i (GetLocal (nr 1l)) in let get_tbl_area = G.i (GetLocal (nr 2l)) in @@ -2187,7 +2220,7 @@ module Serialization = struct Heap.load_field 1l ^^ compile_mul_const Heap.word_size ^^ get_tbl_area ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ load_ptr ^^ ElemHeap.remember_reference env ^^ Heap.store_field 1l @@ -2197,8 +2230,8 @@ module Serialization = struct let serialize env = if E.mode env <> DfinityMode - then Func.share_code env "serialize" ["x"] [I32Type] (fun env -> G.i Unreachable) - else Func.share_code env "serialize" ["x"] [I32Type] (fun env -> + then Func.share_code env "serialize" ["x", I32Type] [I32Type] (fun env -> G.i Unreachable) + else Func.share_code env "serialize" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (GetLocal (nr 0l)) in let (set_start, get_start) = new_local env "old_heap" in @@ -2239,7 +2272,7 @@ module Serialization = struct (* Adjust pointers *) get_start ^^ get_end ^^ - compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ shift_pointers env ^^ (* Extract references, and remember how many there were *) @@ -2252,14 +2285,14 @@ module Serialization = struct (* Create databuf *) get_start ^^ - get_end ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + get_end ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ set_databuf ^^ (* Append this reference at the end of the extracted references *) get_end ^^ get_tbl_size ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_databuf ^^ store_ptr ^^ (* And bump table end *) @@ -2280,7 +2313,7 @@ module Serialization = struct | 1 -> serialize env | _ -> let name = Printf.sprintf "serialize_%i" n in - let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i) in + let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in let retty = Lib.List.make n I32Type in Func.share_code env name args retty (fun env -> G.table n (fun i -> @@ -2289,7 +2322,7 @@ module Serialization = struct ) let deserialize env = - Func.share_code env "deserialize" ["ref"] [I32Type] (fun env -> + Func.share_code env "deserialize" ["ref", I32Type] [I32Type] (fun env -> let get_elembuf = G.i (GetLocal (nr 0l)) in let (set_databuf, get_databuf) = new_local env "databuf" in let (set_start, get_start) = new_local env "start" in @@ -2325,7 +2358,7 @@ module Serialization = struct (* Check if we got something unboxed (data buf size 1 word) *) get_data_len ^^ compile_unboxed_const Heap.word_size ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (* Yes, we got something unboxed. Return it, and do _not_ bump the heap pointer *) ( get_start ^^ load_ptr ) @@ -2333,7 +2366,7 @@ module Serialization = struct ( (* update heap pointer *) get_start ^^ get_data_len ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (SetGlobal (nr Heap.heap_ptr)) ^^ (* Fix pointers *) @@ -2381,7 +2414,7 @@ module GC = struct to after end_to_space, and replace it with a pointer, adjusted for where the object will be finally. *) (* Invariant: Must not be called on the same pointer twice. *) - let evacuate env = Func.share_code env "evaucate" ["begin_from_space"; "begin_to_space"; "end_to_space"; "ptr_loc"] [I32Type] (fun env -> + let evacuate env = Func.share_code env "evaucate" ["begin_from_space", I32Type; "begin_to_space", I32Type; "end_to_space", I32Type; "ptr_loc", I32Type] [I32Type] (fun env -> let get_begin_from_space = G.i (GetLocal (nr 0l)) in let get_begin_to_space = G.i (GetLocal (nr 1l)) in let get_end_to_space = G.i (GetLocal (nr 2l)) in @@ -2398,7 +2431,7 @@ module GC = struct (* If this is static, ignore it *) get_obj ^^ get_begin_from_space ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtU)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType None) (get_end_to_space ^^ G.i Return) G.nop ^^ (* If this is an indirection, just use that value *) @@ -2422,9 +2455,9 @@ module GC = struct (* Calculate new pointer *) get_end_to_space ^^ get_begin_to_space ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ get_begin_from_space ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_new_ptr ^^ (* Set indirection *) @@ -2442,7 +2475,7 @@ module GC = struct (* Calculate new end of to space *) get_end_to_space ^^ get_len ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ) let register env (end_of_static_space : int32) = Func.define_built_in env "collect" [] [] (fun env -> @@ -2489,13 +2522,13 @@ module GC = struct (* Copy the to-space to the beginning of memory. *) get_begin_to_space ^^ get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ + get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ Heap.memcpy env ^^ (* Reset the heap pointer *) get_begin_from_space ^^ - get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) ^^ + get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ G.i (SetGlobal (nr Heap.heap_ptr)) ) @@ -2527,7 +2560,7 @@ module FuncDec = struct G.i (CallIndirect (nr (message_ty env cc))) let export_self_message env = - Func.share_code env "export_self_message" ["name"] [I32Type] (fun env -> + Func.share_code env "export_self_message" ["name", I32Type] [I32Type] (fun env -> let get_name = G.i (GetLocal (nr 0l)) in Tagged.obj env Tagged.Reference [ @@ -2547,9 +2580,9 @@ module FuncDec = struct Parameter `captured` should contain the, well, captured local variables that the function will find in the closure. *) let compile_local_function env cc restore_env mk_pat mk_body at = - let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in + let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in let retty = Lib.List.make cc.Value.n_res I32Type in - Func.of_body env (["clos"] @ args) retty (fun env1 -> G.with_region at ( + Func.of_body env (["clos", I32Type] @ args) retty (fun env1 -> G.with_region at ( let get_closure = G.i (GetLocal (E.unary_closure_local env1)) in let (env2, closure_code) = restore_env env1 get_closure in @@ -2573,9 +2606,9 @@ module FuncDec = struct - Fake orthogonal persistence *) let compile_message env cc restore_env mk_pat mk_body at = - let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in + let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in assert (cc.Value.n_res = 0); - Func.of_body env (["clos"] @ args) [] (fun env1 -> G.with_region at ( + Func.of_body env (["clos", I32Type] @ args) [] (fun env1 -> G.with_region at ( (* Restore memory *) OrthogonalPersistence.restore_mem env1 ^^ @@ -2608,7 +2641,7 @@ module FuncDec = struct (* A static message, from a public actor field *) (* Like compile__message, but no closure *) let compile_static_message env cc mk_pat mk_body at : E.func_with_names = - let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i) in + let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in assert (cc.Value.n_res = 0); (* Messages take no closure, return nothing*) Func.of_body env args [] (fun env1 -> @@ -2789,7 +2822,7 @@ module StackRep = struct let to_block_type env = function | Vanilla -> ValBlockType (Some I32Type) - | UnboxedInt -> ValBlockType (Some I32Type) + | UnboxedInt -> ValBlockType (Some I64Type) | UnboxedTuple 0 -> ValBlockType None | UnboxedTuple 1 -> ValBlockType (Some I32Type) | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) @@ -2903,10 +2936,10 @@ let compile_lit env lit = Syntax.(match lit with | BoolLit true -> StackRep.bool, Bool.lit true (* This maps int to int32, instead of a proper arbitrary precision library *) | IntLit n -> StackRep.UnboxedInt, - (try compile_unboxed_const (Big_int.int32_of_big_int n) + (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) | NatLit n -> StackRep.UnboxedInt, - (try compile_unboxed_const (Big_int.int32_of_big_int n) + (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) | NullLit -> StackRep.Vanilla, compile_null | TextLit t -> StackRep.Vanilla, Text.lit env t @@ -2920,11 +2953,11 @@ let compile_lit_as env sr_out lit = let compile_unop env t op = Syntax.(match op with | NegOp -> StackRep.UnboxedInt, - Func.share_code env "neg" ["n"] [I32Type] (fun env -> + Func.share_code env "neg" ["n", I64Type] [I64Type] (fun env -> let get_n = G.i (GetLocal (nr 0l)) in - compile_unboxed_zero ^^ + compile_const_64 0L ^^ get_n ^^ - G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) + G.i (Binary (Wasm.Values.I64 I64Op.Sub)) ) | PosOp -> StackRep.UnboxedInt, @@ -2938,31 +2971,51 @@ let compile_unop env t op = Syntax.(match op with *) let compile_binop env t op = StackRep.of_prim t, - Syntax.(match op with - | AddOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Add)) - | SubOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Sub)) - | MulOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Mul)) - | DivOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.DivU)) - | ModOp -> G.i (Binary (Wasm.Values.I32 Wasm_copy.Ast.I32Op.RemU)) - | CatOp -> Text.concat env + Syntax.(match t, op with + | Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Nat, SubOp -> + Func.share_code env "nat_sub" ["n1", I64Type; "n2", I64Type] [I64Type] (fun env -> + let get_n1 = G.i (GetLocal (nr 0l)) in + let get_n2 = G.i (GetLocal (nr 1l)) in + get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ + G.if_ (StackRep.to_block_type env StackRep.UnboxedInt) + (G.i Unreachable) + (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) + ) + | Type.Nat, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.Nat, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.Nat, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.Int, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Int, SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) + | Type.Int, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.Int, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.Text, CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) ) +let compile_eq env t = match t with + | Type.Text -> Text.compare env + | Type.Bool -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + | Type.Nat | Type.Int -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) + | _ -> G.i Unreachable + let compile_relop env t op = StackRep.of_prim t, - Syntax.(match op with - | EqOp -> - begin match t with - | Type.Text -> Text.compare env - | _ -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) - end - | NeqOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + Syntax.(match t, op with + | _, EqOp -> compile_eq env t + | _, NeqOp -> compile_eq env t ^^ G.if_ (StackRep.to_block_type env StackRep.bool) (Bool.lit false) (Bool.lit true) - | GeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GeS)) - | GtOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.GtS)) - | LeOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LeS)) - | LtOp -> G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.LtS)) + | Type.Nat, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeU)) + | Type.Nat, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtU)) + | Type.Nat, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeU)) + | Type.Nat, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtU)) + | Type.Int, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeS)) + | Type.Int, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtS)) + | Type.Int, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeS)) + | Type.Int, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtS)) + | _ -> G.i Unreachable ) @@ -2977,6 +3030,7 @@ let rec compile_lexp (env : E.t) exp = | IdxE (e1,e2) -> compile_exp_vanilla env e1 ^^ (* offset to array *) compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ Array.idx env, store_ptr | DotE (e, n) -> @@ -2993,6 +3047,7 @@ and compile_exp (env : E.t) exp = StackRep.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to array *) compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) + G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ Array.idx env ^^ load_ptr | DotE (e, ({it = Syntax.Name n;_} as name)) -> @@ -3113,7 +3168,7 @@ and compile_exp (env : E.t) exp = Heap.load_field Object.class_position ^^ (* Equal? *) get_j ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (Bool.lit true) (* Static function id? *) @@ -3123,7 +3178,7 @@ and compile_exp (env : E.t) exp = Heap.load_field 0l ^^ (* get the function id *) compile_mul_const Heap.word_size ^^ compile_add_const 1l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ) ] | BlockE decs -> @@ -3255,7 +3310,7 @@ and compile_exp (env : E.t) exp = (* Check for null *) get_oi ^^ compile_null ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) G.nop ( alloc_code ^^ get_oi ^^ Opt.project ^^ @@ -3344,16 +3399,16 @@ and compile_lit_pat env l = match l with | Syntax.NullLit -> compile_lit_as env StackRep.Vanilla l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | Syntax.BoolLit true -> G.nop | Syntax.BoolLit false -> Bool.lit false ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | Syntax.(NatLit _ | IntLit _) -> BoxedInt.unbox env ^^ compile_lit_as env StackRep.UnboxedInt l ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) + compile_eq env Type.Nat | Syntax.(TextLit t) -> Text.lit env t ^^ Text.compare env @@ -3370,7 +3425,7 @@ and fill_pat env pat : patternCode = set_i ^^ get_i ^^ compile_null ^^ - G.i (Compare (Wasm.Values.I32 Wasm_copy.Ast.I32Op.Eq)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) fail_code ( get_i ^^ Opt.project ^^ diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index 66be92a9c1f..29912e7004a 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -4,69 +4,117 @@ compile_binop: PowOp compile_binop: PowOp compile_binop: PowOp compile_binop: PowOp +compile_binop: AddOp of_prim: Float +compile_binop: AddOp of_prim: Float +compile_binop: SubOp of_prim: Float +compile_binop: SubOp of_prim: Float +compile_binop: MulOp of_prim: Float +compile_binop: MulOp of_prim: Float +compile_binop: DivOp of_prim: Float +compile_binop: DivOp of_prim: Float compile_binop: PowOp of_prim: Float compile_binop: PowOp of_prim: Float +compile_binop: AddOp of_prim: Word8 +compile_binop: AddOp of_prim: Word8 +compile_binop: SubOp of_prim: Word8 +compile_binop: SubOp of_prim: Word8 +compile_binop: MulOp of_prim: Word8 +compile_binop: MulOp of_prim: Word8 +compile_binop: DivOp of_prim: Word8 +compile_binop: DivOp of_prim: Word8 +compile_binop: ModOp of_prim: Word8 +compile_binop: ModOp of_prim: Word8 compile_binop: PowOp of_prim: Word8 compile_binop: PowOp of_prim: Word8 +compile_binop: AddOp of_prim: Word16 +compile_binop: AddOp of_prim: Word16 +compile_binop: SubOp of_prim: Word16 +compile_binop: SubOp of_prim: Word16 +compile_binop: MulOp of_prim: Word16 +compile_binop: MulOp of_prim: Word16 +compile_binop: DivOp of_prim: Word16 +compile_binop: DivOp of_prim: Word16 +compile_binop: ModOp of_prim: Word16 +compile_binop: ModOp of_prim: Word16 compile_binop: PowOp of_prim: Word16 compile_binop: PowOp of_prim: Word16 +compile_binop: AddOp of_prim: Word32 +compile_binop: AddOp of_prim: Word32 +compile_binop: SubOp of_prim: Word32 +compile_binop: SubOp of_prim: Word32 +compile_binop: MulOp of_prim: Word32 +compile_binop: MulOp of_prim: Word32 +compile_binop: DivOp of_prim: Word32 +compile_binop: DivOp of_prim: Word32 +compile_binop: ModOp of_prim: Word32 +compile_binop: ModOp of_prim: Word32 compile_binop: PowOp of_prim: Word32 compile_binop: PowOp of_prim: Word32 +compile_binop: AddOp of_prim: Word64 +compile_binop: AddOp of_prim: Word64 +compile_binop: SubOp of_prim: Word64 +compile_binop: SubOp of_prim: Word64 +compile_binop: MulOp of_prim: Word64 +compile_binop: MulOp of_prim: Word64 +compile_binop: DivOp of_prim: Word64 +compile_binop: DivOp of_prim: Word64 +compile_binop: ModOp of_prim: Word64 +compile_binop: ModOp of_prim: Word64 compile_binop: PowOp of_prim: Word64 diff --git a/test/run/ok/overflow.wasm.stderr.ok b/test/run/ok/overflow.wasm.stderr.ok index 362c8a99d5f..aa4d8670bab 100644 --- a/test/run/ok/overflow.wasm.stderr.ok +++ b/test/run/ok/overflow.wasm.stderr.ok @@ -1,16 +1,5 @@ -compile_lit: Overflow in literal 9223372036854775807 compile_lit: Overflow in literal 9223372036854775808 compile_lit: Overflow in literal 9223372036854775808 compile_lit: Overflow in literal 9223372036854775808 -compile_lit: Overflow in literal 4294967295 -compile_lit: Overflow in literal 4294967296 -compile_lit: Overflow in literal 4611686018427387903 -compile_lit: Overflow in literal 4611686018427387904 -compile_lit: Overflow in literal 4611686018427387904 -compile_lit: Overflow in literal 2305843009213693952 -compile_lit: Overflow in literal 6917529027641081856 -compile_lit: Overflow in literal 2305843009213693952 -compile_lit: Overflow in literal 1152921504606846976 -compile_lit: Overflow in literal 1152921504606846976 compile_lit: Overflow in literal 72462525423451963967165868 compile_lit: Overflow in literal 1314235251543424342678909 From 0e465e6e0072325e10e49687c1130a91a90781d4 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 11:53:55 +0100 Subject: [PATCH 28/41] Overloading of BinE: Use result type, not argument type otherwise `(0:Int) - (1:Nat) == (-1:Int)` traps erronously. --- src/desugar.ml | 6 ++++-- test/run/sub-negative.as | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) create mode 100644 test/run/sub-negative.as diff --git a/src/desugar.ml b/src/desugar.ml index 4dc0848a8ae..7e3be0c8d96 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -32,10 +32,12 @@ let | S.VarE i -> I.VarE i | S.LitE l -> I.LitE !l | S.UnE (o, e) -> - let p = prim_of_type (e.Source.note.S.note_typ) in + (* Important: Use the type of the result (due to Nat <: Int subtyping *) + let p = prim_of_type (note.S.note_typ) in I.UnE (p , o, exp e) | S.BinE (e1, o, e2) -> - let p = prim_of_type (e1.Source.note.S.note_typ) in + (* Important: Use the type of the result (due to Nat <: Int subtyping *) + let p = prim_of_type (note.S.note_typ) in I.BinE (p, exp e1, o, exp e2) | S.RelE (e1, o, e2) -> let p = prim_of_type (e1.Source.note.S.note_typ) in diff --git a/test/run/sub-negative.as b/test/run/sub-negative.as new file mode 100644 index 00000000000..c3a4899efde --- /dev/null +++ b/test/run/sub-negative.as @@ -0,0 +1 @@ +assert (- (1:Nat) == (-1:Int)); From a5b2d139d290b32b665a0679f17ce60d1032115c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 12:11:21 +0100 Subject: [PATCH 29/41] Introduce a stack representation for (unboxed) references to avoid a bit of boxing/unboxing. This also resolves the overloading of `.` (objects vs. actors) in the desguarer. This code is currently incomplete for type constructors, as we don't have a consenv around there. --- src/arrange_ir.ml | 1 + src/compile.ml | 77 ++++++++++--------- src/desugar.ml | 8 +- src/freevars_ir.ml | 1 + src/ir.ml | 1 + .../ok/counter-class.wasm.stderr.ok | 64 +-------------- test/run/sub-negative.as | 2 + 7 files changed, 55 insertions(+), 99 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index a9b5d35e4c0..8bff0baae7b 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -14,6 +14,7 @@ let rec exp e = match e.it with | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | ActorE (i, efs) -> "ActorE" $$ [id i] @ List.map exp_field efs | DotE (e, n) -> "DotE" $$ [exp e; name n] + | ActorDotE (e, n) -> "ActorDotE" $$ [exp e; name n] | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] | ArrayE (m, es) -> "ArrayE" $$ [Arrange.mut m] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] diff --git a/src/compile.ml b/src/compile.ml index 154ac888c0d..1d833cb6a6f 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1719,14 +1719,23 @@ module Dfinity = struct edesc = nr (FuncExport (nr fi)) }) - let get_self_reference env = - Func.share_code env "get_self_reference" [] [I32Type] (fun env -> + let box_reference env = + Func.share_code env "box_reference" ["ref", I32Type] [I32Type] (fun env -> + let get_ref = G.i (GetLocal (nr 0l)) in Tagged.obj env Tagged.Reference [ - G.i (Call (nr (actor_self_i env))) ^^ + get_ref ^^ ElemHeap.remember_reference env ] ) + let unbox_reference env = + Heap.load_field 1l ^^ + ElemHeap.recall_reference env + + let get_self_reference env = + G.i (Call (nr (actor_self_i env))) ^^ + box_reference env + end (* Dfinity *) module OrthogonalPersistence = struct @@ -2188,8 +2197,7 @@ module Serialization = struct get_i ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_x ^^ - Heap.load_field 1l ^^ - ElemHeap.recall_reference env ^^ + Dfinity.unbox_reference env ^^ store_ptr ^^ get_x ^^ @@ -2551,9 +2559,7 @@ module FuncDec = struct let call_funcref env cc get_ref = if E.mode env <> DfinityMode then G.i Unreachable else compile_unboxed_const tmp_table_slot ^^ (* slot number *) - get_ref ^^ (* the boxed funcref table id *) - Heap.load_field 1l ^^ - ElemHeap.recall_reference env ^^ + get_ref ^^ (* the unboxed funcref *) G.i (Call (nr (Dfinity.func_internalize_i env))) ^^ compile_unboxed_const tmp_table_slot ^^ @@ -2793,7 +2799,12 @@ module StackRep = struct there are various ways of putting a value onto the stack -- unboxed, tupled etc. *) - type t = Vanilla | UnboxedTuple of int | UnboxedInt | Unreachable + type t = + | Vanilla + | UnboxedTuple of int + | UnboxedInt + | UnboxedReference + | Unreachable let unit = UnboxedTuple 0 @@ -2823,6 +2834,7 @@ module StackRep = struct let to_block_type env = function | Vanilla -> ValBlockType (Some I32Type) | UnboxedInt -> ValBlockType (Some I64Type) + | UnboxedReference -> ValBlockType (Some I32Type) | UnboxedTuple 0 -> ValBlockType None | UnboxedTuple 1 -> ValBlockType (Some I32Type) | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) @@ -2831,6 +2843,7 @@ module StackRep = struct let to_string = function | Vanilla -> "Vanilla" | UnboxedInt -> "UnboxedInt" + | UnboxedReference -> "UnboxedReference" | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n | Unreachable -> "Unreachable" @@ -2838,6 +2851,7 @@ module StackRep = struct | Unreachable, sr2 -> sr2 | sr1, Unreachable -> sr1 | UnboxedInt, UnboxedInt -> UnboxedInt + | UnboxedReference, UnboxedReference -> UnboxedReference | UnboxedTuple n, UnboxedTuple m when n = m -> sr1 | _, Vanilla -> Vanilla | Vanilla, _ -> Vanilla @@ -2849,6 +2863,7 @@ module StackRep = struct match sr_in with | Vanilla -> G.i Drop | UnboxedInt -> G.i Drop + | UnboxedReference -> G.i Drop | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) | Unreachable -> G.nop @@ -2861,8 +2876,13 @@ module StackRep = struct | UnboxedTuple n, Vanilla -> Array.from_stack env n | Vanilla, UnboxedTuple n -> Array.to_stack env n + | UnboxedInt, Vanilla -> BoxedInt.box env | Vanilla, UnboxedInt -> BoxedInt.unbox env + + | UnboxedReference, Vanilla -> Dfinity.box_reference env + | Vanilla, UnboxedReference -> Dfinity.unbox_reference env + | _, _ -> Printf.eprintf "Unknown stack_rep conversion %s -> %s\n" (to_string sr_in) (to_string sr_out); @@ -3058,16 +3078,14 @@ and compile_exp (env : E.t) exp = get_o ^^ Tagged.branch env (ValBlockType (Some I32Type)) ( [ Tagged.Object, get_o ^^ Object.load_idx env name ] @ - (if E.mode env = DfinityMode - then [ Tagged.Reference, - get_o ^^ - actor_fake_object_idx env {name with it = n} exp.at - ] - else []) @ match Array.fake_object_idx env n with | None -> [] | Some code -> [ Tagged.Array, get_o ^^ code ] ) + | ActorDotE (e, ({it = Syntax.Name n;_} as name)) -> + StackRep.UnboxedReference, + compile_exp_as env StackRep.UnboxedReference e ^^ + actor_fake_object_idx env {name with it = n} (* We only allow prims of certain shapes, as they occur in the prelude *) (* Binary prims *) | CallE (_, ({ it = PrimE p; _} as pe), _, { it = TupE [e1;e2]; _}) -> @@ -3239,7 +3257,7 @@ and compile_exp (env : E.t) exp = | ArrayE (m, es) -> StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) | ActorE (name, fs) -> - StackRep.Vanilla, + StackRep.UnboxedReference, let captured = Freevars_ir.exp exp in let prelude_names = find_prelude_names env in if Freevars_ir.M.is_empty (Freevars_ir.diff captured prelude_names) @@ -3262,7 +3280,7 @@ and compile_exp (env : E.t) exp = Closure.call_closure env cc | None, Type.Call Type.Sharable -> let (set_funcref, get_funcref) = new_local env "funcref" in - compile_exp_vanilla env e1 ^^ + compile_exp_as env StackRep.UnboxedReference e1 ^^ set_funcref ^^ compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ Serialization.serialize_n env cc.Value.n_args ^^ @@ -3698,31 +3716,14 @@ and actor_lit outer_env name fs at = let (_map, wasm_binary) = Wasm_copy.CustomModule.encode m in wasm_binary in - let code = G.with_region at @@ Dfinity.compile_databuf_of_bytes outer_env wasm_binary ^^ - (* Create actorref *) G.i (Call (nr (Dfinity.module_new_i outer_env))) ^^ - G.i (Call (nr (Dfinity.actor_new_i outer_env))) ^^ - ElemHeap.remember_reference outer_env in - - (* Wrap it in a tagged heap object *) - Tagged.obj outer_env Tagged.Reference [ code ] - -and actor_fake_object_idx env name at = G.with_region at @@ - let (set_i, get_i) = new_local env "ref" in - (* The wrapped actor table entry is on the stack *) - Heap.load_field 1l ^^ - ElemHeap.recall_reference env ^^ - set_i ^^ + G.i (Call (nr (Dfinity.actor_new_i outer_env))) - (* Export the methods and put it in a Reference object *) - Tagged.obj env Tagged.Reference - [ get_i ^^ - Dfinity.compile_databuf_of_bytes env (name.it) ^^ - G.i (Call (nr (Dfinity.actor_export_i env))) ^^ - ElemHeap.remember_reference env - ] +and actor_fake_object_idx env name = + Dfinity.compile_databuf_of_bytes env (name.it) ^^ + G.i (Call (nr (Dfinity.actor_export_i env))) and conclude_module env module_name start_fi_o = diff --git a/src/desugar.ml b/src/desugar.ml index 7e3be0c8d96..bdfc98c121b 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -46,7 +46,13 @@ let | S.ProjE (e, i) -> I.ProjE (exp e, i) | S.OptE e -> I.OptE (exp e) | S.ObjE (s, i, es) -> obj at s None i es - | S.DotE (e, n) -> I.DotE (exp e, n) + | S.DotE (e, n) -> + begin match e.Source.note.S.note_typ with + | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp e, n) + | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp e, n) + | Type.Con _ -> raise (Invalid_argument ("TODO: Con in dot operator")) + | _ -> raise (Invalid_argument ("non-object in dot operator")) + end | S.AssignE (e1, e2) -> I.AssignE (exp e1, exp e2) | S.ArrayE (m, es) -> I.ArrayE (m, exps es) | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index acd6dc2cfef..b44e43c1ee1 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -69,6 +69,7 @@ let rec exp e : f = match e.it with | ProjE (e, i) -> exp e | ActorE (i, efs) -> close (exp_fields efs) // i.it | DotE (e, i) -> exp e + | ActorDotE (e, i) -> exp e | AssignE (e1, e2) -> exps [e1; e2] | ArrayE (m, es) -> exps es | IdxE (e1, e2) -> exps [e1; e2] diff --git a/src/ir.ml b/src/ir.ml index 154b7b5bf3b..ad4b5582425 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -24,6 +24,7 @@ and exp' = | OptE of exp (* option injection *) | ActorE of Syntax.id * exp_field list (* actor *) | DotE of exp * Syntax.name (* object projection *) + | ActorDotE of exp * Syntax.name (* actor field access *) | AssignE of exp * exp (* assignment *) | ArrayE of Syntax.mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 4a8a2f469a6..b722cde3b6c 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -1,60 +1,4 @@ -non-closed actor: (ActorE - anon-object-1.30 - (c c (VarE i) Var Private) - (dec - dec - (BlockE - (FuncD - (shared 0 -> 0) - dec - (TupP) - (TupT) - (BlockE - (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) - (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) - ) - ) - ) - Const - Public - ) - (read - read - (BlockE - (FuncD - (shared 1 -> 0) - read - (VarP $1) - (TupT) - (BlockE - (LetD (TupP) (TupE)) - (ExpD - (CallE - ( 1 -> 0) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $0) - (PrimT Any) - (CallE ( 1 -> 0) (VarE $0) (BlockE (ExpD (VarE c)))) - ) - ) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $2) - (PrimT Any) - (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) - ) - ) - ) - ) - ) - ) - ) - Const - Public - ) -) +(unknown location): internal error, Invalid_argument("TODO: Con in dot operator") + +Last environment: + diff --git a/test/run/sub-negative.as b/test/run/sub-negative.as index c3a4899efde..12b91a7cc80 100644 --- a/test/run/sub-negative.as +++ b/test/run/sub-negative.as @@ -1 +1,3 @@ assert (- (1:Nat) == (-1:Int)); +assert ((0:Int) - (1:Nat) == (-1:Int)); +assert ((0:Nat) - (1:Int) == (-1:Int)); From c4d27a5b542e7fd12652297c32171d0f2d4ca490 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 12:42:55 +0100 Subject: [PATCH 30/41] Pass `con_env` to desguar to properly recognize objects that are instances of classes --- src/compile.ml | 1 + src/desugar.ml | 148 +++++++++--------- src/desugar.mli | 2 +- src/pipeline.ml | 7 +- .../ok/counter-class.wasm.stderr.ok | 64 +++++++- 5 files changed, 140 insertions(+), 82 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 1d833cb6a6f..fa79d0d461a 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3084,6 +3084,7 @@ and compile_exp (env : E.t) exp = ) | ActorDotE (e, ({it = Syntax.Name n;_} as name)) -> StackRep.UnboxedReference, + if E.mode env <> DfinityMode then G.i Unreachable else compile_exp_as env StackRep.UnboxedReference e ^^ actor_fake_object_idx env {name with it = n} (* We only allow prims of certain shapes, as they occur in the prelude *) diff --git a/src/desugar.ml b/src/desugar.ml index bdfc98c121b..d157ee9a4a0 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -21,86 +21,86 @@ let prim_of_type = function | Type.Non -> Type.Nat (* dead code anyways *) | t -> raise (Invalid_argument ("non-primitive operator type: " ^ Type.string_of_typ t)) -let phrase f x = f x.it @@ x.at -let phrase' f x = f x.at x.note x.it @@ x.at +let phrase ce f x = f ce x.it @@ x.at +let phrase' ce f x = f ce x.at x.note x.it @@ x.at let - rec exps es = List.map exp es - and exp e = phrase' exp' e - and exp' at note = function + rec exps ce es = List.map (exp ce) es + and exp ce e = phrase' ce exp' e + and exp' ce at note = function | S.PrimE p -> I.PrimE p | S.VarE i -> I.VarE i | S.LitE l -> I.LitE !l | S.UnE (o, e) -> (* Important: Use the type of the result (due to Nat <: Int subtyping *) let p = prim_of_type (note.S.note_typ) in - I.UnE (p , o, exp e) + I.UnE (p , o, exp ce e) | S.BinE (e1, o, e2) -> (* Important: Use the type of the result (due to Nat <: Int subtyping *) let p = prim_of_type (note.S.note_typ) in - I.BinE (p, exp e1, o, exp e2) + I.BinE (p, exp ce e1, o, exp ce e2) | S.RelE (e1, o, e2) -> let p = prim_of_type (e1.Source.note.S.note_typ) in - I.RelE (p, exp e1, o, exp e2) - | S.TupE es -> I.TupE (exps es) - | S.ProjE (e, i) -> I.ProjE (exp e, i) - | S.OptE e -> I.OptE (exp e) - | S.ObjE (s, i, es) -> obj at s None i es + I.RelE (p, exp ce e1, o, exp ce e2) + | S.TupE es -> I.TupE (exps ce es) + | S.ProjE (e, i) -> I.ProjE (exp ce e, i) + | S.OptE e -> I.OptE (exp ce e) + | S.ObjE (s, i, es) -> obj ce at s None i es | S.DotE (e, n) -> - begin match e.Source.note.S.note_typ with - | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp e, n) - | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp e, n) - | Type.Con _ -> raise (Invalid_argument ("TODO: Con in dot operator")) + begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with + | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) + | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp ce e, n) + | Type.Con _ -> raise (Invalid_argument ("Con in promoted type")) | _ -> raise (Invalid_argument ("non-object in dot operator")) end - | S.AssignE (e1, e2) -> I.AssignE (exp e1, exp e2) - | S.ArrayE (m, es) -> I.ArrayE (m, exps es) - | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) + | S.AssignE (e1, e2) -> I.AssignE (exp ce e1, exp ce e2) + | S.ArrayE (m, es) -> I.ArrayE (m, exps ce es) + | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in let inst = List.map (fun t -> t.Source.it ) inst in - I.CallE (cc, exp e1, inst, exp e2) - | S.BlockE ds -> I.BlockE (decs ds) - | S.NotE e -> I.IfE (exp e, false_lit, true_lit) - | S.AndE (e1, e2) -> I.IfE (exp e1, exp e2, false_lit) - | S.OrE (e1, e2) -> I.IfE (exp e1, true_lit, exp e2) - | S.IfE (e1, e2, e3) -> I.IfE (exp e1, exp e2, exp e3) - | S.SwitchE (e1, cs) -> I.SwitchE (exp e1, cases cs) - | S.WhileE (e1, e2) -> I.WhileE (exp e1, exp e2) - | S.LoopE (e1, None) -> I.LoopE (exp e1, None) - | S.LoopE (e1, Some e2) -> I.LoopE (exp e1, Some (exp e2)) - | S.ForE (p, e1, e2) -> I.ForE (pat p, exp e1, exp e2) - | S.LabelE (l, t, e) -> I.LabelE (l, t, exp e) - | S.BreakE (l, e) -> I.BreakE (l, exp e) - | S.RetE e -> I.RetE (exp e) - | S.AsyncE e -> I.AsyncE (exp e) - | S.AwaitE e -> I.AwaitE (exp e) - | S.AssertE e -> I.AssertE (exp e) - | S.IsE (e1, e2) -> I.IsE (exp e1, exp e2) - | S.AnnotE (e, _) -> exp' at note e.it - | S.DecE d -> I.BlockE [dec d] - | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp e) - | S.DefineE (i, m, e) -> I.DefineE (i, m, exp e) + I.CallE (cc, exp ce e1, inst, exp ce e2) + | S.BlockE ds -> I.BlockE (decs ce ds) + | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) + | S.AndE (e1, e2) -> I.IfE (exp ce e1, exp ce e2, false_lit) + | S.OrE (e1, e2) -> I.IfE (exp ce e1, true_lit, exp ce e2) + | S.IfE (e1, e2, e3) -> I.IfE (exp ce e1, exp ce e2, exp ce e3) + | S.SwitchE (e1, cs) -> I.SwitchE (exp ce e1, cases ce cs) + | S.WhileE (e1, e2) -> I.WhileE (exp ce e1, exp ce e2) + | S.LoopE (e1, None) -> I.LoopE (exp ce e1, None) + | S.LoopE (e1, Some e2) -> I.LoopE (exp ce e1, Some (exp ce e2)) + | S.ForE (p, e1, e2) -> I.ForE (pat ce p, exp ce e1, exp ce e2) + | S.LabelE (l, t, e) -> I.LabelE (l, t, exp ce e) + | S.BreakE (l, e) -> I.BreakE (l, exp ce e) + | S.RetE e -> I.RetE (exp ce e) + | S.AsyncE e -> I.AsyncE (exp ce e) + | S.AwaitE e -> I.AwaitE (exp ce e) + | S.AssertE e -> I.AssertE (exp ce e) + | S.IsE (e1, e2) -> I.IsE (exp ce e1, exp ce e2) + | S.AnnotE (e, _) -> exp' ce at note e.it + | S.DecE d -> I.BlockE [dec ce d] + | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp ce e) + | S.DefineE (i, m, e) -> I.DefineE (i, m, exp ce e) | S.NewObjE (s, fs) -> I.NewObjE (s, fs) - and field_to_dec (f : S.exp_field) : Ir.dec = + and field_to_dec ce (f : S.exp_field) : Ir.dec = match f.it.S.mut.it with - | S.Const -> I.LetD (I.VarP f.it.S.id @@ no_region, exp f.it.S.exp) @@ f.at - | S.Var -> I.VarD (f.it.S.id, exp f.it.S.exp) @@ f.at + | S.Const -> I.LetD (I.VarP f.it.S.id @@ no_region, exp ce f.it.S.exp) @@ f.at + | S.Var -> I.VarD (f.it.S.id, exp ce f.it.S.exp) @@ f.at and field_to_obj_entry (f : S.exp_field) = match f.it.S.priv.it with | S.Private -> [] | S.Public -> [ (f.it.S.name, f.it.S.id) ] - and obj at s class_id self_id es = + and obj ce at s class_id self_id es = match s.it with - | Type.Object _ -> build_obj at None self_id es - | Type.Actor -> I.ActorE (self_id, exp_fields es) + | Type.Object _ -> build_obj ce at None self_id es + | Type.Actor -> I.ActorE (self_id, exp_fields ce es) - and build_obj at class_id self_id es = + and build_obj ce at class_id self_id es = I.BlockE ( - List.map field_to_dec es @ + List.map (field_to_dec ce) es @ [ I.LetD ( I.VarP self_id @@ at, I.NewObjE @@ -109,41 +109,41 @@ let ) @@ at; I.ExpD (I.VarE self_id @@ at) @@ at]) - and exp_fields fs = List.map exp_field fs - and exp_field f = phrase exp_field' f - and exp_field' (f : S.exp_field') = - S.{ I.name = f.name; I.id = f.id; I.exp = exp f.exp; I.mut = f.mut; I.priv = f.priv} - - and decs ds = List.map dec ds - and dec d = phrase' dec' d - and dec' at n = function - | S.ExpD e -> I.ExpD (exp e) - | S.LetD (p, e) -> I.LetD (pat p, exp e) - | S.VarD (i, e) -> I.VarD (i, exp e) + and exp_fields ce fs = List.map (exp_field ce) fs + and exp_field ce f = phrase ce exp_field' f + and exp_field' cd (f : S.exp_field') = + S.{ I.name = f.name; I.id = f.id; I.exp = exp cd f.exp; I.mut = f.mut; I.priv = f.priv} + + and decs ce ds = List.map (dec ce) ds + and dec ce d = phrase' ce dec' d + and dec' ce at n = function + | S.ExpD e -> I.ExpD (exp ce e) + | S.LetD (p, e) -> I.LetD (pat ce p, exp ce e) + | S.VarD (i, e) -> I.VarD (i, exp ce e) | S.FuncD (s, i, tp, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, tp, pat p, ty, exp e) + I.FuncD (cc, i, tp, pat ce p, ty, exp ce e) | S.TypD (i, ty, t) -> I.TypD (i, ty, t) | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, fun_id, tp, pat p, S.PrimT "dummy" @@ at, - obj at s (Some fun_id) self_id es @@ at) + I.FuncD (cc, fun_id, tp, pat ce p, S.PrimT "dummy" @@ at, + obj ce at s (Some fun_id) self_id es @@ at) - and cases cs = List.map case cs - and case c = phrase case' c - and case' c = S.{ I.pat = pat c.pat; I.exp = exp c.exp} + and cases ce cs = List.map (case ce) cs + and case ce c = phrase ce case' c + and case' ce c = S.{ I.pat = pat ce c.pat; I.exp = exp ce c.exp} - and pats ps = List.map pat ps - and pat p = phrase pat' p - and pat' = function + and pats ce ps = List.map (pat ce) ps + and pat ce p = phrase ce pat' p + and pat' ce = function | S.VarP v -> I.VarP v | S.WildP -> I.WildP | S.LitP l -> I.LitP !l | S.SignP (o, l) -> I.LitP (apply_sign o !l) - | S.TupP ps -> I.TupP (pats ps) - | S.OptP p -> I.OptP (pat p) - | S.AltP (p1, p2) -> I.AltP (pat p1, pat p2) - | S.AnnotP (p, _) -> pat' p.it + | S.TupP ps -> I.TupP (pats ce ps) + | S.OptP p -> I.OptP (pat ce p) + | S.AltP (p1, p2) -> I.AltP (pat ce p1, pat ce p2) + | S.AnnotP (p, _) -> pat' ce p.it - and prog p = phrase decs p + and prog ce p = phrase ce decs p diff --git a/src/desugar.mli b/src/desugar.mli index a2ec063ac2d..e5b8ac30616 100644 --- a/src/desugar.mli +++ b/src/desugar.mli @@ -1 +1 @@ -val prog : Syntax.prog -> Ir.prog +val prog : Typing.con_env -> Syntax.prog -> Ir.prog diff --git a/src/pipeline.ml b/src/pipeline.ml index 4ca61983f0b..92a4627bab3 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -284,13 +284,14 @@ type compile_result = (Wasm_copy.CustomModule.extended_module, Diag.messages) re let compile_with check mode name : compile_result = match check initial_stat_env name with | Error msgs -> Error msgs - | Ok ((prog, _t, _scope), msgs) -> + | Ok ((prog, _t, scope), msgs) -> Diag.print_messages msgs; + let prelude = Desugar.prog initial_stat_env.Typing.con_env prelude in let prog = await_lowering true prog name in let prog = async_lowering true prog name in let prog = tailcall_optimization true prog name in - let prog = Desugar.prog prog in - let prelude = Desugar.prog prelude in + let scope' = Typing.adjoin_scope initial_stat_env scope in + let prog = Desugar.prog scope'.Typing.con_env prog in phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index b722cde3b6c..4a8a2f469a6 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -1,4 +1,60 @@ -(unknown location): internal error, Invalid_argument("TODO: Con in dot operator") - -Last environment: - +non-closed actor: (ActorE + anon-object-1.30 + (c c (VarE i) Var Private) + (dec + dec + (BlockE + (FuncD + (shared 0 -> 0) + dec + (TupP) + (TupT) + (BlockE + (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) + (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) + ) + ) + ) + Const + Public + ) + (read + read + (BlockE + (FuncD + (shared 1 -> 0) + read + (VarP $1) + (TupT) + (BlockE + (LetD (TupP) (TupE)) + (ExpD + (CallE + ( 1 -> 0) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $0) + (PrimT Any) + (CallE ( 1 -> 0) (VarE $0) (BlockE (ExpD (VarE c)))) + ) + ) + (BlockE + (FuncD + ( 1 -> 0) + $lambda + (VarP $2) + (PrimT Any) + (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) + ) + ) + ) + ) + ) + ) + ) + Const + Public + ) +) From 0bdd494f0a203e0ce7beb26f2350927df352c693 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 13:00:56 +0100 Subject: [PATCH 31/41] Only do dynamic dispatch on `DotE` if the field could be that of an array --- src/compile.ml | 20 +++++++++++--------- test/run/ok/account.wasm.stderr.ok | 2 +- test/run/ok/bank-example.wasm.stderr.ok | 2 +- 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index fa79d0d461a..261f204fee6 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3073,15 +3073,17 @@ and compile_exp (env : E.t) exp = | DotE (e, ({it = Syntax.Name n;_} as name)) -> StackRep.Vanilla, compile_exp_vanilla env e ^^ - let (set_o, get_o) = new_local env "o" in - set_o ^^ - get_o ^^ - Tagged.branch env (ValBlockType (Some I32Type)) ( - [ Tagged.Object, get_o ^^ Object.load_idx env name ] @ - match Array.fake_object_idx env n with - | None -> [] - | Some code -> [ Tagged.Array, get_o ^^ code ] - ) + begin match Array.fake_object_idx env n with + | None -> Object.load_idx env name + | Some array_code -> + let (set_o, get_o) = new_local env "o" in + set_o ^^ + get_o ^^ + Tagged.branch env (ValBlockType (Some I32Type)) ( + [ Tagged.Object, get_o ^^ Object.load_idx env name + ; Tagged.Array, get_o ^^ array_code ] + ) + end | ActorDotE (e, ({it = Syntax.Name n;_} as name)) -> StackRep.UnboxedReference, if E.mode env <> DfinityMode then G.i Unreachable else diff --git a/test/run/ok/account.wasm.stderr.ok b/test/run/ok/account.wasm.stderr.ok index 9f8f70f418a..f1b111c40ed 100644 --- a/test/run/ok/account.wasm.stderr.ok +++ b/test/run/ok/account.wasm.stderr.ok @@ -119,7 +119,7 @@ non-closed actor: (ActorE (ExpD (CallE (shared 2 -> 0) - (DotE (VarE account) credit) + (ActorDotE (VarE account) credit) (TupE (VarE amount) (VarE Account)) ) ) diff --git a/test/run/ok/bank-example.wasm.stderr.ok b/test/run/ok/bank-example.wasm.stderr.ok index f457c77ea70..45a674ee096 100644 --- a/test/run/ok/bank-example.wasm.stderr.ok +++ b/test/run/ok/bank-example.wasm.stderr.ok @@ -219,7 +219,7 @@ non-closed actor: (ActorE (ExpD (CallE (shared 2 -> 0) - (DotE (VarE account) credit) + (ActorDotE (VarE account) credit) (TupE (VarE amount) (VarE Account)) ) ) From 025d3bc6414df84c61bfd2ef5cf34b420b65087b Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 2 Jan 2019 14:44:19 +0100 Subject: [PATCH 32/41] Update dev (no particular reason) --- Jenkinsfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Jenkinsfile b/Jenkinsfile index 6fd2715ece7..9c50a951aa0 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -5,7 +5,7 @@ pipeline { steps { sh 'git submodule update --init --recursive' sh 'git clone --recursive git@github.com:dfinity-lab/dev nix/dev' - sh 'git -C nix/dev checkout f2bbb3d91ef87a037044ed3822a222a0654cd835' + sh 'git -C nix/dev checkout 5bc3b33f92e20432588ee0bec513edef649f237d' sh 'git -C nix/dev submodule update --init --recursive' } } From d3af081e223f3b55a8d2d8f9f0f87f1d546de40b Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 3 Jan 2019 19:18:33 +0100 Subject: [PATCH 33/41] Add test case for #122 --- test/run/issue122.as | 1 + test/run/ok/issue122.run-low.ok | 1 + test/run/ok/issue122.run.ok | 1 + test/run/ok/issue122.wasm.stderr.ok | 4 ++++ 4 files changed, 7 insertions(+) create mode 100644 test/run/issue122.as create mode 100644 test/run/ok/issue122.run-low.ok create mode 100644 test/run/ok/issue122.run.ok create mode 100644 test/run/ok/issue122.wasm.stderr.ok diff --git a/test/run/issue122.as b/test/run/issue122.as new file mode 100644 index 00000000000..0eb6e89d51d --- /dev/null +++ b/test/run/issue122.as @@ -0,0 +1 @@ +ignore((42:Nat)-(23:Nat)); diff --git a/test/run/ok/issue122.run-low.ok b/test/run/ok/issue122.run-low.ok new file mode 100644 index 00000000000..2d56f4094b0 --- /dev/null +++ b/test/run/ok/issue122.run-low.ok @@ -0,0 +1 @@ +issue122.as:1.8-1.25: execution error, arithmetic overflow diff --git a/test/run/ok/issue122.run.ok b/test/run/ok/issue122.run.ok new file mode 100644 index 00000000000..2d56f4094b0 --- /dev/null +++ b/test/run/ok/issue122.run.ok @@ -0,0 +1 @@ +issue122.as:1.8-1.25: execution error, arithmetic overflow diff --git a/test/run/ok/issue122.wasm.stderr.ok b/test/run/ok/issue122.wasm.stderr.ok new file mode 100644 index 00000000000..2671c9253c2 --- /dev/null +++ b/test/run/ok/issue122.wasm.stderr.ok @@ -0,0 +1,4 @@ +(unknown location): internal error, Invalid_argument("non-primitive operator type: Any") + +Last environment: + From 41830d056846a23ec3051c7ca29f83c635df7fec Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 3 Jan 2019 19:50:52 +0100 Subject: [PATCH 34/41] Record type of overloaded operators the type infernce code knows the precise type that it has determined is compatible with a given operation (`t` in `typing`). But previously, this was not stored anywhere, and interpreter and compiler had to make educated guesses based on the type annotation of the arguments and/or the return values. This is brittle, due to subtyping, and led to bugs. Therefore, we not simply store the type within the constructor. This fixes #122. --- src/arrange.ml | 10 +- src/arrange_ir.ml | 8 +- src/async.ml | 18 ++- src/awaitopt.ml | 24 ++-- src/compile.ml | 62 +++++----- src/desugar.ml | 23 +--- src/effect.ml | 6 +- src/freevars.ml | 6 +- src/interpret.ml | 16 +-- src/ir.ml | 6 +- src/parser.mly | 12 +- src/rename.ml | 6 +- src/syntax.ml | 13 +- src/tailcall.ml | 6 +- src/typing.ml | 24 ++-- test/run/ok/bit-ops.wasm.stderr.ok | 112 ++++++++--------- test/run/ok/issue122.run-low.ok | 1 - test/run/ok/issue122.run.ok | 1 - test/run/ok/issue122.wasm.stderr.ok | 4 - test/run/ok/numeric-ops.wasm.stderr.ok | 116 ++++++++--------- test/run/ok/relational-ops.wasm.stderr.ok | 144 +++++++++++----------- 21 files changed, 308 insertions(+), 310 deletions(-) delete mode 100644 test/run/ok/issue122.run-low.ok delete mode 100644 test/run/ok/issue122.run.ok delete mode 100644 test/run/ok/issue122.wasm.stderr.ok diff --git a/src/arrange.ml b/src/arrange.ml index 8a6eb646775..bdcf92c657e 100644 --- a/src/arrange.ml +++ b/src/arrange.ml @@ -7,9 +7,9 @@ let ($$) head inner = Node (head, inner) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] | LitE l -> "LitE" $$ [lit !l] - | UnE (uo, e) -> "UnE" $$ [unop uo; exp e] - | BinE (e1, bo, e2) -> "BinE" $$ [exp e1; binop bo; exp e2] - | RelE (e1, ro, e2) -> "RelE" $$ [exp e1; relop ro; exp e2] + | UnE (ot, uo, e) -> "UnE" $$ [operator_type !ot; unop uo; exp e] + | BinE (ot, e1, bo, e2) -> "BinE" $$ [operator_type !ot; exp e1; binop bo; exp e2] + | RelE (ot, e1, ro, e2) -> "RelE" $$ [operator_type !ot; exp e1; relop ro; exp e2] | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | ObjE (s, i, efs) -> "ObjE" $$ [obj_sort s; id i] @ List.map exp_field efs @@ -136,7 +136,9 @@ and exp_field (ef : exp_field) = (string_of_name ef.it.name.it) $$ [id ef.it.id; exp ef.it.exp; mut ef.it.mut; priv ef.it.priv] and inst t = typ t.it - + +and operator_type t = Atom (Type.string_of_typ t) + and typ t = match t.it with | VarT (s, ts) -> "VarT" $$ [id s] @ List.map typ ts | PrimT p -> "PrimT" $$ [Atom p] diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 8bff0baae7b..c461f77c8fd 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -7,9 +7,9 @@ let ($$) head inner = Node (head, inner) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] | LitE l -> "LitE" $$ [Arrange.lit l] - | UnE (t, uo, e) -> "UnE" $$ [Arrange.prim t; Arrange.unop uo; exp e] - | BinE (t, e1, bo, e2)-> "BinE" $$ [Arrange.prim t; exp e1; Arrange.binop bo; exp e2] - | RelE (t, e1, ro, e2)-> "RelE" $$ [Arrange.prim t; exp e1; Arrange.relop ro; exp e2] + | UnE (t, uo, e) -> "UnE" $$ [typ t; Arrange.unop uo; exp e] + | BinE (t, e1, bo, e2)-> "BinE" $$ [typ t; exp e1; Arrange.binop bo; exp e2] + | RelE (t, e1, ro, e2)-> "RelE" $$ [typ t; exp e1; Arrange.relop ro; exp e2] | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | ActorE (i, efs) -> "ActorE" $$ [id i] @ List.map exp_field efs @@ -51,7 +51,7 @@ and pat p = match p.it with and case c = "case" $$ [pat c.it.pat; exp c.it.exp] -and prim p = Atom (Type.string_of_prim p) +and typ t = Atom (Type.string_of_typ t) and exp_field (ef : exp_field) = (Syntax.string_of_name ef.it.name.it) $$ [id ef.it.id; exp ef.it.exp; Arrange.mut ef.it.mut; Arrange.priv ef.it.priv] diff --git a/src/async.ml b/src/async.ml index 190dfead5fb..44598d27c35 100644 --- a/src/async.ml +++ b/src/async.ml @@ -200,6 +200,12 @@ let rec t_typ (t:T.typ) = and t_bind {var; bound} = {var; bound = t_typ bound} +and t_operator_type ot = + (* We recreate the reference here. That is ok, because it + we run after type inference. Once we move async past desugaring, + it will be a pure value anyways. *) + ref (t_typ !ot) + and t_field {name; typ} = {name; typ = t_typ typ} let rec t_exp (exp:Syntax.exp) = @@ -214,12 +220,12 @@ and t_exp' (exp:Syntax.exp) = | PrimE _ | LitE _ -> exp' | VarE id -> exp' - | UnE (op, exp1) -> - UnE (op, t_exp exp1) - | BinE (exp1, op, exp2) -> - BinE (t_exp exp1, op, t_exp exp2) - | RelE (exp1, op, exp2) -> - RelE (t_exp exp1, op, t_exp exp2) + | UnE (ot, op, exp1) -> + UnE (t_operator_type ot, op, t_exp exp1) + | BinE (ot, exp1, op, exp2) -> + BinE (t_operator_type ot, t_exp exp1, op, t_exp exp2) + | RelE (ot, exp1, op, exp2) -> + RelE (t_operator_type ot, t_exp exp1, op, t_exp exp2) | TupE exps -> TupE (List.map t_exp exps) | OptE exp1 -> diff --git a/src/awaitopt.ml b/src/awaitopt.ml index 61782b07838..6f9887bcf41 100644 --- a/src/awaitopt.ml +++ b/src/awaitopt.ml @@ -67,12 +67,12 @@ and t_exp' context exp' = | PrimE _ | VarE _ | LitE _ -> exp' - | UnE (op, exp1) -> - UnE (op, t_exp context exp1) - | BinE (exp1, op, exp2) -> - BinE (t_exp context exp1, op, t_exp context exp2) - | RelE (exp1, op, exp2) -> - RelE (t_exp context exp1, op, t_exp context exp2) + | UnE (ot, op, exp1) -> + UnE (ot, op, t_exp context exp1) + | BinE (ot, exp1, op, exp2) -> + BinE (ot, t_exp context exp1, op, t_exp context exp2) + | RelE (ot, exp1, op, exp2) -> + RelE (ot, t_exp context exp1, op, t_exp context exp2) | TupE exps -> TupE (List.map (t_exp context) exps) | OptE exp1 -> @@ -393,12 +393,12 @@ and c_exp' context exp k = | VarE _ | LitE _ -> assert false - | UnE (op, exp1) -> - unary context k (fun v1 -> e (UnE(op, v1))) exp1 - | BinE (exp1, op, exp2) -> - binary context k (fun v1 v2 -> e (BinE (v1, op, v2))) exp1 exp2 - | RelE (exp1, op, exp2) -> - binary context k (fun v1 v2 -> e (RelE (v1, op, v2))) exp1 exp2 + | UnE (ot, op, exp1) -> + unary context k (fun v1 -> e (UnE (ot, op, v1))) exp1 + | BinE (ot, exp1, op, exp2) -> + binary context k (fun v1 v2 -> e (BinE (ot, v1, op, v2))) exp1 exp2 + | RelE (ot, exp1, op, exp2) -> + binary context k (fun v1 v2 -> e (RelE (ot, v1, op, v2))) exp1 exp2 | TupE exps -> nary context k (fun vs -> e (TupE vs)) exps | OptE exp1 -> diff --git a/src/compile.ml b/src/compile.ml index 261f204fee6..976ce19bccc 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2824,12 +2824,12 @@ module StackRep = struct if n = 1 then Vanilla else UnboxedTuple n (* The stack rel of a primitive type, i.e. what the binary operators expect *) - let of_prim : Type.prim -> t = function - | Type.Bool -> bool - | Type.Nat -> UnboxedInt - | Type.Int -> UnboxedInt - | Type.Text -> Vanilla - | p -> todo "of_prim" (Arrange.prim p) Vanilla + let of_type : Type.typ -> t = function + | Type.Prim Type.Bool -> bool + | Type.Prim Type.Nat -> UnboxedInt + | Type.Prim Type.Int -> UnboxedInt + | Type.Prim Type.Text -> Vanilla + | p -> todo "of_type" (Arrange_ir.typ p) Vanilla let to_block_type env = function | Vanilla -> ValBlockType (Some I32Type) @@ -2990,10 +2990,10 @@ let compile_unop env t op = Syntax.(match op with but none of these do, so a single value is fine. *) let compile_binop env t op = - StackRep.of_prim t, + StackRep.of_type t, Syntax.(match t, op with - | Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) - | Type.Nat, SubOp -> + | Type.Prim Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Prim Type.Nat, SubOp -> Func.share_code env "nat_sub" ["n1", I64Type; "n2", I64Type] [I64Type] (fun env -> let get_n1 = G.i (GetLocal (nr 0l)) in let get_n2 = G.i (GetLocal (nr 1l)) in @@ -3002,39 +3002,39 @@ let compile_binop env t op = (G.i Unreachable) (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) ) - | Type.Nat, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) - | Type.Nat, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) - | Type.Nat, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) - | Type.Int, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) - | Type.Int, SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) - | Type.Int, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) - | Type.Int, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) - | Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) - | Type.Text, CatOp -> Text.concat env + | Type.Prim Type.Nat, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.Prim Type.Nat, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.Prim Type.Nat, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.Prim Type.Int, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Prim Type.Int, SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) + | Type.Prim Type.Int, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.Prim Type.Int, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.Prim Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.Prim Type.Text, CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) ) let compile_eq env t = match t with - | Type.Text -> Text.compare env - | Type.Bool -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) - | Type.Nat | Type.Int -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) + | Type.Prim Type.Text -> Text.compare env + | Type.Prim Type.Bool -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + | Type.Prim (Type.Nat | Type.Int) -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) | _ -> G.i Unreachable let compile_relop env t op = - StackRep.of_prim t, + StackRep.of_type t, Syntax.(match t, op with | _, EqOp -> compile_eq env t | _, NeqOp -> compile_eq env t ^^ G.if_ (StackRep.to_block_type env StackRep.bool) (Bool.lit false) (Bool.lit true) - | Type.Nat, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeU)) - | Type.Nat, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtU)) - | Type.Nat, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeU)) - | Type.Nat, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtU)) - | Type.Int, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeS)) - | Type.Int, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtS)) - | Type.Int, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeS)) - | Type.Int, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtS)) + | Type.Prim Type.Nat, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeU)) + | Type.Prim Type.Nat, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtU)) + | Type.Prim Type.Nat, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeU)) + | Type.Prim Type.Nat, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtU)) + | Type.Prim Type.Int, GeOp -> G.i (Compare (Wasm.Values.I64 I64Op.GeS)) + | Type.Prim Type.Int, GtOp -> G.i (Compare (Wasm.Values.I64 I64Op.GtS)) + | Type.Prim Type.Int, LeOp -> G.i (Compare (Wasm.Values.I64 I64Op.LeS)) + | Type.Prim Type.Int, LtOp -> G.i (Compare (Wasm.Values.I64 I64Op.LtS)) | _ -> G.i Unreachable ) @@ -3429,7 +3429,7 @@ and compile_lit_pat env l = | Syntax.(NatLit _ | IntLit _) -> BoxedInt.unbox env ^^ compile_lit_as env StackRep.UnboxedInt l ^^ - compile_eq env Type.Nat + compile_eq env (Type.Prim Type.Nat) | Syntax.(TextLit t) -> Text.lit env t ^^ Text.compare env diff --git a/src/desugar.ml b/src/desugar.ml index d157ee9a4a0..d8ef7f918b3 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -15,12 +15,6 @@ let apply_sign op l = Syntax.(match op, l with | _, _ -> raise (Invalid_argument "Invalid signed pattern") ) -let prim_of_type = function - | Type.Prim p -> p - | Type.Mut (Type.Prim p) -> p - | Type.Non -> Type.Nat (* dead code anyways *) - | t -> raise (Invalid_argument ("non-primitive operator type: " ^ Type.string_of_typ t)) - let phrase ce f x = f ce x.it @@ x.at let phrase' ce f x = f ce x.at x.note x.it @@ x.at @@ -31,17 +25,12 @@ let | S.PrimE p -> I.PrimE p | S.VarE i -> I.VarE i | S.LitE l -> I.LitE !l - | S.UnE (o, e) -> - (* Important: Use the type of the result (due to Nat <: Int subtyping *) - let p = prim_of_type (note.S.note_typ) in - I.UnE (p , o, exp ce e) - | S.BinE (e1, o, e2) -> - (* Important: Use the type of the result (due to Nat <: Int subtyping *) - let p = prim_of_type (note.S.note_typ) in - I.BinE (p, exp ce e1, o, exp ce e2) - | S.RelE (e1, o, e2) -> - let p = prim_of_type (e1.Source.note.S.note_typ) in - I.RelE (p, exp ce e1, o, exp ce e2) + | S.UnE (ot, o, e) -> + I.UnE (!ot, o, exp ce e) + | S.BinE (ot, e1, o, e2) -> + I.BinE (!ot, exp ce e1, o, exp ce e2) + | S.RelE (ot, e1, o, e2) -> + I.RelE (!ot, exp ce e1, o, exp ce e2) | S.TupE es -> I.TupE (exps ce es) | S.ProjE (e, i) -> I.ProjE (exp ce e, i) | S.OptE e -> I.OptE (exp ce e) diff --git a/src/effect.ml b/src/effect.ml index e3ecfa202c2..d8a8c1fcdad 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -23,7 +23,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | VarE _ | LitE _ -> T.Triv - | UnE (_, exp1) + | UnE (_, _, exp1) | ProjE (exp1, _) | OptE exp1 | DotE (exp1, _) @@ -35,10 +35,10 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | AnnotE (exp1, _) | LoopE (exp1, None) -> effect_exp exp1 - | BinE (exp1, _, exp2) + | BinE (_, exp1, _, exp2) | IdxE (exp1, exp2) | IsE (exp1, exp2) - | RelE (exp1, _, exp2) + | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) | CallE (exp1, _, exp2) | AndE (exp1, exp2) diff --git a/src/freevars.ml b/src/freevars.ml index a38f2eace76..b8a19adb741 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -36,9 +36,9 @@ let rec exp e : f = match e.it with | VarE i -> S.singleton i.it | LitE l -> S.empty | PrimE _ -> S.empty - | UnE (uo, e) -> exp e - | BinE (e1, bo, e2) -> exps [e1; e2] - | RelE (e1, ro, e2) -> exps [e1; e2] + | UnE (_, uo, e) -> exp e + | BinE (_, e1, bo, e2)-> exps [e1; e2] + | RelE (_, e1, ro, e2)-> exps [e1; e2] | TupE es -> exps es | ProjE (e, i) -> exp e | ObjE (s, i, efs) -> close (exp_fields efs) // i.it diff --git a/src/interpret.ml b/src/interpret.ml index 8797b93828d..10a1a34b7cc 100644 --- a/src/interpret.ml +++ b/src/interpret.ml @@ -266,23 +266,19 @@ and interpret_exp_mut env exp (k : V.value V.cont) = ) | LitE lit -> k (interpret_lit env lit) - | UnE (op, exp1) -> - let t = T.as_immut exp.note.note_typ in - interpret_exp env exp1 (fun v1 -> k (Operator.unop t op v1)) - | BinE (exp1, op, exp2) -> - let t = T.as_immut exp.note.note_typ in + | UnE (ot, op, exp1) -> + interpret_exp env exp1 (fun v1 -> k (Operator.unop !ot op v1)) + | BinE (ot, exp1, op, exp2) -> interpret_exp env exp1 (fun v1 -> interpret_exp env exp2 (fun v2 -> - k (try Operator.binop t op v1 v2 with _ -> + k (try Operator.binop !ot op v1 v2 with _ -> trap exp.at "arithmetic overflow") ) ) - | RelE (exp1, op, exp2) -> - let t = T.lub Con.Env.empty (* both types are primitive *) - (T.as_immut exp1.note.note_typ) (T.as_immut exp2.note.note_typ) in + | RelE (ot, exp1, op, exp2) -> interpret_exp env exp1 (fun v1 -> interpret_exp env exp2 (fun v2 -> - k (Operator.relop t op v1 v2) + k (Operator.relop !ot op v1 v2) ) ) | TupE exps -> diff --git a/src/ir.ml b/src/ir.ml index ad4b5582425..944aacda41a 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -16,9 +16,9 @@ and exp' = | PrimE of string (* primitive *) | VarE of Syntax.id (* variable *) | LitE of Syntax.lit (* literal *) - | UnE of Type.prim * Syntax.unop * exp (* unary operator *) - | BinE of Type.prim * exp * Syntax.binop * exp (* binary operator *) - | RelE of Type.prim * exp * Syntax.relop * exp (* relational operator *) + | UnE of Type.typ * Syntax.unop * exp (* unary operator *) + | BinE of Type.typ * exp * Syntax.binop * exp (* binary operator *) + | RelE of Type.typ * exp * Syntax.relop * exp (* relational operator *) | TupE of exp list (* tuple *) | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) diff --git a/src/parser.mly b/src/parser.mly index 433dcaeee0e..b38a338fdeb 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -360,23 +360,23 @@ exp_un : | e=exp_post { e } | op=unop e=exp_un - { UnE(op, e) @? at $sloc } + { UnE(ref Type.Pre, op, e) @? at $sloc } | op=unassign e=exp_un - { assign_op e (fun e' -> UnE(op, e') @? at $sloc) (at $sloc) } + { assign_op e (fun e' -> UnE(ref Type.Pre, op, e') @? at $sloc) (at $sloc) } | NOT e=exp_un { NotE e @? at $sloc } exp_bin : | e=exp_un - { e } + { e } | e1=exp_bin op=binop e2=exp_bin - { BinE(e1, op, e2) @? at $sloc } + { BinE(ref Type.Pre, e1, op, e2) @? at $sloc } | e1=exp_bin op=relop e2=exp_bin - { RelE(e1, op, e2) @? at $sloc } + { RelE(ref Type.Pre, e1, op, e2) @? at $sloc } | e1=exp_bin ASSIGN e2=exp_bin { AssignE(e1, e2) @? at $sloc} | e1=exp_bin op=binassign e2=exp_bin - { assign_op e1 (fun e1' -> BinE(e1', op, e2) @? at $sloc) (at $sloc) } + { assign_op e1 (fun e1' -> BinE(ref Type.Pre, e1', op, e2) @? at $sloc) (at $sloc) } | e1=exp_bin AND e2=exp_bin { AndE(e1, e2) @? at $sloc } | e1=exp_bin OR e2=exp_bin diff --git a/src/rename.ml b/src/rename.ml index 2c888be79b0..4127dda9182 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -28,9 +28,9 @@ and exp' rho e = match e with | VarE i -> VarE (id rho i) | LitE l -> e | PrimE _ -> e - | UnE (uo, e) -> UnE (uo, exp rho e) - | BinE (e1, bo, e2) -> BinE (exp rho e1, bo, exp rho e2) - | RelE (e1, ro, e2) -> RelE (exp rho e1, ro, exp rho e2) + | UnE (ot, uo, e) -> UnE (ot, uo, exp rho e) + | BinE (ot, e1, bo, e2)-> BinE (ot, exp rho e1, bo, exp rho e2) + | RelE (ot, e1, ro, e2)-> RelE (ot, exp rho e1, ro, exp rho e2) | TupE es -> TupE (List.map (exp rho) es) | ProjE (e, i) -> ProjE (exp rho e, i) | ObjE (s, i, efs) -> ObjE (s, i, exp_fields rho efs) diff --git a/src/syntax.ml b/src/syntax.ml index c87e59115bc..943e2ab65ac 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -123,17 +123,20 @@ and pat_field' = {id : id; pat : pat} type priv = priv' Source.phrase and priv' = Public | Private -(* type instantiations *) +(* type instantiations *) type inst = (typ, Type.typ ref) Source.annotated_phrase - + +(* Filled in for overloaded operators during type checking. Initially Type.Pre. *) +type op_type = Type.typ ref + type exp = (exp', typ_note) Source.annotated_phrase and exp' = | PrimE of string (* primitive *) | VarE of id (* variable *) | LitE of lit ref (* literal *) - | UnE of unop * exp (* unary operator *) - | BinE of exp * binop * exp (* binary operator *) - | RelE of exp * relop * exp (* relational operator *) + | UnE of op_type * unop * exp (* unary operator *) + | BinE of op_type * exp * binop * exp (* binary operator *) + | RelE of op_type * exp * relop * exp (* relational operator *) | TupE of exp list (* tuple *) | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) diff --git a/src/tailcall.ml b/src/tailcall.ml index 91caa196585..fe150feec4d 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -79,9 +79,9 @@ and exp' env e = match e.it with | VarE _ | LitE _ | PrimE _ -> e.it - | UnE (uo, e) -> UnE (uo, exp env e) - | BinE (e1, bo, e2) -> BinE (exp env e1, bo, exp env e2) - | RelE (e1, ro, e2) -> RelE (exp env e1, ro, exp env e2) + | UnE (ot, uo, e) -> UnE (ot, uo, exp env e) + | BinE (ot, e1, bo, e2)-> BinE (ot, exp env e1, bo, exp env e2) + | RelE (ot, e1, ro, e2)-> RelE (ot, exp env e1, ro, exp env e2) | TupE es -> TupE (List.map (exp env) es) | ProjE (e, i) -> ProjE (exp env e, i) | ObjE (s, i, efs) -> ObjE (s, i, exp_fields env efs) diff --git a/src/typing.ml b/src/typing.ml index 939684dc8aa..f4aae00b4e6 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -355,36 +355,42 @@ and infer_exp' env exp : T.typ = ) | LitE lit -> T.Prim (infer_lit env lit exp.at) - | UnE (op, exp1) -> + | UnE (ot, op, exp1) -> let t1 = infer_exp_promote env exp1 in (* Special case for subtyping *) let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in if not env.pre then begin + assert (!ot = Type.Pre); if not (Operator.has_unop t op) then error env exp.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons t); + ot := t; end; t - | BinE (exp1, op, exp2) -> + | BinE (ot, exp1, op, exp2) -> let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in if not env.pre then begin + assert (!ot = Type.Pre); if not (Operator.has_binop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) - (T.string_of_typ_expand env.cons t2) + (T.string_of_typ_expand env.cons t2); + ot := t end; t - | RelE (exp1, op, exp2) -> + | RelE (ot,exp1, op, exp2) -> let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in if not env.pre then begin + assert (!ot = Type.Pre); if not (Operator.has_relop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) - (T.string_of_typ_expand env.cons t2) + (T.string_of_typ_expand env.cons t2); + ot := t; end; T.bool | TupE exps -> @@ -638,9 +644,11 @@ and check_exp' env t exp = () | LitE lit, _ -> check_lit env t lit exp.at - | UnE (op, exp1), t' when Operator.has_unop t' op -> + | UnE (ot, op, exp1), t' when Operator.has_unop t' op -> + ot := t'; check_exp env t' exp1 - | BinE (exp1, op, exp2), t' when Operator.has_binop t' op -> + | BinE (ot, exp1, op, exp2), t' when Operator.has_binop t' op -> + ot := t'; check_exp env t' exp1; check_exp env t' exp2 | TupE exps, T.Tup ts when List.length exps = List.length ts -> diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok index f1401236c8e..26051ca0e82 100644 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ b/test/run/ok/bit-ops.wasm.stderr.ok @@ -1,120 +1,120 @@ compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp -of_prim: Word8 +of_type: Word8 compile_binop: OrOp -of_prim: Word8 +of_type: Word8 compile_binop: AndOp -of_prim: Word8 +of_type: Word8 compile_binop: AndOp -of_prim: Word8 +of_type: Word8 compile_binop: XorOp -of_prim: Word8 +of_type: Word8 compile_binop: XorOp -of_prim: Word8 +of_type: Word8 compile_binop: ShiftLOp -of_prim: Word8 +of_type: Word8 compile_binop: ShiftLOp -of_prim: Word8 +of_type: Word8 compile_binop: ShiftROp -of_prim: Word8 +of_type: Word8 compile_binop: ShiftROp -of_prim: Word8 +of_type: Word8 compile_binop: RotLOp -of_prim: Word8 +of_type: Word8 compile_binop: RotLOp -of_prim: Word8 +of_type: Word8 compile_binop: RotROp -of_prim: Word8 +of_type: Word8 compile_binop: RotROp -of_prim: Word8 +of_type: Word8 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp -of_prim: Word16 +of_type: Word16 compile_binop: OrOp -of_prim: Word16 +of_type: Word16 compile_binop: AndOp -of_prim: Word16 +of_type: Word16 compile_binop: AndOp -of_prim: Word16 +of_type: Word16 compile_binop: XorOp -of_prim: Word16 +of_type: Word16 compile_binop: XorOp -of_prim: Word16 +of_type: Word16 compile_binop: ShiftLOp -of_prim: Word16 +of_type: Word16 compile_binop: ShiftLOp -of_prim: Word16 +of_type: Word16 compile_binop: ShiftROp -of_prim: Word16 +of_type: Word16 compile_binop: ShiftROp -of_prim: Word16 +of_type: Word16 compile_binop: RotLOp -of_prim: Word16 +of_type: Word16 compile_binop: RotLOp -of_prim: Word16 +of_type: Word16 compile_binop: RotROp -of_prim: Word16 +of_type: Word16 compile_binop: RotROp -of_prim: Word16 +of_type: Word16 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp -of_prim: Word32 +of_type: Word32 compile_binop: OrOp -of_prim: Word32 +of_type: Word32 compile_binop: AndOp -of_prim: Word32 +of_type: Word32 compile_binop: AndOp -of_prim: Word32 +of_type: Word32 compile_binop: XorOp -of_prim: Word32 +of_type: Word32 compile_binop: XorOp -of_prim: Word32 +of_type: Word32 compile_binop: ShiftLOp -of_prim: Word32 +of_type: Word32 compile_binop: ShiftLOp -of_prim: Word32 +of_type: Word32 compile_binop: ShiftROp -of_prim: Word32 +of_type: Word32 compile_binop: ShiftROp -of_prim: Word32 +of_type: Word32 compile_binop: RotLOp -of_prim: Word32 +of_type: Word32 compile_binop: RotLOp -of_prim: Word32 +of_type: Word32 compile_binop: RotROp -of_prim: Word32 +of_type: Word32 compile_binop: RotROp -of_prim: Word32 +of_type: Word32 compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp -of_prim: Word64 +of_type: Word64 compile_binop: OrOp -of_prim: Word64 +of_type: Word64 compile_binop: AndOp -of_prim: Word64 +of_type: Word64 compile_binop: AndOp -of_prim: Word64 +of_type: Word64 compile_binop: XorOp -of_prim: Word64 +of_type: Word64 compile_binop: XorOp -of_prim: Word64 +of_type: Word64 compile_binop: ShiftLOp -of_prim: Word64 +of_type: Word64 compile_binop: ShiftLOp -of_prim: Word64 +of_type: Word64 compile_binop: ShiftROp -of_prim: Word64 +of_type: Word64 compile_binop: ShiftROp -of_prim: Word64 +of_type: Word64 compile_binop: RotLOp -of_prim: Word64 +of_type: Word64 compile_binop: RotLOp -of_prim: Word64 +of_type: Word64 compile_binop: RotROp -of_prim: Word64 +of_type: Word64 compile_binop: RotROp -of_prim: Word64 +of_type: Word64 diff --git a/test/run/ok/issue122.run-low.ok b/test/run/ok/issue122.run-low.ok deleted file mode 100644 index 2d56f4094b0..00000000000 --- a/test/run/ok/issue122.run-low.ok +++ /dev/null @@ -1 +0,0 @@ -issue122.as:1.8-1.25: execution error, arithmetic overflow diff --git a/test/run/ok/issue122.run.ok b/test/run/ok/issue122.run.ok deleted file mode 100644 index 2d56f4094b0..00000000000 --- a/test/run/ok/issue122.run.ok +++ /dev/null @@ -1 +0,0 @@ -issue122.as:1.8-1.25: execution error, arithmetic overflow diff --git a/test/run/ok/issue122.wasm.stderr.ok b/test/run/ok/issue122.wasm.stderr.ok deleted file mode 100644 index 2671c9253c2..00000000000 --- a/test/run/ok/issue122.wasm.stderr.ok +++ /dev/null @@ -1,4 +0,0 @@ -(unknown location): internal error, Invalid_argument("non-primitive operator type: Any") - -Last environment: - diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index 29912e7004a..b000c649143 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -5,118 +5,118 @@ compile_binop: PowOp compile_binop: PowOp compile_binop: PowOp compile_binop: AddOp -of_prim: Float +of_type: Float compile_binop: AddOp -of_prim: Float +of_type: Float compile_binop: SubOp -of_prim: Float +of_type: Float compile_binop: SubOp -of_prim: Float +of_type: Float compile_binop: MulOp -of_prim: Float +of_type: Float compile_binop: MulOp -of_prim: Float +of_type: Float compile_binop: DivOp -of_prim: Float +of_type: Float compile_binop: DivOp -of_prim: Float +of_type: Float compile_binop: PowOp -of_prim: Float +of_type: Float compile_binop: PowOp -of_prim: Float +of_type: Float compile_binop: AddOp -of_prim: Word8 +of_type: Word8 compile_binop: AddOp -of_prim: Word8 +of_type: Word8 compile_binop: SubOp -of_prim: Word8 +of_type: Word8 compile_binop: SubOp -of_prim: Word8 +of_type: Word8 compile_binop: MulOp -of_prim: Word8 +of_type: Word8 compile_binop: MulOp -of_prim: Word8 +of_type: Word8 compile_binop: DivOp -of_prim: Word8 +of_type: Word8 compile_binop: DivOp -of_prim: Word8 +of_type: Word8 compile_binop: ModOp -of_prim: Word8 +of_type: Word8 compile_binop: ModOp -of_prim: Word8 +of_type: Word8 compile_binop: PowOp -of_prim: Word8 +of_type: Word8 compile_binop: PowOp -of_prim: Word8 +of_type: Word8 compile_binop: AddOp -of_prim: Word16 +of_type: Word16 compile_binop: AddOp -of_prim: Word16 +of_type: Word16 compile_binop: SubOp -of_prim: Word16 +of_type: Word16 compile_binop: SubOp -of_prim: Word16 +of_type: Word16 compile_binop: MulOp -of_prim: Word16 +of_type: Word16 compile_binop: MulOp -of_prim: Word16 +of_type: Word16 compile_binop: DivOp -of_prim: Word16 +of_type: Word16 compile_binop: DivOp -of_prim: Word16 +of_type: Word16 compile_binop: ModOp -of_prim: Word16 +of_type: Word16 compile_binop: ModOp -of_prim: Word16 +of_type: Word16 compile_binop: PowOp -of_prim: Word16 +of_type: Word16 compile_binop: PowOp -of_prim: Word16 +of_type: Word16 compile_binop: AddOp -of_prim: Word32 +of_type: Word32 compile_binop: AddOp -of_prim: Word32 +of_type: Word32 compile_binop: SubOp -of_prim: Word32 +of_type: Word32 compile_binop: SubOp -of_prim: Word32 +of_type: Word32 compile_binop: MulOp -of_prim: Word32 +of_type: Word32 compile_binop: MulOp -of_prim: Word32 +of_type: Word32 compile_binop: DivOp -of_prim: Word32 +of_type: Word32 compile_binop: DivOp -of_prim: Word32 +of_type: Word32 compile_binop: ModOp -of_prim: Word32 +of_type: Word32 compile_binop: ModOp -of_prim: Word32 +of_type: Word32 compile_binop: PowOp -of_prim: Word32 +of_type: Word32 compile_binop: PowOp -of_prim: Word32 +of_type: Word32 compile_binop: AddOp -of_prim: Word64 +of_type: Word64 compile_binop: AddOp -of_prim: Word64 +of_type: Word64 compile_binop: SubOp -of_prim: Word64 +of_type: Word64 compile_binop: SubOp -of_prim: Word64 +of_type: Word64 compile_binop: MulOp -of_prim: Word64 +of_type: Word64 compile_binop: MulOp -of_prim: Word64 +of_type: Word64 compile_binop: DivOp -of_prim: Word64 +of_type: Word64 compile_binop: DivOp -of_prim: Word64 +of_type: Word64 compile_binop: ModOp -of_prim: Word64 +of_type: Word64 compile_binop: ModOp -of_prim: Word64 +of_type: Word64 compile_binop: PowOp -of_prim: Word64 +of_type: Word64 compile_binop: PowOp -of_prim: Word64 +of_type: Word64 diff --git a/test/run/ok/relational-ops.wasm.stderr.ok b/test/run/ok/relational-ops.wasm.stderr.ok index b018b665cd4..e141c2551b0 100644 --- a/test/run/ok/relational-ops.wasm.stderr.ok +++ b/test/run/ok/relational-ops.wasm.stderr.ok @@ -1,72 +1,72 @@ -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Float -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word8 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word16 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word32 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Word64 -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char -of_prim: Char +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Float +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word8 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word16 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word32 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Word64 +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char +of_type: Char From 04933cc3c2dbc9c23ac5addef45c1b76b255e512 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 3 Jan 2019 20:50:43 +0100 Subject: [PATCH 35/41] Traps in `dvm` are now silent, as they should thanks to https://github.com/dfinity-lab/dev/pull/408 But in order to keep the test suite useful, `run.sh` now automatically appends print("Top-level code done.\n") to all test cases (in `--dfinity` mode). This way, a trap in the top-level code will be observable in the `.dvm-run.ok` file It does not help with, say ignore(async {assert False}); so tests that want to check the absence of traps need to somehow make that visible. --- Jenkinsfile | 2 +- .../ok/async-loop-while.dvm-run.ok | 1 + test/run-dfinity/ok/async-loop.dvm-run.ok | 1 + test/run-dfinity/ok/async-new-obj.dvm-run.ok | 1 + test/run-dfinity/ok/async-obj-mut.dvm-run.ok | 1 + test/run-dfinity/ok/async-while.dvm-run.ok | 1 + test/run-dfinity/ok/closure-params.dvm-run.ok | 1 + test/run-dfinity/ok/counter-class.dvm-run.ok | 1 - test/run-dfinity/ok/counter.dvm-run.ok | 1 + test/run-dfinity/ok/data-params.dvm-run.ok | 1 + test/run-dfinity/ok/empty-actor.dvm-run.ok | 1 + test/run-dfinity/ok/fac.dvm-run.ok | 2 +- .../ok/flatten-awaitables.dvm-run.ok | 1 + .../ok/generic-tail-rec.dvm-run.ok | 1 + .../ok/hello-concat-world.dvm-run.ok | 1 + .../ok/hello-world-async.dvm-run.ok | 1 + .../ok/hello-world-await.dvm-run.ok | 1 + test/run-dfinity/ok/hello-world.dvm-run.ok | 1 + test/run-dfinity/ok/hello-world2.dvm-run.ok | 1 + test/run-dfinity/ok/hello-world3.dvm-run.ok | 1 + .../ok/indirect-counter.dvm-run.ok | 1 + test/run-dfinity/ok/nary-async.dvm-run.ok | 1 + test/run-dfinity/ok/overflow.dvm-run.ok | 5 +++ test/run-dfinity/ok/overflow.run-low.ok | 6 ++++ test/run-dfinity/ok/overflow.run.ok | 6 ++++ .../ok/reference-params.dvm-run.ok | 1 + test/run-dfinity/ok/selftail.dvm-run.ok | 1 + test/run-dfinity/ok/tailpositions.dvm-run.ok | 1 + test/run-dfinity/ok/the-answer.dvm-run.ok | 2 +- test/run-dfinity/overflow.as | 34 +++++++++++++++++++ test/run.sh | 11 +++--- 31 files changed, 83 insertions(+), 8 deletions(-) delete mode 100644 test/run-dfinity/ok/counter-class.dvm-run.ok create mode 100644 test/run-dfinity/ok/empty-actor.dvm-run.ok create mode 100644 test/run-dfinity/ok/overflow.dvm-run.ok create mode 100644 test/run-dfinity/ok/overflow.run-low.ok create mode 100644 test/run-dfinity/ok/overflow.run.ok create mode 100644 test/run-dfinity/overflow.as diff --git a/Jenkinsfile b/Jenkinsfile index 9c50a951aa0..e455ac06919 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -5,7 +5,7 @@ pipeline { steps { sh 'git submodule update --init --recursive' sh 'git clone --recursive git@github.com:dfinity-lab/dev nix/dev' - sh 'git -C nix/dev checkout 5bc3b33f92e20432588ee0bec513edef649f237d' + sh 'git -C nix/dev checkout 268a453421fc345bf170435a264c03826b14999f' sh 'git -C nix/dev submodule update --init --recursive' } } diff --git a/test/run-dfinity/ok/async-loop-while.dvm-run.ok b/test/run-dfinity/ok/async-loop-while.dvm-run.ok index ac6ac408923..48962aa5514 100644 --- a/test/run-dfinity/ok/async-loop-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop-while.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/async-loop.dvm-run.ok b/test/run-dfinity/ok/async-loop.dvm-run.ok index ac6ac408923..48962aa5514 100644 --- a/test/run-dfinity/ok/async-loop.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/async-new-obj.dvm-run.ok b/test/run-dfinity/ok/async-new-obj.dvm-run.ok index 9dfdfbb5120..7e362ebf28b 100644 --- a/test/run-dfinity/ok/async-new-obj.dvm-run.ok +++ b/test/run-dfinity/ok/async-new-obj.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. aaab babb cacb diff --git a/test/run-dfinity/ok/async-obj-mut.dvm-run.ok b/test/run-dfinity/ok/async-obj-mut.dvm-run.ok index 98f29c526f9..4adf0505adb 100644 --- a/test/run-dfinity/ok/async-obj-mut.dvm-run.ok +++ b/test/run-dfinity/ok/async-obj-mut.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. 123 done creating 345 diff --git a/test/run-dfinity/ok/async-while.dvm-run.ok b/test/run-dfinity/ok/async-while.dvm-run.ok index ac6ac408923..48962aa5514 100644 --- a/test/run-dfinity/ok/async-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-while.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/closure-params.dvm-run.ok b/test/run-dfinity/ok/closure-params.dvm-run.ok index 17b4c77d5c9..ebca8e760cd 100644 --- a/test/run-dfinity/ok/closure-params.dvm-run.ok +++ b/test/run-dfinity/ok/closure-params.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. 1 1 3 diff --git a/test/run-dfinity/ok/counter-class.dvm-run.ok b/test/run-dfinity/ok/counter-class.dvm-run.ok deleted file mode 100644 index 2ccd2408cd7..00000000000 --- a/test/run-dfinity/ok/counter-class.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -dvm: user error (Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/counter.dvm-run.ok b/test/run-dfinity/ok/counter.dvm-run.ok index dc01807c8fe..a3480e087a1 100644 --- a/test/run-dfinity/ok/counter.dvm-run.ok +++ b/test/run-dfinity/ok/counter.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. 2344 diff --git a/test/run-dfinity/ok/data-params.dvm-run.ok b/test/run-dfinity/ok/data-params.dvm-run.ok index e77c77a5d0a..26d329b39b0 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. 1 3 6 diff --git a/test/run-dfinity/ok/empty-actor.dvm-run.ok b/test/run-dfinity/ok/empty-actor.dvm-run.ok new file mode 100644 index 00000000000..3b7e66c4381 --- /dev/null +++ b/test/run-dfinity/ok/empty-actor.dvm-run.ok @@ -0,0 +1 @@ +Top-level code done. diff --git a/test/run-dfinity/ok/fac.dvm-run.ok b/test/run-dfinity/ok/fac.dvm-run.ok index 52bd8e43afb..6332b8b5e87 100644 --- a/test/run-dfinity/ok/fac.dvm-run.ok +++ b/test/run-dfinity/ok/fac.dvm-run.ok @@ -1 +1 @@ -120 +120Top-level code done. diff --git a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok index 4c1b1bd6651..c8ab234ed8e 100644 --- a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok +++ b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. first-order ,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, diff --git a/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok b/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok index 6d96c93ceef..1cfb8645d12 100644 --- a/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok +++ b/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok @@ -2,3 +2,4 @@ done 1 done 2 done 3 done 4 +Top-level code done. diff --git a/test/run-dfinity/ok/hello-concat-world.dvm-run.ok b/test/run-dfinity/ok/hello-concat-world.dvm-run.ok index 980a0d5f19a..8d9d4c9eb23 100644 --- a/test/run-dfinity/ok/hello-concat-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-concat-world.dvm-run.ok @@ -1 +1,2 @@ Hello World! +Top-level code done. diff --git a/test/run-dfinity/ok/hello-world-async.dvm-run.ok b/test/run-dfinity/ok/hello-world-async.dvm-run.ok index 980a0d5f19a..9c393e21691 100644 --- a/test/run-dfinity/ok/hello-world-async.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-async.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world-await.dvm-run.ok b/test/run-dfinity/ok/hello-world-await.dvm-run.ok index 980a0d5f19a..9c393e21691 100644 --- a/test/run-dfinity/ok/hello-world-await.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-await.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world.dvm-run.ok b/test/run-dfinity/ok/hello-world.dvm-run.ok index 980a0d5f19a..8d9d4c9eb23 100644 --- a/test/run-dfinity/ok/hello-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world.dvm-run.ok @@ -1 +1,2 @@ Hello World! +Top-level code done. diff --git a/test/run-dfinity/ok/hello-world2.dvm-run.ok b/test/run-dfinity/ok/hello-world2.dvm-run.ok index 980a0d5f19a..9c393e21691 100644 --- a/test/run-dfinity/ok/hello-world2.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world2.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world3.dvm-run.ok b/test/run-dfinity/ok/hello-world3.dvm-run.ok index 980a0d5f19a..9c393e21691 100644 --- a/test/run-dfinity/ok/hello-world3.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world3.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/indirect-counter.dvm-run.ok b/test/run-dfinity/ok/indirect-counter.dvm-run.ok index dc01807c8fe..a3480e087a1 100644 --- a/test/run-dfinity/ok/indirect-counter.dvm-run.ok +++ b/test/run-dfinity/ok/indirect-counter.dvm-run.ok @@ -1 +1,2 @@ +Top-level code done. 2344 diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index 5b2baf03eb2..b4dbdd9a6ee 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. 0_0 1_0 2_0 diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok new file mode 100644 index 00000000000..12855d1b218 --- /dev/null +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -0,0 +1,5 @@ +Top-level code done. +This is reachable. +This is reachable. +This is reachable. +This is reachable. diff --git a/test/run-dfinity/ok/overflow.run-low.ok b/test/run-dfinity/ok/overflow.run-low.ok new file mode 100644 index 00000000000..99ef5a02d51 --- /dev/null +++ b/test/run-dfinity/ok/overflow.run-low.ok @@ -0,0 +1,6 @@ +This is reachable. +This is reachable. +overflow.as:14.14-14.17: execution error, arithmetic overflow +overflow.as:18.14-18.17: execution error, arithmetic overflow +This is reachable. +This is reachable. diff --git a/test/run-dfinity/ok/overflow.run.ok b/test/run-dfinity/ok/overflow.run.ok new file mode 100644 index 00000000000..99ef5a02d51 --- /dev/null +++ b/test/run-dfinity/ok/overflow.run.ok @@ -0,0 +1,6 @@ +This is reachable. +This is reachable. +overflow.as:14.14-14.17: execution error, arithmetic overflow +overflow.as:18.14-18.17: execution error, arithmetic overflow +This is reachable. +This is reachable. diff --git a/test/run-dfinity/ok/reference-params.dvm-run.ok b/test/run-dfinity/ok/reference-params.dvm-run.ok index 8650e0ef3bf..9a57656f7a1 100644 --- a/test/run-dfinity/ok/reference-params.dvm-run.ok +++ b/test/run-dfinity/ok/reference-params.dvm-run.ok @@ -1,3 +1,4 @@ +Top-level code done. Hello World! Hello World! Hello World! diff --git a/test/run-dfinity/ok/selftail.dvm-run.ok b/test/run-dfinity/ok/selftail.dvm-run.ok index acb397e19f2..d58ee786174 100644 --- a/test/run-dfinity/ok/selftail.dvm-run.ok +++ b/test/run-dfinity/ok/selftail.dvm-run.ok @@ -1,2 +1,3 @@ ok1 ok2 +Top-level code done. diff --git a/test/run-dfinity/ok/tailpositions.dvm-run.ok b/test/run-dfinity/ok/tailpositions.dvm-run.ok index 025c12b0e9a..a0ef19cc3e9 100644 --- a/test/run-dfinity/ok/tailpositions.dvm-run.ok +++ b/test/run-dfinity/ok/tailpositions.dvm-run.ok @@ -5,3 +5,4 @@ done 4 done 5 done 6 done 7 +Top-level code done. diff --git a/test/run-dfinity/ok/the-answer.dvm-run.ok b/test/run-dfinity/ok/the-answer.dvm-run.ok index d81cc0710eb..911d4f5b36f 100644 --- a/test/run-dfinity/ok/the-answer.dvm-run.ok +++ b/test/run-dfinity/ok/the-answer.dvm-run.ok @@ -1 +1 @@ -42 +42Top-level code done. diff --git a/test/run-dfinity/overflow.as b/test/run-dfinity/overflow.as new file mode 100644 index 00000000000..49b0222c865 --- /dev/null +++ b/test/run-dfinity/overflow.as @@ -0,0 +1,34 @@ +// We have theses tests in run-dfinity because we want to check that certain +// traps are happening, and a good way to test this is if a message gets +// aborted. + +ignore(async { + ignore ((0-1):Int); + print("This is reachable.\n"); +}); +ignore(async { + ignore ((1-1):Nat); + print("This is reachable.\n"); +}); +ignore(async { + ignore ((0-1):Nat); + print("This should be unreachable.\n"); +}); +ignore(async { + ignore ((0-1):Nat); + print("This should be unreachable.\n"); +}); +/* +ignore(async { + ignore ((18446744073709551615 + 0):Nat); + print("This is reachable.\n"); +}); +*/ +ignore(async { + ignore ((9223372036854775806 + 9223372036854775806 + 1):Nat); + print("This is reachable.\n"); +}); +ignore(async { + ignore ((9223372036854775806 + 9223372036854775806 + 2):Nat); + print("This is reachable.\n"); +}); diff --git a/test/run.sh b/test/run.sh index c85ec58f20e..7811ee62231 100755 --- a/test/run.sh +++ b/test/run.sh @@ -92,12 +92,15 @@ do # Compile echo -n " [wasm]" - $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as 2> $out/$base.wasm.stderr + if [ $DFINITY = 'yes' ] + then + $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as <(echo 'print("Top-level code done.\n")') -o $out/$base.wasm 2> $out/$base.wasm.stderr + else + $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as -o $out/$base.wasm 2> $out/$base.wasm.stderr + fi diff_files="$diff_files $base.wasm.stderr" - if [ -e $base.wasm ] + if [ -e $out/$base.wasm ] then - mv $base.wasm $base.wasm.map $out - if [ "$SKIP_RUNNING" != yes ] then if [ $DFINITY = 'yes' ] From 45544b7000729d6ba1224c996311fbf488c81877 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 3 Jan 2019 21:02:14 +0100 Subject: [PATCH 36/41] A simple test case for trap-on-array-out-of-bounds also catch out-of-bounds error in the interpreter and treat them as traps. --- src/interpret.ml | 3 ++- test/run-dfinity/array-out-of-bounds.as | 11 +++++++++++ .../ok/array-out-of-bounds.dvm-run.ok | 1 + .../ok/array-out-of-bounds.run-low.ok | 2 ++ test/run-dfinity/ok/array-out-of-bounds.run.ok | 2 ++ test/run/ok/array-bounds.run-low.ok | 16 +--------------- test/run/ok/array-bounds.run.ok | 16 +--------------- 7 files changed, 20 insertions(+), 31 deletions(-) create mode 100644 test/run-dfinity/array-out-of-bounds.as create mode 100644 test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok create mode 100644 test/run-dfinity/ok/array-out-of-bounds.run-low.ok create mode 100644 test/run-dfinity/ok/array-out-of-bounds.run.ok diff --git a/src/interpret.ml b/src/interpret.ml index 10a1a34b7cc..e86deb8a1f3 100644 --- a/src/interpret.ml +++ b/src/interpret.ml @@ -311,7 +311,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = | IdxE (exp1, exp2) -> interpret_exp env exp1 (fun v1 -> interpret_exp env exp2 (fun v2 -> - k (V.as_array v1).(V.Int.to_int (V.as_int v2)) + k (try (V.as_array v1).(V.Int.to_int (V.as_int v2)) + with Invalid_argument s -> trap exp.at "%s" s) ) ) | CallE (exp1, typs, exp2) -> diff --git a/test/run-dfinity/array-out-of-bounds.as b/test/run-dfinity/array-out-of-bounds.as new file mode 100644 index 00000000000..e1502a20faf --- /dev/null +++ b/test/run-dfinity/array-out-of-bounds.as @@ -0,0 +1,11 @@ +let a = [0, 1, 2, 3, 4]; +let b = []; + +ignore(async { + ignore(a[5]); + print("Unreachable code reached\n"); +}); +ignore(async { + ignore(b[0]); + print("Unreachable code reached\n"); +}); diff --git a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok new file mode 100644 index 00000000000..3b7e66c4381 --- /dev/null +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -0,0 +1 @@ +Top-level code done. diff --git a/test/run-dfinity/ok/array-out-of-bounds.run-low.ok b/test/run-dfinity/ok/array-out-of-bounds.run-low.ok new file mode 100644 index 00000000000..48afd57d5df --- /dev/null +++ b/test/run-dfinity/ok/array-out-of-bounds.run-low.ok @@ -0,0 +1,2 @@ +array-out-of-bounds.as:5.10-5.14: execution error, index out of bounds +array-out-of-bounds.as:9.10-9.14: execution error, index out of bounds diff --git a/test/run-dfinity/ok/array-out-of-bounds.run.ok b/test/run-dfinity/ok/array-out-of-bounds.run.ok new file mode 100644 index 00000000000..48afd57d5df --- /dev/null +++ b/test/run-dfinity/ok/array-out-of-bounds.run.ok @@ -0,0 +1,2 @@ +array-out-of-bounds.as:5.10-5.14: execution error, index out of bounds +array-out-of-bounds.as:9.10-9.14: execution error, index out of bounds diff --git a/test/run/ok/array-bounds.run-low.ok b/test/run/ok/array-bounds.run-low.ok index d9a60a53b6a..62abb269136 100644 --- a/test/run/ok/array-bounds.run-low.ok +++ b/test/run/ok/array-bounds.run-low.ok @@ -1,15 +1 @@ -array-bounds.as:5.17-5.18: fatal error, Invalid_argument("index out of bounds") - -Last environment: -@new_async = func -Array_init = func -Array_tabulate = func -a = [0, 1, 2, 3, 4] -abs = func -ignore = func -n = 5 -print = func -printInt = func -range = class -revrange = class - +array-bounds.as:5.15-5.19: execution error, index out of bounds diff --git a/test/run/ok/array-bounds.run.ok b/test/run/ok/array-bounds.run.ok index d9a60a53b6a..62abb269136 100644 --- a/test/run/ok/array-bounds.run.ok +++ b/test/run/ok/array-bounds.run.ok @@ -1,15 +1 @@ -array-bounds.as:5.17-5.18: fatal error, Invalid_argument("index out of bounds") - -Last environment: -@new_async = func -Array_init = func -Array_tabulate = func -a = [0, 1, 2, 3, 4] -abs = func -ignore = func -n = 5 -print = func -printInt = func -range = class -revrange = class - +array-bounds.as:5.15-5.19: execution error, index out of bounds From 429c7adefa9fcef453dee766e54048e293ad7b9c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Tue, 8 Jan 2019 15:00:42 +0100 Subject: [PATCH 37/41] Switch to multi-value fork of wasm-spec --- .gitmodules | 2 +- nix/ocaml-wasm.nix | 6 +++--- src/wasm_copy/encodeMap.ml | 2 +- vendor/wasm-spec | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index f21531ffef2..9591b6a0d88 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "vendor/wasm-spec"] path = vendor/wasm-spec - url = https://github.com/WebAssembly/spec/ + url = https://github.com/WebAssembly/multi-value/ diff --git a/nix/ocaml-wasm.nix b/nix/ocaml-wasm.nix index 6eb36583f36..25f9857211a 100644 --- a/nix/ocaml-wasm.nix +++ b/nix/ocaml-wasm.nix @@ -18,9 +18,9 @@ stdenv.mkDerivation rec { #src = ../vendor/wasm-spec; src = fetchFromGitHub { owner = "WebAssembly"; - repo = "spec"; - rev = "639bb02f851d9468bdae533457d40731156ef12a"; - sha256 = "0vqkz428bkwpm0jdy717sfxvp9mh0ai9n849f3wq0vbiw0k6vzmk"; + repo = "multi-value"; + rev = "fa755dfe0c8ab3ec93636a092fc3dfbe8c8a232c"; + sha256 = "0867nd4k2lypal7g2a7816wi5zs4kp4w2dv9dxan9vvn3wi19b5i"; }; buildInputs = [ ocaml findlib ocamlbuild ]; diff --git a/src/wasm_copy/encodeMap.ml b/src/wasm_copy/encodeMap.ml index 021eee03674..78064409842 100644 --- a/src/wasm_copy/encodeMap.ml +++ b/src/wasm_copy/encodeMap.ml @@ -100,7 +100,7 @@ let encode m = let vu32 i = vu64 Int64.(logand (of_int32 i) 0xffffffffL) let vs7 i = vs64 (Int64.of_int i) let vs32 i = vs64 (Int64.of_int32 i) - let vs33 i = vs64 (Wasm.I64_convert.extend_s_i32 i) + let vs33 i = vs64 (Wasm.I64_convert.extend_i32_s i) let f32 x = u32 (Wasm.F32.to_bits x) let f64 x = u64 (Wasm.F64.to_bits x) diff --git a/vendor/wasm-spec b/vendor/wasm-spec index 639bb02f851..fa755dfe0c8 160000 --- a/vendor/wasm-spec +++ b/vendor/wasm-spec @@ -1 +1 @@ -Subproject commit 639bb02f851d9468bdae533457d40731156ef12a +Subproject commit fa755dfe0c8ab3ec93636a092fc3dfbe8c8a232c From 878f2beba079e2bdefc2bf66d606b004f6a49c72 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Tue, 8 Jan 2019 15:07:58 +0100 Subject: [PATCH 38/41] Switch back to using the AST from the wasm library this undoes 8783539df916e6e3eaa1a1ff5889891d26d376d5. --- default.nix | 1 - src/_tags | 1 - src/compile.ml | 226 +++++++++++----------- src/compile.mli | 2 +- src/{wasm_copy => }/customModule.ml | 2 +- src/{wasm_copy => }/customSections.ml | 0 src/{wasm_copy => }/encodeMap.ml | 16 +- src/instrList.ml | 14 +- src/js_main.ml | 2 +- src/main.ml | 2 +- src/pipeline.ml | 2 +- src/pipeline.mli | 2 +- src/wasm_copy.mlpack | 5 - src/wasm_copy/ast.ml | 259 -------------------------- src/wasm_copy/types.ml | 108 ----------- 15 files changed, 134 insertions(+), 508 deletions(-) rename src/{wasm_copy => }/customModule.ml (98%) rename src/{wasm_copy => }/customSections.ml (100%) rename src/{wasm_copy => }/encodeMap.ml (98%) delete mode 100644 src/wasm_copy.mlpack delete mode 100644 src/wasm_copy/ast.ml delete mode 100644 src/wasm_copy/types.ml diff --git a/default.nix b/default.nix index cb38a984b2e..4457ba47e04 100644 --- a/default.nix +++ b/default.nix @@ -61,7 +61,6 @@ rec { src = sourceByRegex ./. [ "src/" "src/Makefile.*" - "src/wasm_copy/" "src/.*.ml" "src/.*.mli" "src/.*.mly" diff --git a/src/_tags b/src/_tags index 845ca8ad8f5..b8a23322447 100644 --- a/src/_tags +++ b/src/_tags @@ -1,2 +1 @@ <**/*>: coverage -: for-pack(Wasm_copy) diff --git a/src/compile.ml b/src/compile.ml index 976ce19bccc..bfb4928efb7 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1,12 +1,12 @@ -open Wasm_copy.Ast -open Wasm_copy.Types +open Wasm.Ast +open Wasm.Types open Source open Ir (* Re-shadow Source.(@@), to get Pervasives.(@@) *) let (@@) = Pervasives.(@@) -open Wasm_copy.CustomModule +open CustomModule module G = InstrList let (^^) = G.(^^) (* is this how we do that? *) @@ -107,7 +107,7 @@ module E = struct (* The prelude. We need to re-use this when compiling actors *) prelude : prog; (* Exports that need a custom type for the hypervisor *) - dfinity_types : (int32 * Wasm_copy.CustomSections.type_ list) list ref; + dfinity_types : (int32 * CustomSections.type_ list) list ref; (* Where does static memory end and dynamic memory begin? *) end_of_static_memory : int32 ref; (* Static memory defined so far *) @@ -303,8 +303,8 @@ end (* Function called compile_* return a list of instructions (and maybe other stuff) *) -let compile_unboxed_const i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I32 i))) -let compile_const_64 i = G.i (Wasm_copy.Ast.Const (nr (Wasm.Values.I64 i))) +let compile_unboxed_const i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I32 i))) +let compile_const_64 i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I64 i))) let compile_unboxed_zero = compile_unboxed_const 0l let compile_unit = compile_unboxed_const 1l (* This needs to be disjoint from all pointers *) @@ -324,8 +324,8 @@ let compile_divU_const = compile_op_const I32Op.DivU let new_local_ env t name = let i = E.add_anon_local env t in E.add_local_name env i name; - ( G.i (SetLocal (nr i)) - , G.i (GetLocal (nr i)) + ( G.i (LocalSet (nr i)) + , G.i (LocalGet (nr i)) , i ) @@ -411,24 +411,24 @@ module Heap = struct let dyn_alloc_words env = Func.share_code env "alloc_words" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (GetLocal (nr 0l)) in + let get_n = G.i (LocalGet (nr 0l)) in (* expect the size (in words), returns the pointer *) - G.i (GetGlobal (nr heap_ptr)) ^^ + G.i (GlobalGet (nr heap_ptr)) ^^ (* Update heap pointer *) get_n ^^ compile_mul_const word_size ^^ (* Add to old heap value *) - G.i (GetGlobal (nr heap_ptr)) ^^ + G.i (GlobalGet (nr heap_ptr)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (SetGlobal (nr heap_ptr)) + G.i (GlobalSet (nr heap_ptr)) ) let dyn_alloc_bytes env = Func.share_code env "alloc_bytes" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (GetLocal (nr 0l)) in + let get_n = G.i (LocalGet (nr 0l)) in get_n ^^ (* Round up to next multiple of the word size and convert to words *) @@ -481,9 +481,9 @@ module Heap = struct let memcpy env = Func.share_code env "memcpy" ["from", I32Type; "two", I32Type; "n", I32Type] [] (fun env -> - let get_from = G.i (GetLocal (nr 0l)) in - let get_to = G.i (GetLocal (nr 1l)) in - let get_n = G.i (GetLocal (nr 2l)) in + let get_from = G.i (LocalGet (nr 0l)) in + let get_to = G.i (LocalGet (nr 1l)) in + let get_n = G.i (LocalGet (nr 2l)) in get_n ^^ from_0_to_n env (fun get_i -> get_to ^^ @@ -517,28 +517,28 @@ module ElemHeap = struct reference table *) let remember_reference env : G.t = Func.share_code env "remember_reference" ["ref", I32Type] [I32Type] (fun env -> - let get_ref = G.i (GetLocal (nr 0l)) in + let get_ref = G.i (LocalGet (nr 0l)) in (* Return index *) - G.i (GetGlobal (nr ref_counter)) ^^ + G.i (GlobalGet (nr ref_counter)) ^^ (* Store reference *) - G.i (GetGlobal (nr ref_counter)) ^^ + G.i (GlobalGet (nr ref_counter)) ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ store_ptr ^^ (* Bump counter *) - G.i (GetGlobal (nr ref_counter)) ^^ + G.i (GlobalGet (nr ref_counter)) ^^ compile_add_const 1l ^^ - G.i (SetGlobal (nr ref_counter)) + G.i (GlobalSet (nr ref_counter)) ) (* Assumes a index into the table on the stack, and replaces it with the reference *) let recall_reference env : G.t = Func.share_code env "recall_reference" ["ref_idx", I32Type] [I32Type] (fun env -> - let get_ref_idx = G.i (GetLocal (nr 0l)) in + let get_ref_idx = G.i (LocalGet (nr 0l)) in get_ref_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ @@ -564,7 +564,7 @@ module ClosureTable = struct reference table *) let remember_closure env : G.t = Func.share_code env "remember_closure" ["ptr", I32Type] [I32Type] (fun env -> - let get_ptr = G.i (GetLocal (nr 0l)) in + let get_ptr = G.i (LocalGet (nr 0l)) in (* Return index *) get_counter ^^ @@ -587,7 +587,7 @@ module ClosureTable = struct (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) let recall_closure env : G.t = Func.share_code env "recall_closure" ["closure_idx", I32Type] [I32Type] (fun env -> - let get_closure_idx = G.i (GetLocal (nr 0l)) in + let get_closure_idx = G.i (LocalGet (nr 0l)) in get_closure_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ @@ -604,7 +604,7 @@ module BitTagged = struct let if_unboxed env retty is1 is2 = Func.share_code env "is_unboxed" ["x", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in + let get_x = G.i (LocalGet (nr 0l)) in (* Get bit *) get_x ^^ compile_unboxed_const 1l ^^ @@ -735,11 +735,11 @@ module Var = struct (* Stores the payload *) let set_val env var = match E.lookup_var env var with | Some (Local i) -> - G.i (SetLocal (nr i)) + G.i (LocalSet (nr i)) | Some (HeapInd (i, off)) -> let (set_new_val, get_new_val) = new_local env "new_val" in set_new_val ^^ - G.i (GetLocal (nr i)) ^^ + G.i (LocalGet (nr i)) ^^ get_new_val ^^ Heap.store_field off | Some (Static i) -> @@ -753,8 +753,8 @@ module Var = struct (* Returns the payload *) let get_val env var = match E.lookup_var env var with - | Some (Local i) -> G.i (GetLocal (nr i)) - | Some (HeapInd (i, off)) -> G.i (GetLocal (nr i)) ^^ Heap.load_field off + | Some (Local i) -> G.i (LocalGet (nr i)) + | Some (HeapInd (i, off)) -> G.i (LocalGet (nr i)) ^^ Heap.load_field off | Some (Static i) -> compile_unboxed_const i ^^ load_ptr | Some (Deferred d) -> d.allocate env | None -> G.i Unreachable @@ -763,17 +763,17 @@ module Var = struct and code to restore it, including adding to the environment *) let capture env var : G.t * (E.t -> (E.t * G.t)) = match E.lookup_var env var with | Some (Local i) -> - ( G.i (GetLocal (nr i)) + ( G.i (LocalGet (nr i)) , fun env1 -> let (env2, j) = E.add_direct_local env1 var in - let restore_code = G.i (SetLocal (nr j)) + let restore_code = G.i (LocalSet (nr j)) in (env2, restore_code) ) | Some (HeapInd (i, off)) -> - ( G.i (GetLocal (nr i)) + ( G.i (LocalGet (nr i)) , fun env1 -> let (env2, j) = E.add_local_with_offset env1 var off in - let restore_code = G.i (SetLocal (nr j)) + let restore_code = G.i (LocalSet (nr j)) in (env2, restore_code) ) | Some (Static i) -> @@ -786,7 +786,7 @@ module Var = struct (either a mutbox, if already mutable, or a freshly allocated box *) let get_val_ptr env var = match E.lookup_var env var with - | Some (HeapInd (i, 1l)) -> G.i (GetLocal (nr i)) + | Some (HeapInd (i, 1l)) -> G.i (LocalGet (nr i)) | _ -> field_box env (get_val env var) end (* Var *) @@ -906,7 +906,7 @@ module AllocHow = struct let (env1, i) = E.add_local_with_offset env name 1l in let alloc_code = Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i (SetLocal (nr i)) in + G.i (LocalSet (nr i)) in (env1, alloc_code) | _ -> (env, G.nop) @@ -928,7 +928,7 @@ module Closure = struct let first_captured = header_size - let load_the_closure = G.i (GetLocal (nr 0l)) + let load_the_closure = G.i (LocalGet (nr 0l)) let load_closure i = load_the_closure ^^ Heap.load_field (Int32.add first_captured i) @@ -977,7 +977,7 @@ module BoxedInt = struct get_i let box env = Func.share_code env "box_int" ["n", I64Type] [I32Type] (fun env -> - let get_n = G.i (GetLocal (nr 0l)) in + let get_n = G.i (LocalGet (nr 0l)) in get_n ^^ compile_const_64 (Int64.of_int (1 lsl 5)) ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ G.if_ (ValBlockType (Some I32Type)) @@ -986,7 +986,7 @@ module BoxedInt = struct ) let unbox env = Func.share_code env "unbox_int" ["n", I32Type] [I64Type] (fun env -> - let get_n = G.i (GetLocal (nr 0l)) in + let get_n = G.i (LocalGet (nr 0l)) in get_n ^^ BitTagged.if_unboxed env (ValBlockType (Some I64Type)) ( get_n ^^ BitTagged.untag_scalar env) @@ -1091,8 +1091,8 @@ module Object = struct (* Returns a pointer to the object field *) let idx_hash env = Func.share_code env "obj_idx" ["x", I32Type; "hash", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in - let get_hash = G.i (GetLocal (nr 1l)) in + let get_x = G.i (LocalGet (nr 0l)) in + let get_hash = G.i (LocalGet (nr 1l)) in let (set_f, get_f) = new_local env "f" in let (set_r, get_r) = new_local env "r" in @@ -1171,8 +1171,8 @@ module Text = struct (* Two strings on stack *) let concat env = Func.share_code env "concat" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in - let get_y = G.i (GetLocal (nr 1l)) in + let get_x = G.i (LocalGet (nr 0l)) in + let get_y = G.i (LocalGet (nr 1l)) in let (set_z, get_z) = new_local env "z" in let (set_len1, get_len1) = new_local env "len1" in let (set_len2, get_len2) = new_local env "len2" in @@ -1229,8 +1229,8 @@ module Text = struct (* Two strings on stack *) let compare env = Func.share_code env "Text.compare" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in - let get_y = G.i (GetLocal (nr 1l)) in + let get_x = G.i (LocalGet (nr 0l)) in + let get_y = G.i (LocalGet (nr 1l)) in let (set_len1, get_len1) = new_local env "len1" in let (set_len2, get_len2) = new_local env "len2" in @@ -1274,8 +1274,8 @@ module Array = struct (* Dynamic array access. Returns the address of the field. Does bounds checking *) let idx env = Func.share_code env "Array.idx" ["array", I32Type; "idx", I32Type] [I32Type] (fun env -> - let get_array = G.i (GetLocal (nr 0l)) in - let get_idx = G.i (GetLocal (nr 1l)) in + let get_array = G.i (LocalGet (nr 0l)) in + let get_idx = G.i (LocalGet (nr 1l)) in (* No need to check the lower bound, we interpret is as unsigned *) (* Check the upper bound *) @@ -1299,8 +1299,8 @@ module Array = struct let common_funcs env = let get_array_object = Closure.load_closure 0l in - let get_first_arg = G.i (GetLocal (nr 1l)) in - let get_second_arg = G.i (GetLocal (nr 2l)) in + let get_first_arg = G.i (LocalGet (nr 1l)) in + let get_second_arg = G.i (LocalGet (nr 2l)) in E.define_built_in env "array_get" (fun () -> Func.of_body env ["clos", I32Type; "idx", I32Type] [I32Type] (fun env1 -> @@ -1498,7 +1498,7 @@ module Array = struct let name = Printf.sprintf "to_%i_tuple" n in let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in Func.share_code env name args [I32Type] (fun env -> - lit env (Lib.List.table n (fun i -> G.i (GetLocal (nr (Int32.of_int i))))) + lit env (Lib.List.table n (fun i -> G.i (LocalGet (nr (Int32.of_int i))))) ) (* Takes an argument tuple and puts the elements on the stack: *) @@ -1507,7 +1507,7 @@ module Array = struct let name = Printf.sprintf "from_%i_tuple" n in let retty = Lib.List.make n I32Type in Func.share_code env name ["tup", I32Type] retty (fun env -> - let get_tup = G.i (GetLocal (nr 0l)) in + let get_tup = G.i (LocalGet (nr 0l)) in G.table n (fun i -> get_tup ^^ load_n (Int32.of_int i)) ) @@ -1648,7 +1648,7 @@ module Dfinity = struct let compile_databuf_of_text env = Func.share_code env "databuf_of_text" ["string", I32Type] [I32Type] (fun env -> - let get_i = G.i (GetLocal (nr 0l)) in + let get_i = G.i (LocalGet (nr 0l)) in (* Calculate the offset *) get_i ^^ @@ -1721,7 +1721,7 @@ module Dfinity = struct let box_reference env = Func.share_code env "box_reference" ["ref", I32Type] [I32Type] (fun env -> - let get_ref = G.i (GetLocal (nr 0l)) in + let get_ref = G.i (LocalGet (nr 0l)) in Tagged.obj env Tagged.Reference [ get_ref ^^ ElemHeap.remember_reference env @@ -1772,7 +1772,7 @@ module OrthogonalPersistence = struct Func.define_built_in env "restore_mem" [] [] (fun env1 -> let (set_i, get_i) = new_local env1 "len" in - G.i (GetGlobal (nr mem_global)) ^^ + G.i (GlobalGet (nr mem_global)) ^^ G.i (Call (nr (Dfinity.data_length_i env1))) ^^ set_i ^^ @@ -1787,24 +1787,24 @@ module OrthogonalPersistence = struct ( (* Set heap pointer based on databuf length *) get_i ^^ compile_add_const ElemHeap.table_end ^^ - G.i (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalSet (nr Heap.heap_ptr)) ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ get_i ^^ - G.i (GetGlobal (nr mem_global)) ^^ + G.i (GlobalGet (nr mem_global)) ^^ compile_unboxed_zero ^^ G.i (Call (nr (Dfinity.data_internalize_i env1))) ^^ (* Load reference counter *) - G.i (GetGlobal (nr elem_global)) ^^ + G.i (GlobalGet (nr elem_global)) ^^ G.i (Call (nr (Dfinity.elem_length_i env1))) ^^ - G.i (SetGlobal (nr ElemHeap.ref_counter)) ^^ + G.i (GlobalSet (nr ElemHeap.ref_counter)) ^^ (* Load references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i (GetGlobal (nr ElemHeap.ref_counter)) ^^ - G.i (GetGlobal (nr elem_global)) ^^ + G.i (GlobalGet (nr ElemHeap.ref_counter)) ^^ + G.i (GlobalGet (nr elem_global)) ^^ compile_unboxed_zero ^^ G.i (Call (nr (Dfinity.elem_internalize_i env1))) ) @@ -1812,17 +1812,17 @@ module OrthogonalPersistence = struct Func.define_built_in env "save_mem" [] [] (fun env1 -> (* Store memory *) compile_unboxed_const ElemHeap.table_end ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ compile_unboxed_const ElemHeap.table_end ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ - G.i (SetGlobal (nr mem_global)) ^^ + G.i (GlobalSet (nr mem_global)) ^^ (* Store references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i (GetGlobal (nr ElemHeap.ref_counter)) ^^ + G.i (GlobalGet (nr ElemHeap.ref_counter)) ^^ G.i (Call (nr (Dfinity.elem_externalize_i env))) ^^ - G.i (SetGlobal (nr elem_global)) + G.i (GlobalSet (nr elem_global)) ) let save_mem env = G.i (Call (nr (E.built_in env "save_mem"))) @@ -1864,10 +1864,10 @@ module Serialization = struct let serialize_go env = Func.share_code env "serialize_go" ["x", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in + let get_x = G.i (LocalGet (nr 0l)) in let (set_copy, get_copy) = new_local env "x" in - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_copy ^^ get_x ^^ @@ -2025,8 +2025,8 @@ module Serialization = struct let shift_pointer_at env = Func.share_code env "shift_pointer_at" ["loc", I32Type; "ptr_offset", I32Type] [] (fun env -> - let get_loc = G.i (GetLocal (nr 0l)) in - let get_ptr_offset = G.i (GetLocal (nr 1l)) in + let get_loc = G.i (LocalGet (nr 0l)) in + let get_ptr_offset = G.i (LocalGet (nr 1l)) in let (set_ptr, get_ptr) = new_local env "ptr" in get_loc ^^ load_ptr ^^ @@ -2046,7 +2046,7 @@ module Serialization = struct (* Returns the object size (in bytes) *) let object_size env = Func.share_code env "object_size" ["x", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in + let get_x = G.i (LocalGet (nr 0l)) in get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, @@ -2166,9 +2166,9 @@ module Serialization = struct let shift_pointers env = Func.share_code env "shift_pointers" ["start", I32Type; "to", I32Type; "ptr_offset", I32Type] [] (fun env -> - let get_start = G.i (GetLocal (nr 0l)) in - let get_to = G.i (GetLocal (nr 1l)) in - let get_ptr_offset = G.i (GetLocal (nr 2l)) in + let get_start = G.i (LocalGet (nr 0l)) in + let get_to = G.i (LocalGet (nr 1l)) in + let get_ptr_offset = G.i (LocalGet (nr 2l)) in walk_heap_from_to env get_start get_to (fun get_x -> for_each_pointer env get_x (fun get_ptr_loc -> @@ -2181,9 +2181,9 @@ module Serialization = struct let extract_references env = Func.share_code env "extract_references" ["start", I32Type; "to", I32Type; "tbl_area", I32Type] [I32Type] (fun env -> - let get_start = G.i (GetLocal (nr 0l)) in - let get_to = G.i (GetLocal (nr 1l)) in - let get_tbl_area = G.i (GetLocal (nr 2l)) in + let get_start = G.i (LocalGet (nr 0l)) in + let get_to = G.i (LocalGet (nr 1l)) in + let get_tbl_area = G.i (LocalGet (nr 2l)) in let (set_i, get_i) = new_local env "i" in compile_unboxed_const 0l ^^ set_i ^^ @@ -2214,9 +2214,9 @@ module Serialization = struct let intract_references env = Func.share_code env "intract_references" ["start", I32Type; "to", I32Type; "tbl_area", I32Type] [] (fun env -> - let get_start = G.i (GetLocal (nr 0l)) in - let get_to = G.i (GetLocal (nr 1l)) in - let get_tbl_area = G.i (GetLocal (nr 2l)) in + let get_start = G.i (LocalGet (nr 0l)) in + let get_to = G.i (LocalGet (nr 1l)) in + let get_tbl_area = G.i (LocalGet (nr 2l)) in walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ @@ -2240,7 +2240,7 @@ module Serialization = struct if E.mode env <> DfinityMode then Func.share_code env "serialize" ["x", I32Type] [I32Type] (fun env -> G.i Unreachable) else Func.share_code env "serialize" ["x", I32Type] [I32Type] (fun env -> - let get_x = G.i (GetLocal (nr 0l)) in + let get_x = G.i (LocalGet (nr 0l)) in let (set_start, get_start) = new_local env "old_heap" in let (set_end, get_end) = new_local env "end" in @@ -2248,7 +2248,7 @@ module Serialization = struct let (set_databuf, get_databuf) = new_local env "databuf" in (* Remember where we start to copy to *) - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_start ^^ (* Copy data *) @@ -2262,7 +2262,7 @@ module Serialization = struct store_ptr ^^ (* Remember the end *) - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_end ^^ (* Empty table of references *) @@ -2274,7 +2274,7 @@ module Serialization = struct G.i Drop ^^ (* Remember the end *) - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_end ^^ (* Adjust pointers *) @@ -2308,7 +2308,7 @@ module Serialization = struct (* Reset the heap counter, to free some space *) get_start ^^ - G.i (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalSet (nr Heap.heap_ptr)) ^^ (* Finally, create elembuf *) get_end ^^ @@ -2325,20 +2325,20 @@ module Serialization = struct let retty = Lib.List.make n I32Type in Func.share_code env name args retty (fun env -> G.table n (fun i -> - G.i (GetLocal (nr (Int32.of_int i))) ^^ serialize env + G.i (LocalGet (nr (Int32.of_int i))) ^^ serialize env ) ) let deserialize env = Func.share_code env "deserialize" ["ref", I32Type] [I32Type] (fun env -> - let get_elembuf = G.i (GetLocal (nr 0l)) in + let get_elembuf = G.i (LocalGet (nr 0l)) in let (set_databuf, get_databuf) = new_local env "databuf" in let (set_start, get_start) = new_local env "start" in let (set_data_len, get_data_len) = new_local env "data_len" in let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in (* new positions *) - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_start ^^ get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ @@ -2375,16 +2375,16 @@ module Serialization = struct get_start ^^ get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (SetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalSet (nr Heap.heap_ptr)) ^^ (* Fix pointers *) get_start ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ get_start ^^ shift_pointers env ^^ (* Load references *) - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ get_tbl_size ^^ compile_sub_const 1l ^^ get_elembuf ^^ compile_unboxed_const 0l ^^ @@ -2393,8 +2393,8 @@ module Serialization = struct (* Fix references *) (* Extract references *) get_start ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ intract_references env ^^ (* return allocated thing *) @@ -2423,10 +2423,10 @@ module GC = struct the object will be finally. *) (* Invariant: Must not be called on the same pointer twice. *) let evacuate env = Func.share_code env "evaucate" ["begin_from_space", I32Type; "begin_to_space", I32Type; "end_to_space", I32Type; "ptr_loc", I32Type] [I32Type] (fun env -> - let get_begin_from_space = G.i (GetLocal (nr 0l)) in - let get_begin_to_space = G.i (GetLocal (nr 1l)) in - let get_end_to_space = G.i (GetLocal (nr 2l)) in - let get_ptr_loc = G.i (GetLocal (nr 3l)) in + let get_begin_from_space = G.i (LocalGet (nr 0l)) in + let get_begin_to_space = G.i (LocalGet (nr 1l)) in + let get_end_to_space = G.i (LocalGet (nr 2l)) in + let get_ptr_loc = G.i (LocalGet (nr 3l)) in let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2493,8 +2493,8 @@ module GC = struct let (set_end_to_space, get_end_to_space) = new_local env "end_to_space" in compile_unboxed_const end_of_static_space ^^ set_begin_from_space ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_begin_to_space ^^ - G.i (GetGlobal (nr Heap.heap_ptr)) ^^ set_end_to_space ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_begin_to_space ^^ + G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_end_to_space ^^ (* Common arguments for evalcuate *) @@ -2537,7 +2537,7 @@ module GC = struct get_begin_from_space ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (SetGlobal (nr Heap.heap_ptr)) + G.i (GlobalSet (nr Heap.heap_ptr)) ) @@ -2567,7 +2567,7 @@ module FuncDec = struct let export_self_message env = Func.share_code env "export_self_message" ["name", I32Type] [I32Type] (fun env -> - let get_name = G.i (GetLocal (nr 0l)) in + let get_name = G.i (LocalGet (nr 0l)) in Tagged.obj env Tagged.Reference [ (* Create a funcref for the message *) @@ -2589,7 +2589,7 @@ module FuncDec = struct let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in let retty = Lib.List.make cc.Value.n_res I32Type in Func.of_body env (["clos", I32Type] @ args) retty (fun env1 -> G.with_region at ( - let get_closure = G.i (GetLocal (E.unary_closure_local env1)) in + let get_closure = G.i (LocalGet (E.unary_closure_local env1)) in let (env2, closure_code) = restore_env env1 get_closure in @@ -2598,7 +2598,7 @@ module FuncDec = struct closure_code ^^ alloc_args_code ^^ - let get i = G.i (GetLocal (nr (Int32.(add 1l (of_int i))))) in + let get i = G.i (LocalGet (nr (Int32.(add 1l (of_int i))))) in destruct_args_code get ^^ mk_body env3 )) @@ -2620,7 +2620,7 @@ module FuncDec = struct (* Look up closure *) let (set_closure, get_closure) = new_local env1 "closure" in - G.i (GetLocal (nr 0l)) ^^ + G.i (LocalGet (nr 0l)) ^^ ClosureTable.recall_closure env1 ^^ set_closure ^^ @@ -2632,7 +2632,7 @@ module FuncDec = struct closure_code ^^ alloc_args_code ^^ let get i = - G.i (GetLocal (nr (Int32.(add 1l (of_int i))))) ^^ + G.i (LocalGet (nr (Int32.(add 1l (of_int i))))) ^^ Serialization.deserialize env in destruct_args_code get ^^ mk_body env3 ^^ @@ -2660,7 +2660,7 @@ module FuncDec = struct alloc_args_code ^^ let get i = - G.i (GetLocal (nr (Int32.(add 0l (of_int i))))) ^^ + G.i (LocalGet (nr (Int32.(add 0l (of_int i))))) ^^ Serialization.deserialize env in destruct_args_code get ^^ mk_body env2 ^^ @@ -2735,7 +2735,7 @@ module FuncDec = struct let f = compile_message env cc restore_env mk_pat mk_body at in let fi = E.add_fun env f name.it in E.add_dfinity_type env (fi, - Wasm_copy.CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) + CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) ); fi in @@ -2974,7 +2974,7 @@ let compile_unop env t op = Syntax.(match op with | NegOp -> StackRep.UnboxedInt, Func.share_code env "neg" ["n", I64Type] [I64Type] (fun env -> - let get_n = G.i (GetLocal (nr 0l)) in + let get_n = G.i (LocalGet (nr 0l)) in compile_const_64 0L ^^ get_n ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub)) @@ -2995,8 +2995,8 @@ let compile_binop env t op = | Type.Prim Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) | Type.Prim Type.Nat, SubOp -> Func.share_code env "nat_sub" ["n1", I64Type; "n2", I64Type] [I64Type] (fun env -> - let get_n1 = G.i (GetLocal (nr 0l)) in - let get_n2 = G.i (GetLocal (nr 1l)) in + let get_n1 = G.i (LocalGet (nr 0l)) in + let get_n2 = G.i (LocalGet (nr 1l)) in get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ G.if_ (StackRep.to_block_type env StackRep.UnboxedInt) (G.i Unreachable) @@ -3344,7 +3344,7 @@ and compile_exp (env : E.t) exp = let sr, code = compile_exp env1 e in sr, Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ - G.i (SetLocal (nr i)) ^^ + G.i (LocalSet (nr i)) ^^ code | DefineE (name, _, e) -> StackRep.unit, @@ -3660,7 +3660,7 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = in find_func f.it.exp in let (fi, fill) = E.reserve_fun pre_env name.it in - E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args Wasm_copy.CustomSections.ElemBuf); + E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args CustomSections.ElemBuf); E.add_export pre_env (nr { name = Dfinity.explode name.it; edesc = nr (FuncExport (nr fi)) @@ -3716,7 +3716,7 @@ and actor_lit outer_env name fs at = OrthogonalPersistence.register env start_fi; let m = conclude_module env name.it None in - let (_map, wasm_binary) = Wasm_copy.CustomModule.encode m in + let (_map, wasm_binary) = CustomModule.encode m in wasm_binary in Dfinity.compile_databuf_of_bytes outer_env wasm_binary ^^ @@ -3774,7 +3774,7 @@ and conclude_module env module_name start_fi_o = { module_ = nr { types = List.map nr (E.get_types env); funcs = List.map (fun (f,_,_) -> f) funcs; - tables = [ nr { ttype = TableType ({min = table_sz; max = Some table_sz}, AnyFuncType) } ]; + tables = [ nr { ttype = TableType ({min = table_sz; max = Some table_sz}, FuncRefType) } ]; elems = [ nr { index = nr 0l; offset = nr (G.to_instr_list (compile_unboxed_const ni')); @@ -3788,8 +3788,8 @@ and conclude_module env module_name start_fi_o = }; types = E.get_dfinity_types env; persist = - [ (OrthogonalPersistence.mem_global, Wasm_copy.CustomSections.DataBuf) - ; (OrthogonalPersistence.elem_global, Wasm_copy.CustomSections.ElemBuf) + [ (OrthogonalPersistence.mem_global, CustomSections.DataBuf) + ; (OrthogonalPersistence.elem_global, CustomSections.ElemBuf) ]; module_name; function_names = diff --git a/src/compile.mli b/src/compile.mli index 6a70b9a080d..ce0789f661e 100644 --- a/src/compile.mli +++ b/src/compile.mli @@ -1,3 +1,3 @@ type mode = WasmMode | DfinityMode -val compile : mode -> string -> Ir.prog -> Ir.prog list -> Wasm_copy.CustomModule.extended_module +val compile : mode -> string -> Ir.prog -> Ir.prog list -> CustomModule.extended_module diff --git a/src/wasm_copy/customModule.ml b/src/customModule.ml similarity index 98% rename from src/wasm_copy/customModule.ml rename to src/customModule.ml index 93911284737..313b91d960d 100644 --- a/src/wasm_copy/customModule.ml +++ b/src/customModule.ml @@ -3,7 +3,7 @@ *) open Wasm.Source -open Ast +open Wasm.Ast type extended_module = { (* The non-custom sections *) diff --git a/src/wasm_copy/customSections.ml b/src/customSections.ml similarity index 100% rename from src/wasm_copy/customSections.ml rename to src/customSections.ml diff --git a/src/wasm_copy/encodeMap.ml b/src/encodeMap.ml similarity index 98% rename from src/wasm_copy/encodeMap.ml rename to src/encodeMap.ml index 78064409842..565f199eb67 100644 --- a/src/wasm_copy/encodeMap.ml +++ b/src/encodeMap.ml @@ -129,7 +129,7 @@ let encode m = (* Types *) - open Types + open Wasm.Types let value_type = function | I32Type -> vs7 (-0x01) @@ -138,7 +138,7 @@ let encode m = | F64Type -> vs7 (-0x04) let elem_type = function - | AnyFuncType -> vs7 (-0x10) + | FuncRefType -> vs7 (-0x10) let stack_type = vec value_type let func_type = function @@ -163,7 +163,7 @@ let encode m = (* Expressions *) open Wasm.Source - open Ast + open Wasm.Ast open Wasm.Values open Wasm.Memory @@ -203,11 +203,11 @@ let encode m = | Drop -> op 0x1a | Select -> op 0x1b - | GetLocal x -> op 0x20; var x - | SetLocal x -> op 0x21; var x - | TeeLocal x -> op 0x22; var x - | GetGlobal x -> op 0x23; var x - | SetGlobal x -> op 0x24; var x + | LocalGet x -> op 0x20; var x + | LocalSet x -> op 0x21; var x + | LocalTee x -> op 0x22; var x + | GlobalGet x -> op 0x23; var x + | GlobalSet x -> op 0x24; var x | Load ({ty = I32Type; sz = None; _} as mo) -> op 0x28; memop mo | Load ({ty = I64Type; sz = None; _} as mo) -> op 0x29; memop mo diff --git a/src/instrList.ml b/src/instrList.ml index 28e5322bbad..d45e87863f4 100644 --- a/src/instrList.ml +++ b/src/instrList.ml @@ -7,7 +7,7 @@ features are * Some simple peephole optimizations. *) -open Wasm_copy.Ast +open Wasm.Ast open Wasm.Source (* Some simple peephole optimizations, to make the output code look less stupid *) @@ -16,16 +16,16 @@ let optimize : instr list -> instr list = fun is -> let rec go l r = match l, r with (* Loading and dropping is pointless *) | { it = Const _; _} :: l', { it = Drop; _ } :: r' -> go l' r' - | { it = GetLocal _; _} :: l', { it = Drop; _ } :: r' -> go l' r' + | { it = LocalGet _; _} :: l', { it = Drop; _ } :: r' -> go l' r' (* The following is not semantics preserving for general Wasm (due to out-of-memory) but should be fine for the code that we create *) | { it = Load _; _} :: l', { it = Drop; _ } :: _ -> go l' r (* Introduce TeeLocal *) - | { it = SetLocal n1; _} :: l', ({ it = GetLocal n2; _ } as i) :: r' when n1 = n2 -> - go l' ({i with it = TeeLocal n2 } :: r') - (* Eliminate TeeLocal followed by Drop (good for confluence) *) - | ({ it = TeeLocal n; _} as i) :: l', { it = Drop; _ } :: r' -> - go l' ({i with it = SetLocal n } :: r') + | { it = LocalSet n1; _} :: l', ({ it = LocalGet n2; _ } as i) :: r' when n1 = n2 -> + go l' ({i with it = LocalTee n2 } :: r') + (* Eliminate LocalTee followed by Drop (good for confluence) *) + | ({ it = LocalTee n; _} as i) :: l', { it = Drop; _ } :: r' -> + go l' ({i with it = LocalSet n } :: r') (* Code after Return, Br or Unreachable is dead *) | _, ({ it = Return | Br _ | Unreachable; _ } as i) :: _ -> List.rev (i::l) diff --git a/src/js_main.ml b/src/js_main.ml index 34b2709c183..d76f2878645 100644 --- a/src/js_main.ml +++ b/src/js_main.ml @@ -57,7 +57,7 @@ let js_compile_with mode_string source_map source convert = let js_compile_wasm mode source_map s = js_compile_with mode source_map s - (fun m -> let (map, wasm) = Wasm_copy.CustomModule.encode m in Js.bytestring wasm, Js.string map) + (fun m -> let (map, wasm) = CustomModule.encode m in Js.bytestring wasm, Js.string map) let () = Js.export "ActorScript" diff --git a/src/main.ml b/src/main.ml index df0dffbab81..46894bdd5b0 100644 --- a/src/main.ml +++ b/src/main.ml @@ -82,7 +82,7 @@ let process_files files : unit = let module_name = Filename.remove_extension (Filename.basename !out_file) in let module_ = exit_on_failure Pipeline.(compile_files !compile_mode files module_name) in let oc = open_out !out_file in - let (source_map, wasm) = Wasm_copy.CustomModule.encode module_ in + let (source_map, wasm) = CustomModule.encode module_ in output_string oc wasm; close_out oc; if !Flags.source_map then begin diff --git a/src/pipeline.ml b/src/pipeline.ml index 92a4627bab3..c28dd9990c1 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -279,7 +279,7 @@ let run_files env = function (* Compilation *) type compile_mode = Compile.mode = WasmMode | DfinityMode -type compile_result = (Wasm_copy.CustomModule.extended_module, Diag.messages) result +type compile_result = (CustomModule.extended_module, Diag.messages) result let compile_with check mode name : compile_result = match check initial_stat_env name with diff --git a/src/pipeline.mli b/src/pipeline.mli index 1f000eade22..92677d228fe 100644 --- a/src/pipeline.mli +++ b/src/pipeline.mli @@ -33,7 +33,7 @@ val run_lexer : env -> Lexing.lexbuf -> string -> run_result val run_stdin : env -> unit type compile_mode = WasmMode | DfinityMode -type compile_result = (Wasm_copy.CustomModule.extended_module, Diag.messages) result +type compile_result = (CustomModule.extended_module, Diag.messages) result val compile_file : compile_mode -> string -> string -> compile_result val compile_files : compile_mode -> string list -> string -> compile_result val compile_string : compile_mode -> string -> string -> compile_result diff --git a/src/wasm_copy.mlpack b/src/wasm_copy.mlpack deleted file mode 100644 index 27e55b51f7a..00000000000 --- a/src/wasm_copy.mlpack +++ /dev/null @@ -1,5 +0,0 @@ -wasm_copy/Types -wasm_copy/Ast -wasm_copy/CustomModule -wasm_copy/CustomSections -wasm_copy/EncodeMap diff --git a/src/wasm_copy/ast.ml b/src/wasm_copy/ast.ml deleted file mode 100644 index bd3c279f5af..00000000000 --- a/src/wasm_copy/ast.ml +++ /dev/null @@ -1,259 +0,0 @@ -(* - * Throughout the implementation we use consistent naming conventions for - * syntactic elements, associated with the types defined here and in a few - * other places: - * - * x : var - * v : value - * e : instrr - * f : func - * m : module_ - * - * t : value_type - * s : func_type - * c : context / config - * - * These conventions mostly follow standard practice in language semantics. - *) - -open Types - - -(* Operators *) - -module IntOp = -struct - type unop = Clz | Ctz | Popcnt - type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU - | And | Or | Xor | Shl | ShrS | ShrU | Rotl | Rotr - type testop = Eqz - type relop = Eq | Ne | LtS | LtU | GtS | GtU | LeS | LeU | GeS | GeU - type cvtop = ExtendSI32 | ExtendUI32 | WrapI64 - | TruncSF32 | TruncUF32 | TruncSF64 | TruncUF64 - | ReinterpretFloat -end - -module FloatOp = -struct - type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt - type binop = Add | Sub | Mul | Div | Min | Max | CopySign - type testop - type relop = Eq | Ne | Lt | Gt | Le | Ge - type cvtop = ConvertSI32 | ConvertUI32 | ConvertSI64 | ConvertUI64 - | PromoteF32 | DemoteF64 - | ReinterpretInt -end - -module I32Op = IntOp -module I64Op = IntOp -module F32Op = FloatOp -module F64Op = FloatOp - -type unop = (I32Op.unop, I64Op.unop, F32Op.unop, F64Op.unop) Wasm.Values.op -type binop = (I32Op.binop, I64Op.binop, F32Op.binop, F64Op.binop) Wasm.Values.op -type testop = (I32Op.testop, I64Op.testop, F32Op.testop, F64Op.testop) Wasm.Values.op -type relop = (I32Op.relop, I64Op.relop, F32Op.relop, F64Op.relop) Wasm.Values.op -type cvtop = (I32Op.cvtop, I64Op.cvtop, F32Op.cvtop, F64Op.cvtop) Wasm.Values.op - -type 'a memop = - {ty : value_type; align : int; offset : Wasm.Memory.offset; sz : 'a option} -type loadop = (Wasm.Memory.pack_size * Wasm.Memory.extension) memop -type storeop = Wasm.Memory.pack_size memop - - -(* Expressions *) - -type var = int32 Wasm.Source.phrase -type literal = Wasm.Values.value Wasm.Source.phrase -type name = int list - -type block_type = VarBlockType of var | ValBlockType of value_type option - -type instr = instr' Wasm.Source.phrase -and instr' = - | Unreachable (* trap unconditionally *) - | Nop (* do nothing *) - | Drop (* forget a value *) - | Select (* branchless conditional *) - | Block of block_type * instr list (* execute in sequence *) - | Loop of block_type * instr list (* loop header *) - | If of block_type * instr list * instr list (* conditional *) - | Br of var (* break to n-th surrounding label *) - | BrIf of var (* conditional break *) - | BrTable of var list * var (* indexed break *) - | Return (* break from function body *) - | Call of var (* call function *) - | CallIndirect of var (* call function through table *) - | GetLocal of var (* read local variable *) - | SetLocal of var (* write local variable *) - | TeeLocal of var (* write local variable and keep value *) - | GetGlobal of var (* read global variable *) - | SetGlobal of var (* write global variable *) - | Load of loadop (* read memory at address *) - | Store of storeop (* write memory at address *) - | MemorySize (* size of linear memory *) - | MemoryGrow (* grow linear memory *) - | Const of literal (* constant *) - | Test of testop (* numeric test *) - | Compare of relop (* numeric comparison *) - | Unary of unop (* unary numeric operator *) - | Binary of binop (* binary numeric operator *) - | Convert of cvtop (* conversion *) - - -(* Globals & Functions *) - -type const = instr list Wasm.Source.phrase - -type global = global' Wasm.Source.phrase -and global' = -{ - gtype : global_type; - value : const; -} - -type func = func' Wasm.Source.phrase -and func' = -{ - ftype : var; - locals : value_type list; - body : instr list; -} - - -(* Tables & Memories *) - -type table = table' Wasm.Source.phrase -and table' = -{ - ttype : table_type; -} - -type memory = memory' Wasm.Source.phrase -and memory' = -{ - mtype : memory_type; -} - -type 'data segment = 'data segment' Wasm.Source.phrase -and 'data segment' = -{ - index : var; - offset : const; - init : 'data; -} - -type table_segment = var list segment -type memory_segment = string segment - - -(* Modules *) - -type type_ = func_type Wasm.Source.phrase - -type export_desc = export_desc' Wasm.Source.phrase -and export_desc' = - | FuncExport of var - | TableExport of var - | MemoryExport of var - | GlobalExport of var - -type export = export' Wasm.Source.phrase -and export' = -{ - name : name; - edesc : export_desc; -} - -type import_desc = import_desc' Wasm.Source.phrase -and import_desc' = - | FuncImport of var - | TableImport of table_type - | MemoryImport of memory_type - | GlobalImport of global_type - -type import = import' Wasm.Source.phrase -and import' = -{ - module_name : name; - item_name : name; - idesc : import_desc; -} - -type module_ = module_' Wasm.Source.phrase -and module_' = -{ - types : type_ list; - globals : global list; - tables : table list; - memories : memory list; - funcs : func list; - start : var option; - elems : var list segment list; - data : string segment list; - imports : import list; - exports : export list; -} - - -(* Auxiliary functions *) - -let empty_module = -{ - types = []; - globals = []; - tables = []; - memories = []; - funcs = []; - start = None; - elems = []; - data = []; - imports = []; - exports = []; -} - -open Wasm.Source - -let func_type_for (m : module_) (x : var) : func_type = - (Lib.List32.nth m.it.types x.it).it - -let import_type (m : module_) (im : import) : extern_type = - let {idesc; _} = im.it in - match idesc.it with - | FuncImport x -> ExternFuncType (func_type_for m x) - | TableImport t -> ExternTableType t - | MemoryImport t -> ExternMemoryType t - | GlobalImport t -> ExternGlobalType t - -let export_type (m : module_) (ex : export) : extern_type = - let {edesc; _} = ex.it in - let its = List.map (import_type m) m.it.imports in - let open Lib.List32 in - match edesc.it with - | FuncExport x -> - let fts = - funcs its @ List.map (fun f -> func_type_for m f.it.ftype) m.it.funcs - in ExternFuncType (nth fts x.it) - | TableExport x -> - let tts = tables its @ List.map (fun t -> t.it.ttype) m.it.tables in - ExternTableType (nth tts x.it) - | MemoryExport x -> - let mts = memories its @ List.map (fun m -> m.it.mtype) m.it.memories in - ExternMemoryType (nth mts x.it) - | GlobalExport x -> - let gts = globals its @ List.map (fun g -> g.it.gtype) m.it.globals in - ExternGlobalType (nth gts x.it) - -let string_of_name n = - let b = Buffer.create 16 in - let escape uc = - if uc < 0x20 || uc >= 0x7f then - Buffer.add_string b (Printf.sprintf "\\u{%02x}" uc) - else begin - let c = Char.chr uc in - if c = '\"' || c = '\\' then Buffer.add_char b '\\'; - Buffer.add_char b c - end - in - List.iter escape n; - Buffer.contents b diff --git a/src/wasm_copy/types.ml b/src/wasm_copy/types.ml deleted file mode 100644 index 5a6c0ea762c..00000000000 --- a/src/wasm_copy/types.ml +++ /dev/null @@ -1,108 +0,0 @@ -(* Types *) - -type value_type = I32Type | I64Type | F32Type | F64Type -type elem_type = AnyFuncType -type stack_type = value_type list -type func_type = FuncType of stack_type * stack_type - -type 'a limits = {min : 'a; max : 'a option} -type mutability = Immutable | Mutable -type table_type = TableType of Int32.t limits * elem_type -type memory_type = MemoryType of Int32.t limits -type global_type = GlobalType of value_type * mutability -type extern_type = - | ExternFuncType of func_type - | ExternTableType of table_type - | ExternMemoryType of memory_type - | ExternGlobalType of global_type - - -(* Attributes *) - -let size = function - | I32Type | F32Type -> 4 - | I64Type | F64Type -> 8 - - -(* Subtyping *) - -let match_limits lim1 lim2 = - Wasm.I32.ge_u lim1.min lim2.min && - match lim1.max, lim2.max with - | _, None -> true - | None, Some _ -> false - | Some i, Some j -> Wasm.I32.le_u i j - -let match_func_type ft1 ft2 = - ft1 = ft2 - -let match_table_type (TableType (lim1, et1)) (TableType (lim2, et2)) = - et1 = et2 && match_limits lim1 lim2 - -let match_memory_type (MemoryType lim1) (MemoryType lim2) = - match_limits lim1 lim2 - -let match_global_type gt1 gt2 = - gt1 = gt2 - -let match_extern_type et1 et2 = - match et1, et2 with - | ExternFuncType ft1, ExternFuncType ft2 -> match_func_type ft1 ft2 - | ExternTableType tt1, ExternTableType tt2 -> match_table_type tt1 tt2 - | ExternMemoryType mt1, ExternMemoryType mt2 -> match_memory_type mt1 mt2 - | ExternGlobalType gt1, ExternGlobalType gt2 -> match_global_type gt1 gt2 - | _, _ -> false - - -(* Filters *) - -let funcs = - Lib.List.map_filter (function ExternFuncType t -> Some t | _ -> None) -let tables = - Lib.List.map_filter (function ExternTableType t -> Some t | _ -> None) -let memories = - Lib.List.map_filter (function ExternMemoryType t -> Some t | _ -> None) -let globals = - Lib.List.map_filter (function ExternGlobalType t -> Some t | _ -> None) - - -(* String conversion *) - -let string_of_value_type = function - | I32Type -> "i32" - | I64Type -> "i64" - | F32Type -> "f32" - | F64Type -> "f64" - -let string_of_value_types = function - | [t] -> string_of_value_type t - | ts -> "[" ^ String.concat " " (List.map string_of_value_type ts) ^ "]" - -let string_of_elem_type = function - | AnyFuncType -> "anyfunc" - -let string_of_limits {min; max} = - Wasm.I32.to_string_u min ^ - (match max with None -> "" | Some n -> " " ^ Wasm.I32.to_string_u n) - -let string_of_memory_type = function - | MemoryType lim -> string_of_limits lim - -let string_of_table_type = function - | TableType (lim, t) -> string_of_limits lim ^ " " ^ string_of_elem_type t - -let string_of_global_type = function - | GlobalType (t, Immutable) -> string_of_value_type t - | GlobalType (t, Mutable) -> "(mut " ^ string_of_value_type t ^ ")" - -let string_of_stack_type ts = - "[" ^ String.concat " " (List.map string_of_value_type ts) ^ "]" - -let string_of_func_type (FuncType (ins, out)) = - string_of_stack_type ins ^ " -> " ^ string_of_stack_type out - -let string_of_extern_type = function - | ExternFuncType ft -> "func " ^ string_of_func_type ft - | ExternTableType tt -> "table " ^ string_of_table_type tt - | ExternMemoryType mt -> "memory " ^ string_of_memory_type mt - | ExternGlobalType gt -> "global " ^ string_of_global_type gt From 34bcf4424f91f1289fed60fca9544b33de0b7501 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Tue, 8 Jan 2019 15:30:51 +0100 Subject: [PATCH 39/41] Revert "Use wasm-interp in the test suite" This reverts commit a6a8008201c9e46f6b3ca52802753ab825ab46f7. --- README.md | 5 +++-- default.nix | 2 +- test/fail/ok/use-before-define.wasm-run.ok | 2 +- test/fail/ok/use-before-define2.wasm-run.ok | 2 +- test/run.sh | 2 +- test/run/ok/actors.wasm-run.ok | 2 +- test/run/ok/array-bounds.wasm-run.ok | 2 +- test/run/ok/assertFalse.wasm-run.ok | 2 +- test/run/ok/async-calls.wasm-run.ok | 2 +- test/run/ok/asyncreturn.wasm-run.ok | 2 +- test/run/ok/await.wasm-run.ok | 2 +- test/run/ok/bank-example.wasm-run.ok | 2 +- test/run/ok/block.wasm-run.ok | 2 +- test/run/ok/for.wasm-run.ok | 2 +- test/run/ok/is.wasm-run.ok | 2 +- test/run/ok/literals.wasm-run.ok | 2 +- test/run/ok/overflow.wasm-run.ok | 2 +- 17 files changed, 19 insertions(+), 18 deletions(-) diff --git a/README.md b/README.md index 128109e3fff..fa7cb49f895 100644 --- a/README.md +++ b/README.md @@ -48,10 +48,11 @@ To build `asc.js`, the JavaScript library, use nix-build -A js ``` -If you want to install `wabt` and `dvm` binaries with Nix, run +If you want to install `wasm` and `dvm` binaries with nix (for example because +you maintain your Ocaml installation manually), run ``` -nix-env -i -f . -A wabt +nix-env -i -f . -A wasm nix-env -i -f . -A dvm ``` To update the `dev` checkout and install `dvm` in one go, run `./update-dvm.sh`. diff --git a/default.nix b/default.nix index 4457ba47e04..854ae3832a5 100644 --- a/default.nix +++ b/default.nix @@ -101,6 +101,7 @@ rec { buildInputs = [ native + ocaml_wasm nixpkgs.wabt nixpkgs.bash nixpkgs.perl @@ -197,7 +198,6 @@ rec { }); - wabt = nixpkgs.wabt; wasm = ocaml_wasm; dvm = real-dvm; } diff --git a/test/fail/ok/use-before-define.wasm-run.ok b/test/fail/ok/use-before-define.wasm-run.ok index 286b4068a22..0832a4ae813 100644 --- a/test/fail/ok/use-before-define.wasm-run.ok +++ b/test/fail/ok/use-before-define.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/use-before-define.wasm:0x___: runtime trap: unreachable executed diff --git a/test/fail/ok/use-before-define2.wasm-run.ok b/test/fail/ok/use-before-define2.wasm-run.ok index 286b4068a22..042955b9259 100644 --- a/test/fail/ok/use-before-define2.wasm-run.ok +++ b/test/fail/ok/use-before-define2.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/use-before-define2.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run.sh b/test/run.sh index 7811ee62231..667171b4224 100755 --- a/test/run.sh +++ b/test/run.sh @@ -19,7 +19,7 @@ ACCEPT=no DFINITY=no EXTRA_ASC_FLAGS= ASC=${ASC:-$(realpath $(dirname $0)/../src/asc)} -WASM=${WASM:-wasm-interp --enable-multi-value} +WASM=${WASM:-wasm} DVM_WRAPPER=$(realpath $(dirname $0)/dvm.sh) while getopts "ad" o; do diff --git a/test/run/ok/actors.wasm-run.ok b/test/run/ok/actors.wasm-run.ok index 286b4068a22..fd492e3b4f5 100644 --- a/test/run/ok/actors.wasm-run.ok +++ b/test/run/ok/actors.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/actors.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/array-bounds.wasm-run.ok b/test/run/ok/array-bounds.wasm-run.ok index 286b4068a22..988f0569732 100644 --- a/test/run/ok/array-bounds.wasm-run.ok +++ b/test/run/ok/array-bounds.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/array-bounds.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/assertFalse.wasm-run.ok b/test/run/ok/assertFalse.wasm-run.ok index 286b4068a22..e03ec0ea09e 100644 --- a/test/run/ok/assertFalse.wasm-run.ok +++ b/test/run/ok/assertFalse.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/assertFalse.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/async-calls.wasm-run.ok b/test/run/ok/async-calls.wasm-run.ok index 286b4068a22..8fca2e68476 100644 --- a/test/run/ok/async-calls.wasm-run.ok +++ b/test/run/ok/async-calls.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/async-calls.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/asyncreturn.wasm-run.ok b/test/run/ok/asyncreturn.wasm-run.ok index 286b4068a22..0b80fcc95f3 100644 --- a/test/run/ok/asyncreturn.wasm-run.ok +++ b/test/run/ok/asyncreturn.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/asyncreturn.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/await.wasm-run.ok b/test/run/ok/await.wasm-run.ok index 286b4068a22..da185acef49 100644 --- a/test/run/ok/await.wasm-run.ok +++ b/test/run/ok/await.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/await.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/bank-example.wasm-run.ok b/test/run/ok/bank-example.wasm-run.ok index 286b4068a22..b84483e8c59 100644 --- a/test/run/ok/bank-example.wasm-run.ok +++ b/test/run/ok/bank-example.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/bank-example.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/block.wasm-run.ok b/test/run/ok/block.wasm-run.ok index 286b4068a22..fcc79ff8676 100644 --- a/test/run/ok/block.wasm-run.ok +++ b/test/run/ok/block.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/block.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/for.wasm-run.ok b/test/run/ok/for.wasm-run.ok index 286b4068a22..808d296fa47 100644 --- a/test/run/ok/for.wasm-run.ok +++ b/test/run/ok/for.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/for.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/is.wasm-run.ok b/test/run/ok/is.wasm-run.ok index 286b4068a22..7faf7aff33f 100644 --- a/test/run/ok/is.wasm-run.ok +++ b/test/run/ok/is.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/is.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/literals.wasm-run.ok b/test/run/ok/literals.wasm-run.ok index 286b4068a22..11a148f71ae 100644 --- a/test/run/ok/literals.wasm-run.ok +++ b/test/run/ok/literals.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/literals.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/overflow.wasm-run.ok b/test/run/ok/overflow.wasm-run.ok index 286b4068a22..880c476f3f5 100644 --- a/test/run/ok/overflow.wasm-run.ok +++ b/test/run/ok/overflow.wasm-run.ok @@ -1 +1 @@ -error running start function: unreachable executed +_out/overflow.wasm:0x___: runtime trap: unreachable executed From ae7542f714f43141d6b28397c0e6a6cfaf1442de Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 9 Jan 2019 12:31:52 +0100 Subject: [PATCH 40/41] Lots of new comments in compile.ml (and some mild code cleanup) --- src/compile.ml | 550 ++++++++++++++++++++++++++++++------------------- 1 file changed, 337 insertions(+), 213 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index bfb4928efb7..651a641175b 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1,55 +1,83 @@ +(* +This module is the backend of the ActorScript compiler. It takes a program in +the intermediate representation (ir.ml), and produces a WebAssembly module, +with DFINITY extensions (customModule.ml). An important helper module is +instrList.ml, which provides a more convenient way of assembling WebAssembly +instruction lists, as it takes care of (1) source locations and (2) labels. + +This file is split up in a number of modules, purely for namespacing and +grouping. Every module has a high-level prose comment explainin the concept; +this keeps documentation close to the code (a lessen learned from Simon PJ). +*) + + open Wasm.Ast open Wasm.Types - open Source open Ir +open CustomModule (* Re-shadow Source.(@@), to get Pervasives.(@@) *) let (@@) = Pervasives.(@@) -open CustomModule - module G = InstrList -let (^^) = G.(^^) (* is this how we do that? *) +let (^^) = G.(^^) (* is this how we import a single operator from a module that we otherwise use qualified? *) -(* Helper functions to produce annotated terms *) +(* Helper functions to produce annotated terms (Wasm.AST) *) let nr x = { Wasm.Source.it = x; Wasm.Source.at = Wasm.Source.no_region } -(* Convert between region representations *) +(* Dito, for the Source AST *) let nr_ x = { it = x; at = no_region; note = () } let todo fn se x = Printf.eprintf "%s: %s" fn (Wasm.Sexpr.to_string 80 se); x -(* The compiler environment. +(* -It is almost immutable.. +** The compiler environment. -The mutable parts (`ref`) are used to register things like locals and -functions. This should be monotone in the sense that entries are only added, -and that the order should not matter in a significant way. +Of course, as we go through the code we have to track a few things; these are +put in the compiler environment, type `E.t`. Some fields are valid globally, some +only make sense locally, i.e. within a single function (but we still put them +in one big record, for convenience). -*) +The field fall into the following categories: -type mode = WasmMode | DfinityMode + 1. Static global fields. Never change. + Example: whether we are compiling with --dfinity; the prelude code -(* Names can be referring to one of these things: *) -(* Most names are stored in heap locations stored in Locals. - But some are special (static funcions, static messages of the current actor). - These have no location (yet), but we need to generate one on demand. - *) + 2. Immutable global fields. Change in a well-scoped manner. + Example: Mapping from ActorScrpit names to their location. -type 'env deferred_loc = - { allocate : 'env -> G.t - ; is_direct_call : int32 option - (* a little backdoor. coul be expanded into a general 'call' field *) - } + 3. Mutable global fields. Change only monotonously. + These are used to register things like functions. This should be monotone + in the sense that entries are only added, and that the order should not + matter in a significant way. In some instances, the list contains futures + so that we can reserve and know the _position_ of the thing before we have + to actually fill it in. + + 4. Static local fields. Never change within a function. + Example: number of parameters and return values + + 5. Immutable local fields. Change in a well-scoped manner. + Example: Jump label depth + + 6. Mutable local fields. See above + Example: Name and type of locals. + +**) + +(* Before we can define the environment, we need some auxillary types *) + +type mode = WasmMode | DfinityMode +(* A type to record where ActorScript names are stored. *) type 'env varloc = (* A Wasm Local of the current function, directly containing the value - (note that most values are pointers) - *) + (note that most values are pointers, but not all) + Used for immutable and mutable, non-captured data *) | Local of int32 (* A Wasm Local of the current function, that points to memory location, - with an offset (in words) to the actual data. *) + with an offset (in words) to value. + Used for mutable captured data *) | HeapInd of (int32 * int32) (* A static memory location in the current module *) | Static of int32 @@ -57,6 +85,16 @@ type 'env varloc = (need not be captured) *) | Deferred of 'env deferred_loc +(* Most names are stored in heap locations or in locals. + But some are special (static funcions, the current actor, static messages of + the current actor). These have no real location (yet), but we still need to + produce a value on demand: + *) +and 'env deferred_loc = + { allocate : 'env -> G.t + ; is_direct_call : int32 option (* To optimize known calls. *) + } + module E = struct (* Utilities, internal to E *) @@ -74,94 +112,93 @@ module E = struct (* The environment type *) module NameEnv = Env.Make(String) - type local_names = (int32 * string) list + type local_names = (int32 * string) list (* For the debug section: Names of locals *) type func_with_names = func * local_names type lazy_built_in = | Declared of (int32 * (func_with_names -> unit)) | Defined of int32 | Pending of (unit -> func_with_names) type t = { + (* Global fields *) + (* Static *) mode : mode; + prelude : prog; (* The prelude. Re-used when compiling actors *) + + (* Immutable *) + local_vars_env : t varloc NameEnv.t; (* variables ↦ their location *) - (* Imports defined *) + (* Mutable *) + func_types : func_type list ref; imports : import list ref; - (* Exports defined *) exports : export list ref; - (* Function defined in this module *) + dfinity_types : (int32 * CustomSections.type_ list) list ref; (* Dfinity types of exports *) funcs : (func * string * local_names) Lib.Promise.t list ref; - (* Function number and fill function for built-in functions *) built_in_funcs : lazy_built_in NameEnv.t ref; - (* Types registered in this module *) - func_types : func_type list ref; - (* Number of parameters in the current function, to calculate indices of locals *) - n_param : int32; - (* Number of return values, to correctly compile calls to Return *) - n_res : int; - (* Types of locals *) - locals : value_type list ref; - local_names : (int32 * string) list ref; - (* A mapping from jump label to their depth *) - ld : G.depth NameEnv.t; - (* Mapping ActorScript variables to WebAssembly locals, globals or functions *) - local_vars_env : t varloc NameEnv.t; - (* The prelude. We need to re-use this when compiling actors *) - prelude : prog; - (* Exports that need a custom type for the hypervisor *) - dfinity_types : (int32 * CustomSections.type_ list) list ref; - (* Where does static memory end and dynamic memory begin? *) - end_of_static_memory : int32 ref; - (* Static memory defined so far *) - static_memory : (int32 * string) list ref; - (* Sanity check: Nothing should bump end_of_static_memory once it has been read *) + end_of_static_memory : int32 ref; (* End of statically allocated memory *) + static_memory : (int32 * string) list ref; (* Content of static memory *) static_memory_frozen : bool ref; - } + (* Sanity check: Nothing should bump end_of_static_memory once it has been read *) - let mode (e : t) = e.mode + (* Local fields (only valid/used inside a function) *) + (* Static *) + n_param : int32; (* Number of parameters (to calculate indices of locals) *) + n_res : int; (* Number of return values (for type of Return) *) + + (* Immutable *) + ld : G.depth NameEnv.t; (* jump label ↦ their depth *) - (* Indices of local variables *) - let unary_closure_local env : var = nr 0l (* first param *) + (* Mutable *) + locals : value_type list ref; (* Types of locals *) + local_names : (int32 * string) list ref; (* Names of locals *) + } (* The initial global environment *) let mk_global mode prelude dyn_mem : t = { mode; + prelude; + local_vars_env = NameEnv.empty; + func_types = ref []; imports = ref []; exports = ref []; + dfinity_types = ref []; funcs = ref []; built_in_funcs = ref NameEnv.empty; - func_types = ref []; - dfinity_types = ref []; + end_of_static_memory = ref dyn_mem; + static_memory = ref []; + static_memory_frozen = ref false; (* Actually unused outside mk_fun_env: *) - locals = ref []; - local_names = ref []; - local_vars_env = NameEnv.empty; n_param = 0l; n_res = 0; ld = NameEnv.empty; - prelude; - end_of_static_memory = ref dyn_mem; - static_memory = ref []; - static_memory_frozen = ref false; + locals = ref []; + local_names = ref []; } - - let is_non_local = function + (* Creating a local environment, resetting the local fields, + and removing bindings for local variables (unless they are at global locations) + *) + let is_non_local : 'env varloc -> bool = function | Local _ -> false | HeapInd _ -> false | Static _ -> true | Deferred _ -> true - - (* Resetting the environment for a new function *) let mk_fun_env env n_param n_res = { env with - locals = ref []; - local_names = ref []; n_param; n_res; + ld = NameEnv.empty; + locals = ref []; + local_names = ref []; (* We keep all local vars that are bound to known functions or globals *) local_vars_env = NameEnv.filter (fun _ -> is_non_local) env.local_vars_env; - ld = NameEnv.empty; } + (* We avoid accessing the fields of t directly from outside of E, so here are a + bunch of accessors. *) + + let mode (e : t) = e.mode + + let lookup_var env var = match NameEnv.find_opt var env.local_vars_env with | Some l -> Some l @@ -305,12 +342,9 @@ end let compile_unboxed_const i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I32 i))) let compile_const_64 i = G.i (Wasm.Ast.Const (nr (Wasm.Values.I64 i))) -let compile_unboxed_zero = compile_unboxed_const 0l -let compile_unit = compile_unboxed_const 1l -(* This needs to be disjoint from all pointers *) -let compile_null = compile_unboxed_const 3l +let compile_unboxed_zero = compile_unboxed_const 0l -(* Some common arithmetic *) +(* Some common arithmetic, used for pointer and index arithmetic *) let compile_op_const op i = compile_unboxed_const i ^^ G.i (Binary (Wasm.Values.I32 op)) @@ -337,7 +371,7 @@ let _new_local64 env name = let (set_i, get_i, _) = new_local_ env I64Type name in (set_i, get_i) -(* Some code combinators *) +(* Some common code macros *) (* expects a number on the stack. Iterates from zero t below that number *) let compile_while cond body = @@ -365,7 +399,7 @@ let from_0_to_n env mk_body = ) -(* Heap and allocations *) +(* Pointer reference and dereference *) let load_ptr : G.t = G.i (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) @@ -374,6 +408,9 @@ let store_ptr : G.t = G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) module Func = struct + (* This module contains basic bookkeeping functionality to define functions, + in particular creating the environment, and finally adding it to the environment. + *) let of_body env params retty mk_body = let env1 = E.mk_fun_env env (Int32.of_int (List.length params)) (List.length retty) in @@ -396,34 +433,33 @@ module Func = struct end (* Func *) module Heap = struct - (* General heap object functionalty (allocation, setting fields, reading fields) *) - (* We keep track of the end of the used heap in this global, and bump it if - we allocate stuff. - Memory addresses are 32 bit (I32Type). - *) + (* Memory addresses are 32 bit (I32Type). *) let word_size = 4l - let heap_ptr = 2l + (* We keep track of the end of the used heap in this global, and bump it if + we allocate stuff. *) + let heap_global = 2l + let get_heap_ptr = G.i (GlobalGet (nr heap_global)) + let set_heap_ptr = G.i (GlobalSet (nr heap_global)) (* Dynamic allocation *) - let dyn_alloc_words env = Func.share_code env "alloc_words" ["n", I32Type] [I32Type] (fun env -> let get_n = G.i (LocalGet (nr 0l)) in (* expect the size (in words), returns the pointer *) - G.i (GlobalGet (nr heap_ptr)) ^^ + get_heap_ptr ^^ (* Update heap pointer *) get_n ^^ compile_mul_const word_size ^^ (* Add to old heap value *) - G.i (GlobalGet (nr heap_ptr)) ^^ + get_heap_ptr ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (GlobalSet (nr heap_ptr)) + set_heap_ptr ) let dyn_alloc_bytes env = @@ -439,46 +475,45 @@ module Heap = struct (* Static allocation (always words) (uses dynamic allocation for smaller and more readable code *) - let alloc env (n : int32) : G.t = compile_unboxed_const n ^^ dyn_alloc_words env (* Heap objects *) + (* At this level of abstactions, heap objects are just flat arrays of words *) + let load_field (i : int32) : G.t = G.i (Load {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) - let load_field64 (i : int32) : G.t = - G.i (Load {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) - let store_field (i : int32) : G.t = G.i (Store {ty = I32Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + (* Although we occationally want to treat to of them as a 64 bit number *) + + let load_field64 (i : int32) : G.t = + G.i (Load {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) + let store_field64 (i : int32) : G.t = G.i (Store {ty = I64Type; align = 2; offset = Wasm.I32.mul word_size i; sz = None}) (* Create a heap object with instructions that fill in each word *) let obj env element_instructions : G.t = - let n = List.length element_instructions in + let (set_heap_obj, get_heap_obj) = new_local env "heap_object" in - let (set_i, get_i) = new_local env "heap_object" in + let n = List.length element_instructions in alloc env (Wasm.I32.of_int_u n) ^^ - set_i ^^ - - let compile_self = get_i in + set_heap_obj ^^ let init_elem idx instrs : G.t = - compile_self ^^ + get_heap_obj ^^ instrs ^^ store_field (Wasm.I32.of_int_u idx) in G.concat_mapi init_elem element_instructions ^^ + get_heap_obj - compile_self - - (* Convenience functions around memory *) - + (* Convenience functions related to memory *) let memcpy env = Func.share_code env "memcpy" ["from", I32Type; "two", I32Type; "n", I32Type] [] (fun env -> let get_from = G.i (LocalGet (nr 0l)) in @@ -502,8 +537,20 @@ module Heap = struct end (* Heap *) module ElemHeap = struct - let ref_counter = 3l + (* The ElemHeap adds a level of indirection for references (elements, as in + ElemRef). This way, the fake orthogonal persistence code can easily + store all references an elembuf. + + This could be done differently (e.g. traversing the heap and looking for tagged references), but + it predates the heap traversal code, and the whole thing goes away once we + target orthogonal persistence anyways. + *) + let ref_counter_global = 3l + let get_ref_ctr = G.i (GlobalGet (nr ref_counter_global)) + let set_ref_ctr = G.i (GlobalSet (nr ref_counter_global)) + + (* For now, we allocate a fixed size range. This obviously cannot stay. *) let max_references = 1024l (* By placing the ElemHeap at memory location 0, we incidentally make sure that @@ -520,19 +567,19 @@ module ElemHeap = struct let get_ref = G.i (LocalGet (nr 0l)) in (* Return index *) - G.i (GlobalGet (nr ref_counter)) ^^ + get_ref_ctr ^^ (* Store reference *) - G.i (GlobalGet (nr ref_counter)) ^^ + get_ref_ctr ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ store_ptr ^^ (* Bump counter *) - G.i (GlobalGet (nr ref_counter)) ^^ + get_ref_ctr ^^ compile_add_const 1l ^^ - G.i (GlobalSet (nr ref_counter)) + set_ref_ctr ) (* Assumes a index into the table on the stack, and replaces it with the reference *) @@ -548,17 +595,26 @@ module ElemHeap = struct end (* ElemHeap *) module ClosureTable = struct + (* + Another fixed-size table at the beginning of memory: When we create a closure + that is bound to a funcref that we pass out, we need this level of indirection for + two reasons: + - we cannot just bind the address via i32.bind, because that is not stable, due + to our moving GC, and + - we need to remember that these closures are roots (and currenlty never freed!) + + Therefore we maintain a static table from closure index to address of the closure + on the heap. + *) + let max_entries = 1024l let loc = ElemHeap.table_end let table_end = Int32.(add loc (mul max_entries Heap.word_size)) + (* For reasons I do not recall we use the first word of the table as the counter, + and not a global. + *) let get_counter = compile_unboxed_const loc ^^ load_ptr - let set_counter env = - let (set_i, get_i) = new_local env "new_counter" in - set_i ^^ - compile_unboxed_const loc ^^ - get_i ^^ - store_ptr (* Assumes a reference on the stack, and replaces it with an index into the reference table *) @@ -579,9 +635,10 @@ module ClosureTable = struct store_ptr ^^ (* Bump counter *) + compile_unboxed_const loc ^^ get_counter ^^ compile_add_const 1l ^^ - set_counter env + store_ptr ) (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) @@ -596,12 +653,26 @@ module ClosureTable = struct end (* ClosureTable *) -module BitTagged = struct - (* Raw values x are stored as ( x << 1 | 1), i.e. with the LSB set. - Pointers are stored as is (and should be aligned to have a zero there). - Special case: The zero pointer is considered a pointer. +module Bool = struct + (* Boolean literals are either 0 or 1 + The 1 is recognized as a unboxed scalar anyways, + while the 0 is special (see below). + This allows us to use the result of the WebAssembly comparison operators + directly, and to use the booleans directly with WebAssembly’s If. *) + let lit = function + | false -> compile_unboxed_const 0l + | true -> compile_unboxed_const 1l + +end (* Bool *) + +module BitTagged = struct + (* This module takes care of pointer tagging: Pointer are always aligned, so they + have their LSB bit unset. We use that and store an unboxed scalar x + as (x << 1 | 1). + Special case: The zero pointer is considered a scalar. + *) let if_unboxed env retty is1 is2 = Func.share_code env "is_unboxed" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (LocalGet (nr 0l)) in @@ -613,7 +684,7 @@ module BitTagged = struct compile_unboxed_const 1l ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) - (compile_unboxed_const 1l ^^ G.i Return) G.nop ^^ + (Bool.lit true ^^ G.i Return) G.nop ^^ (* Also check if it is the null-pointer *) get_x ^^ compile_unboxed_const 0l ^^ @@ -621,6 +692,7 @@ module BitTagged = struct ) ^^ G.if_ retty is1 is2 + (* The untag_scalar and tag functions expect 64 bit numbers *) let untag_scalar env = compile_unboxed_const 1l ^^ G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ @@ -638,17 +710,20 @@ end (* BitTagged *) module Tagged = struct (* Tagged objects have, well, a tag to describe their runtime type. This tag is used to traverse the heap (serialization, GC), but also - for objectification of arrays and actorrefs and the like. + for objectification of arrays. - All tagged heap objects have a size of at least two words. + The tag is a word at the beginning of the object. + + All tagged heap objects have a size of at least two words + (important for GC, which replaces them with an Indirection). *) type tag = | Object - | ObjInd (* The indirection used in object *) + | ObjInd (* The indirection used for object fields *) | Array (* Also a tuple *) | Reference (* Either arrayref or funcref, no need to distinguish here *) - | Int + | Int (* Contains a 64 bit number *) | MutBox (* used for local variables *) | Closure | Some (* For opt *) @@ -701,12 +776,16 @@ module Tagged = struct branch_default env retty (G.i Unreachable) cases let obj env tag element_instructions : G.t = - Heap.obj env (compile_unboxed_const (int_of_tag tag) :: element_instructions) + Heap.obj env @@ + compile_unboxed_const (int_of_tag tag) :: + element_instructions end (* Tagged *) module Var = struct + (* This module is all about looking up ActorScript variables in the environment, + and dealing with mutable variables *) (* When accessing a variable that is a static function, then we need to create a heap-allocated closure-like thing on the fly. *) @@ -716,14 +795,9 @@ module Var = struct compile_unboxed_const 0l (* number of parameters: none *) ] - let field_box env code = - Tagged.obj env Tagged.ObjInd [ code ] - (* Local variables may in general be mutable (or at least late-defined). So we need to add an indirection through the heap. We tag this indirection using Tagged.MutBox. - (Although I am not yet entirely sure that this needs to be tagged. Do these - ever show up in GC or serialization? I guess as part of closures.) *) let mutbox_field = Tagged.header_size let load = Heap.load_field mutbox_field @@ -732,7 +806,7 @@ module Var = struct let add_local env name = E.add_local_with_offset env name mutbox_field - (* Stores the payload *) + (* Stores the payload (which is found on the stack) *) let set_val env var = match E.lookup_var env var with | Some (Local i) -> G.i (LocalSet (nr i)) @@ -760,7 +834,10 @@ module Var = struct | None -> G.i Unreachable (* Returns the value to put in the closure, - and code to restore it, including adding to the environment *) + and code to restore it, including adding to the environment + This currently reserves an unused word in the closure even for static stuff, + could be improved at some point. + *) let capture env var : G.t * (E.t -> (E.t * G.t)) = match E.lookup_var env var with | Some (Local i) -> ( G.i (LocalGet (nr i)) @@ -777,25 +854,31 @@ module Var = struct in (env2, restore_code) ) | Some (Static i) -> - ( compile_null , fun env1 -> (E.add_local_static env1 var i, G.i Drop)) + ( compile_unboxed_zero, fun env1 -> (E.add_local_static env1 var i, G.i Drop)) | Some (Deferred d) -> - ( compile_null , fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) + ( compile_unboxed_zero, fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) | None -> (G.i Unreachable, fun env1 -> (env1, G.i Unreachable)) (* Returns a pointer to a heap allocated box for this. - (either a mutbox, if already mutable, or a freshly allocated box + (either a mutbox, if already mutable, or a freshly allocated box) *) + let field_box env code = + Tagged.obj env Tagged.ObjInd [ code ] let get_val_ptr env var = match E.lookup_var env var with | Some (HeapInd (i, 1l)) -> G.i (LocalGet (nr i)) | _ -> field_box env (get_val env var) end (* Var *) module Opt = struct + (* The Option type. Not much intereting to see here *) -let payload_field = Tagged.header_size + let payload_field = Tagged.header_size -let inject env e = Tagged.obj env Tagged.Some [e] -let project = Heap.load_field Tagged.header_size + (* This needs to be disjoint from all pointers, i.e. tagged as a scalar. *) + let null = compile_unboxed_const 3l + + let inject env e = Tagged.obj env Tagged.Some [e] + let project = Heap.load_field Tagged.header_size end (* Opt *) @@ -809,7 +892,8 @@ module AllocHow = struct - functions are static, unless they capture something that is not a static function - everything that is captured before it is defined needs to be heap-allocated, unless it is a static function - - everything that is mutable and captures needs to be heap-allocated + - everything that is mutable and captured needs to be heap-allocated + - the rest can be local Immutable things are always pointers or unboxed scalars, and can be put into closures as such. @@ -824,7 +908,7 @@ module AllocHow = struct type allocHow = nonStatic M.t (* absent means static *) let join : allocHow -> allocHow -> allocHow = - M.union (fun _ x y -> Some (match x, y with + M.union (fun _ x y -> Some (match x, y with | _, StoreHeap -> StoreHeap | StoreHeap, _ -> StoreHeap | LocalMut, _ -> LocalMut @@ -905,7 +989,7 @@ module AllocHow = struct | Some StoreHeap -> let (env1, i) = E.add_local_with_offset env name 1l in let alloc_code = - Tagged.obj env Tagged.MutBox [ compile_unboxed_const 0l ] ^^ + Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ] ^^ G.i (LocalSet (nr i)) in (env1, alloc_code) | _ -> (env, G.nop) @@ -921,16 +1005,24 @@ end (* AllocHow *) module Closure = struct + (* In this module, we deal with closures, i.e. functions that capture parts + of their environment. + + The structure of a closure is: + + ┌─────┬───────┬──────┬──────────────┐ + │ tag │ funid │ size │ captured ... │ + └─────┴───────┴──────┴──────────────┘ + + *) let header_size = Int32.add Tagged.header_size 2l let funptr_field = Tagged.header_size let len_field = Int32.add 1l Tagged.header_size - let first_captured = header_size - - let load_the_closure = G.i (LocalGet (nr 0l)) - let load_closure i = load_the_closure ^^ Heap.load_field (Int32.add first_captured i) - + let get = G.i (LocalGet (nr 0l)) + let load_data i = Heap.load_field (Int32.add header_size i) + let store_data i = Heap.store_field (Int32.add header_size i) (* Calculate the wasm type for a given calling convention. An extra first argument for the closure! *) @@ -940,9 +1032,10 @@ module Closure = struct Lib.List.make cc.Value.n_res I32Type)) (* Expect on the stack - the function closure - and arguments (n-ary!) - the function closure again! *) + * the function closure + * and arguments (n-ary!) + * the function closure again! + *) let call_closure env cc = (* get the table index *) Heap.load_field funptr_field ^^ @@ -962,8 +1055,8 @@ module BoxedInt = struct (* We store large nats and ints in immutable boxed 64bit heap objects. Eventually, this should contain the bigint implementation. - Small values (<2^5, so that both paths are tested) are stored unboxed, - tagged, see BitTagged. + Small values (just <2^5 for now, so that both code paths are well-tested) + are stored unboxed, tagged, see BitTagged. *) let payload_field = Int32.add Tagged.header_size 0l @@ -1019,13 +1112,31 @@ module Prim = struct end (* Prim *) module Object = struct + (* An object has the following heap layout: + + ┌─────┬───────┬──────────┬─────────────┬─────────────┬───┐ + │ tag │ class │ n_fields │ field_hash1 │ field_data1 │ … │ + └─────┴───────┴──────────┴─────────────┴─────────────┴───┘ + + The field_data are pointers to either an ObjInd, or a MutBox (they + have the same layout). This indirection is a consequence of how we + compile object literals with `await` instructions, as these mutable + fields need to be able to alias local mutal variables. + + We could (and eventually should) use the type information to avoid this + indirection for immutable fields. Or switch to an allocate-first approach + in the await-translation of objects, and get rid of this indirection. + *) + (* First word: Class pointer (0x1, an invalid pointer, when none) *) let header_size = Int32.add Tagged.header_size 2l let class_position = Int32.add Tagged.header_size 0l + (* Number of object fields *) let size_field = Int32.add Tagged.header_size 1l + (* We use the same hashing function as Ocaml would *) let hash_field_name ({it = Syntax.Name s; _}) = Int32.of_int (Hashtbl.hash s) @@ -1132,20 +1243,14 @@ module Object = struct end (* Object *) -module Bool = struct - (* Boolean literals are either 0 or 1 - The 1 is recognized as a unboxed scalar anyways, - while the 0 is special. This allows us - to use the result of the WebAssembly comparison operators - directly. - *) - let lit = function - | false -> compile_unboxed_const 0l - | true -> compile_unboxed_const 1l +module Text = struct + (* The layout of a text object is -end (* Bool *) + ┌─────┬─────────┬──────────────────┐ + │ tag │ n_bytes │ bytes (padded) … │ + └─────┴─────────┴──────────────────┘ + *) -module Text = struct let header_size = Int32.add Tagged.header_size 1l let len_field = Int32.add Tagged.header_size 0l @@ -1169,7 +1274,7 @@ module Text = struct let ptr = E.add_static_bytes env data in compile_unboxed_const ptr - (* Two strings on stack *) + (* String concatentation. Expects two strings on stack *) let concat env = Func.share_code env "concat" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> let get_x = G.i (LocalGet (nr 0l)) in let get_y = G.i (LocalGet (nr 1l)) in @@ -1227,7 +1332,7 @@ module Text = struct get_z ) - (* Two strings on stack *) + (* String comparison. Expects two strings on stack *) let compare env = Func.share_code env "Text.compare" ["x", I32Type; "y", I32Type] [I32Type] (fun env -> let get_x = G.i (LocalGet (nr 0l)) in let get_y = G.i (LocalGet (nr 1l)) in @@ -1267,11 +1372,20 @@ module Text = struct end (* String *) module Array = struct + (* Object layout: + + ┌─────┬──────────┬────────┬───┐ + │ tag │ n_fields │ field1 │ … │ + └─────┴──────────┴────────┴───┘ + + No difference between mutable and immutable arrays. + *) + let header_size = Int32.add Tagged.header_size 1l let element_size = 4l let len_field = Int32.add Tagged.header_size 0l - (* Dynamic array access. Returns the address of the field. + (* Dynamic array access. Returns the address (not the value) of the field. Does bounds checking *) let idx env = Func.share_code env "Array.idx" ["array", I32Type; "idx", I32Type] [I32Type] (fun env -> let get_array = G.i (LocalGet (nr 0l)) in @@ -1292,13 +1406,8 @@ module Array = struct G.i (Binary (Wasm.Values.I32 I32Op.Add)) ) - (* Expects on the stack the pointer to the array. *) - (* Should only be used for Tuples, not Arrays, due to lack of bounds checking *) - let field_of_idx n = Int32.add header_size n - let load_n n = Heap.load_field (field_of_idx n) - let common_funcs env = - let get_array_object = Closure.load_closure 0l in + let get_array_object = Closure.get ^^ Closure.load_data 0l in let get_first_arg = G.i (LocalGet (nr 1l)) in let get_second_arg = G.i (LocalGet (nr 2l)) in @@ -1333,7 +1442,7 @@ module Array = struct let (set_boxed_i, get_boxed_i) = new_local env1 "boxed_n" in let (set_i, get_i) = new_local env1 "n" in (* Get pointer to counter from closure *) - Closure.load_closure 0l ^^ + Closure.get ^^ Closure.load_data 0l ^^ (* Get current counter (boxed) *) Var.load ^^ set_boxed_i ^^ @@ -1346,14 +1455,14 @@ module Array = struct get_i ^^ (* Get length *) - Closure.load_closure 1l ^^ Heap.load_field len_field ^^ + Closure.get ^^ Closure.load_data 1l ^^ Heap.load_field len_field ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType (Some I32Type)) (* Then *) - compile_null + Opt.null (* Else *) ( (* Get point to counter from closure *) - Closure.load_closure 0l ^^ + Closure.get ^^ Closure.load_data 0l ^^ (* Store increased counter *) get_i ^^ compile_add_const 1l ^^ @@ -1362,7 +1471,7 @@ module Array = struct Var.store ^^ (* Return stuff *) Opt.inject env1 ( - mk_code env (Closure.load_closure 1l) get_boxed_i get_i + mk_code env (Closure.get ^^ Closure.load_data 1l) get_boxed_i get_i ) ) ) in @@ -1491,6 +1600,23 @@ module Array = struct ) ^^ get_r +end (* Array *) + +module Tuple = struct + (* Tuples use the same object representation (and same tag) as arrays. + Even though we know the size statically, we still need the size + information for the GC. + + One could introduce tags for small tuples, to save one word. + *) + + (* We represent the boxed empty tuple as the unboxed scalar 0, i.e. simply as + number (but really anything is fine, we never look at this) *) + let compile_unit = compile_unboxed_const 1l + + (* Expects on the stack the pointer to the array. *) + let load_n n = Heap.load_field (Int32.add Array.header_size n) + (* Takes n elements of the stack and produces an argument tuple *) let from_stack env n = if n = 0 then compile_unit @@ -1498,7 +1624,7 @@ module Array = struct let name = Printf.sprintf "to_%i_tuple" n in let args = Lib.List.table n (fun i -> Printf.sprintf "arg%i" i, I32Type) in Func.share_code env name args [I32Type] (fun env -> - lit env (Lib.List.table n (fun i -> G.i (LocalGet (nr (Int32.of_int i))))) + Array.lit env (Lib.List.table n (fun i -> G.i (LocalGet (nr (Int32.of_int i))))) ) (* Takes an argument tuple and puts the elements on the stack: *) @@ -1510,10 +1636,10 @@ module Array = struct let get_tup = G.i (LocalGet (nr 0l)) in G.table n (fun i -> get_tup ^^ load_n (Int32.of_int i)) ) - -end (* Array *) +end (* Tuple *) module Dfinity = struct + (* Dfinity-specific stuff: System imports, databufs etc. *) (* function ids for imported stuff *) let test_print_i env = 0l @@ -1787,7 +1913,7 @@ module OrthogonalPersistence = struct ( (* Set heap pointer based on databuf length *) get_i ^^ compile_add_const ElemHeap.table_end ^^ - G.i (GlobalSet (nr Heap.heap_ptr)) ^^ + Heap.set_heap_ptr ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ @@ -1799,11 +1925,11 @@ module OrthogonalPersistence = struct (* Load reference counter *) G.i (GlobalGet (nr elem_global)) ^^ G.i (Call (nr (Dfinity.elem_length_i env1))) ^^ - G.i (GlobalSet (nr ElemHeap.ref_counter)) ^^ + ElemHeap.set_ref_ctr ^^ (* Load references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i (GlobalGet (nr ElemHeap.ref_counter)) ^^ + ElemHeap.get_ref_ctr ^^ G.i (GlobalGet (nr elem_global)) ^^ compile_unboxed_zero ^^ G.i (Call (nr (Dfinity.elem_internalize_i env1))) @@ -1812,7 +1938,7 @@ module OrthogonalPersistence = struct Func.define_built_in env "save_mem" [] [] (fun env1 -> (* Store memory *) compile_unboxed_const ElemHeap.table_end ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ compile_unboxed_const ElemHeap.table_end ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ @@ -1820,7 +1946,7 @@ module OrthogonalPersistence = struct (* Store references *) compile_unboxed_const ElemHeap.ref_location ^^ - G.i (GlobalGet (nr ElemHeap.ref_counter)) ^^ + ElemHeap.get_ref_ctr ^^ G.i (Call (nr (Dfinity.elem_externalize_i env))) ^^ G.i (GlobalSet (nr elem_global)) ) @@ -1858,16 +1984,14 @@ module Serialization = struct pointer. * We traverse this space and adjust all pointers. Same for indices into the reference table. - *) - let serialize_go env = Func.share_code env "serialize_go" ["x", I32Type] [I32Type] (fun env -> let get_x = G.i (LocalGet (nr 0l)) in let (set_copy, get_copy) = new_local env "x" in - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ set_copy ^^ get_x ^^ @@ -2248,7 +2372,7 @@ module Serialization = struct let (set_databuf, get_databuf) = new_local env "databuf" in (* Remember where we start to copy to *) - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ set_start ^^ (* Copy data *) @@ -2262,7 +2386,7 @@ module Serialization = struct store_ptr ^^ (* Remember the end *) - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ set_end ^^ (* Empty table of references *) @@ -2274,7 +2398,7 @@ module Serialization = struct G.i Drop ^^ (* Remember the end *) - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ set_end ^^ (* Adjust pointers *) @@ -2308,7 +2432,7 @@ module Serialization = struct (* Reset the heap counter, to free some space *) get_start ^^ - G.i (GlobalSet (nr Heap.heap_ptr)) ^^ + Heap.set_heap_ptr ^^ (* Finally, create elembuf *) get_end ^^ @@ -2338,7 +2462,7 @@ module Serialization = struct let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in (* new positions *) - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ set_start ^^ get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ @@ -2375,16 +2499,16 @@ module Serialization = struct get_start ^^ get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (GlobalSet (nr Heap.heap_ptr)) ^^ + Heap.set_heap_ptr ^^ (* Fix pointers *) get_start ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ get_start ^^ shift_pointers env ^^ (* Load references *) - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ get_tbl_size ^^ compile_sub_const 1l ^^ get_elembuf ^^ compile_unboxed_const 0l ^^ @@ -2393,8 +2517,8 @@ module Serialization = struct (* Fix references *) (* Extract references *) get_start ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ + Heap.get_heap_ptr ^^ + Heap.get_heap_ptr ^^ intract_references env ^^ (* return allocated thing *) @@ -2493,8 +2617,8 @@ module GC = struct let (set_end_to_space, get_end_to_space) = new_local env "end_to_space" in compile_unboxed_const end_of_static_space ^^ set_begin_from_space ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_begin_to_space ^^ - G.i (GlobalGet (nr Heap.heap_ptr)) ^^ set_end_to_space ^^ + Heap.get_heap_ptr ^^ set_begin_to_space ^^ + Heap.get_heap_ptr ^^ set_end_to_space ^^ (* Common arguments for evalcuate *) @@ -2537,7 +2661,7 @@ module GC = struct get_begin_from_space ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (GlobalSet (nr Heap.heap_ptr)) + Heap.set_heap_ptr ) @@ -2589,7 +2713,7 @@ module FuncDec = struct let args = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in let retty = Lib.List.make cc.Value.n_res I32Type in Func.of_body env (["clos", I32Type] @ args) retty (fun env1 -> G.with_region at ( - let get_closure = G.i (LocalGet (E.unary_closure_local env1)) in + let get_closure = G.i (LocalGet (nr 0l)) in let (env2, closure_code) = restore_env env1 get_closure in @@ -2712,14 +2836,14 @@ module FuncDec = struct let store_env = get_li ^^ store_this ^^ - Heap.store_field (Int32.add Closure.first_captured (Wasm.I32.of_int_u i)) ^^ + Closure.store_data (Wasm.I32.of_int_u i) ^^ store_rest in let restore_env env1 get_env = let (env2, code) = restore_this env1 in let (env3, code_rest) = restore_rest env2 get_env in (env3, get_env ^^ - Heap.load_field (Int32.add Closure.first_captured (Wasm.I32.of_int_u i)) ^^ + Closure.load_data (Wasm.I32.of_int_u i) ^^ code ^^ code_rest ) @@ -2874,8 +2998,8 @@ module StackRep = struct | Unreachable, Unreachable -> G.nop | Unreachable, _ -> G.i Unreachable - | UnboxedTuple n, Vanilla -> Array.from_stack env n - | Vanilla, UnboxedTuple n -> Array.to_stack env n + | UnboxedTuple n, Vanilla -> Tuple.from_stack env n + | Vanilla, UnboxedTuple n -> Tuple.to_stack env n | UnboxedInt, Vanilla -> BoxedInt.box env | Vanilla, UnboxedInt -> BoxedInt.unbox env @@ -2961,7 +3085,7 @@ let compile_lit env lit = Syntax.(match lit with | NatLit n -> StackRep.UnboxedInt, (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) - | NullLit -> StackRep.Vanilla, compile_null + | NullLit -> StackRep.Vanilla, Opt.null | TextLit t -> StackRep.Vanilla, Text.lit env t | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Vanilla, G.i Unreachable) ) @@ -3256,7 +3380,7 @@ and compile_exp (env : E.t) exp = | ProjE (e1,n) -> StackRep.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to tuple (an array) *) - Array.load_n (Int32.of_int n) + Tuple.load_n (Int32.of_int n) | ArrayE (m, es) -> StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) | ActorE (name, fs) -> @@ -3270,7 +3394,7 @@ and compile_exp (env : E.t) exp = StackRep.of_arity (cc.Value.n_res), begin match isDirectCall env e1, cc.Value.sort with | Some fi, _ -> - compile_null ^^ (* A dummy closure *) + compile_unboxed_zero ^^ (* A dummy closure *) compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ (* the args *) G.i (Call (nr fi)) | None, (Type.Call Type.Local | Type.Construct) -> @@ -3330,7 +3454,7 @@ and compile_exp (env : E.t) exp = (* Check for null *) get_oi ^^ - compile_null ^^ + Opt.null ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) G.nop @@ -3445,7 +3569,7 @@ and fill_pat env pat : patternCode = CanFail (fun fail_code -> set_i ^^ get_i ^^ - compile_null ^^ + Opt.null ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) fail_code ( get_i ^^ @@ -3466,7 +3590,7 @@ and fill_pat env pat : patternCode = | (p::ps) -> let code1 = fill_pat env p in let code2 = go (i+1) ps env in - ( CannotFail (get_i ^^ Array.load_n (Int32.of_int i)) ^^^ + ( CannotFail (get_i ^^ Tuple.load_n (Int32.of_int i)) ^^^ code1 ^^^ code2 ) in CannotFail set_i ^^^ go 0 ps env From c95a5e69f0e8b8732f5bbd310ad24c09d8595790 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 9 Jan 2019 12:41:22 +0100 Subject: [PATCH 41/41] Avoid building asc when invoking `nix-shell` --- shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shell.nix b/shell.nix index 52d4538db4c..3c14744e935 100644 --- a/shell.nix +++ b/shell.nix @@ -17,7 +17,7 @@ let default = import ./default.nix { inherit nixpkgs test-dvm; }; in nixpkgs.mkShell { buildInputs = default.native.buildInputs ++ - default.native_test.buildInputs ++ + builtins.filter (i: i != default.native) default.native_test.buildInputs ++ [ nixpkgs.ncurses ]; }