From 07e81926d21751e09ee948dec8505dc7c2b92f17 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 6 Mar 2019 19:38:14 +0100 Subject: [PATCH 01/76] Tag pointers, not scalars to make life easier for arithmetic on Word8/Word16 (#216) (This is with GC disabled.) --- src/compile.ml | 208 ++++++++++-------- test/run-dfinity/data-params.as | 8 +- test/run-dfinity/ok/data-params.dvm-run.ok | 3 +- test/run-dfinity/ok/data-params.run-ir.ok | 4 +- test/run-dfinity/ok/data-params.run-low.ok | 4 +- test/run-dfinity/ok/data-params.run.ok | 4 +- test/run-dfinity/ok/data-params.tc.ok | 1 + .../run-dfinity/ok/data-params.wasm.stderr.ok | 1 + test/run/text-pats.as | 7 + 9 files changed, 149 insertions(+), 91 deletions(-) create mode 100644 test/run-dfinity/ok/data-params.tc.ok create mode 100644 test/run-dfinity/ok/data-params.wasm.stderr.ok diff --git a/src/compile.ml b/src/compile.ml index 57a218ba1b1..67f7a906ca0 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -366,7 +366,7 @@ module E = struct let add_static_bytes (env : t) data : int32 = let ptr = reserve_static_memory env (Int32.of_int (String.length data)) in env.static_memory := !(env.static_memory) @ [ (ptr, data) ]; - ptr + Int32.(add ptr (-1l)) (* Return a shifted pointer *) let get_end_of_static_memory env : int32 = env.static_memory_frozen := true; @@ -448,12 +448,18 @@ let from_0_to_n env mk_body = (* Pointer reference and dereference *) -let load_ptr : G.t = +let load_unshifted_ptr : G.t = G.i (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) -let store_ptr : G.t = +let store_unshifted_ptr : G.t = G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) +let load_ptr : G.t = + G.i (Load {ty = I32Type; align = 2; offset = 1l; sz = None}) + +let store_ptr : G.t = + G.i (Store {ty = I32Type; align = 2; offset = 1l; 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. @@ -512,10 +518,11 @@ module Heap = struct let word_size = 4l (* We keep track of the end of the used heap in this global, and bump it if - we allocate stuff. *) + we allocate stuff. This the actual memory offset, not-shifted yet *) let heap_global = 2l let get_heap_ptr = G.i (GlobalGet (nr heap_global)) let set_heap_ptr = G.i (GlobalSet (nr heap_global)) + let get_shifted_heap_ptr = get_heap_ptr ^^ compile_add_const (-1l) (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) let grow_memory env = @@ -544,8 +551,10 @@ module Heap = struct (* Dynamic allocation *) let dyn_alloc_words env = Func.share_code1 env "alloc_words" ("n", I32Type) [I32Type] (fun env get_n -> - (* expect the size (in words), returns the pointer *) - get_heap_ptr ^^ + (* expects the size (in words), returns the pointer *) + + (* return the current pointer (shifted) *) + get_shifted_heap_ptr ^^ (* Update heap pointer *) get_heap_ptr ^^ @@ -565,28 +574,32 @@ module Heap = struct ) (* Static allocation (always words) - (uses dynamic allocation for smaller and more readable code *) + (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 *) + (* At this level of abstaction, 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 offset = Int32.(add (mul word_size i) 1l) in + G.i (Load {ty = I32Type; align = 2; offset; 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 offset = Int32.(add (mul word_size i) 1l) in + G.i (Store {ty = I32Type; align = 2; offset; 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 offset = Int32.(add (mul word_size i) 1l) in + G.i (Load {ty = I64Type; align = 2; offset; 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}) + let offset = Int32.(add (mul word_size i) 1l) in + G.i (Store {ty = I64Type; align = 2; offset; sz = None}) (* Create a heap object with instructions that fill in each word *) let obj env element_instructions : G.t = @@ -605,6 +618,7 @@ module Heap = struct get_heap_obj (* Convenience functions related to memory *) + (* Works on unshifted memory addresses! *) let memcpy env = Func.share_code3 env "memcpy" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_n ^^ @@ -622,6 +636,15 @@ module Heap = struct ) ) + (* Variant for shifted memory addresses! *) + let memcpy_shifted env = + Func.share_code3 env "memcpy_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> + get_from ^^ compile_add_const 1l ^^ + get_to ^^ compile_add_const 1l ^^ + get_n ^^ + memcpy env + ) + end (* Heap *) module ElemHeap = struct @@ -660,7 +683,7 @@ module ElemHeap = struct compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ - store_ptr ^^ + store_unshifted_ptr ^^ (* Bump counter *) get_ref_ctr ^^ @@ -674,7 +697,7 @@ module ElemHeap = struct get_ref_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ - load_ptr + load_unshifted_ptr ) end (* ElemHeap *) @@ -699,7 +722,7 @@ module ClosureTable = struct (* 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 get_counter = compile_unboxed_const loc ^^ load_unshifted_ptr (* Assumes a reference on the stack, and replaces it with an index into the reference table *) @@ -715,13 +738,13 @@ module ClosureTable = struct compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ get_ptr ^^ - store_ptr ^^ + store_unshifted_ptr ^^ (* Bump counter *) compile_unboxed_const loc ^^ get_counter ^^ compile_add_const 1l ^^ - store_ptr + store_unshifted_ptr ) (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) @@ -730,15 +753,14 @@ module ClosureTable = struct get_closure_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ - load_ptr + load_unshifted_ptr ) end (* ClosureTable *) 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). + Both are recognized as a unboxed scalar anyways, This allows us to use the result of the WebAssembly comparison operators directly, and to use the booleans directly with WebAssembly’s If. *) @@ -750,52 +772,49 @@ 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 scalar_shift = 2l + + (* This module takes care of pointer tagging: + + A pointer to an object at offset `i` on the heap is represented as + `i-1`, so the low two bits of the pointer are always set. + + This means we can store an unboxed scalar x as (x << 2). + + It also means that 0 and 1 are recognized as non-pointers, so we can use + these for false and true, matching the result of WebAssembly’s comparision + operators. *) let if_unboxed env retty is1 is2 = Func.share_code1 env "is_unboxed" ("x", I32Type) [I32Type] (fun env get_x -> (* Get bit *) get_x ^^ - compile_unboxed_const 1l ^^ + compile_unboxed_const 0x2l ^^ G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^ (* Check bit *) - compile_unboxed_const 1l ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) - (Bool.lit true ^^ 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 I32Op.Eq)) + G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ) ^^ G.if_ retty is1 is2 (* The untag_scalar and tag functions expect 64 bit numbers *) let untag_scalar env = - compile_unboxed_const 1l ^^ + compile_unboxed_const scalar_shift ^^ 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 I32Op.Shl)) ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) + compile_unboxed_const scalar_shift ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) (* The untag_i32 and tag_i32 functions expect 32 bit numbers *) let untag_i32 env = - compile_unboxed_const 1l ^^ + compile_unboxed_const scalar_shift ^^ G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) let tag_i32 = - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - compile_unboxed_const 1l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) + compile_unboxed_const scalar_shift ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) end (* BitTagged *) @@ -976,7 +995,7 @@ module Opt = struct let payload_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 null = compile_unboxed_const 5l let inject env e = Tagged.obj env Tagged.Some [e] let project = Heap.load_field Tagged.header_size @@ -1489,10 +1508,10 @@ module Text = struct (* Copy first string *) get_x ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_len1 ^^ @@ -1500,10 +1519,10 @@ module Text = struct (* Copy second string *) get_y ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ @@ -1534,13 +1553,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const (Int32.mul Heap.word_size header_size) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_i ^^ 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) ^^ + compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ get_i ^^ 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)}) ^^ @@ -1574,8 +1593,7 @@ module Array = struct (* 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 ^^ + get_array ^^ Heap.load_field len_field ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ @@ -1954,7 +1972,8 @@ module Dfinity = struct Func.share_code1 env "databuf_of_text" ("string", I32Type) [I32Type] (fun env get_string -> (* Calculate the offset *) get_string ^^ - compile_add_const (Int32.mul Heap.word_size Text.header_size) ^^ + compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) 1l) ^^ + (* Calculate the length *) get_string ^^ Heap.load_field (Text.len_field) ^^ @@ -2149,7 +2168,7 @@ module Serialization = struct TODO: Cycles are not detected yet. We separate code for copying and the code for pointer adjustment because - the latter can be used again in the deseriazliation code. + the latter can be used again in the deserialization code. The deserialization is analogous: * We internalize the elembuf into the table, bumping the table reference @@ -2164,26 +2183,31 @@ module Serialization = struct let serialize_go env = Func.share_code1 env "serialize_go" ("x", I32Type) [I32Type] (fun env get_x -> - let (set_copy, get_copy) = new_local env "x" in - - Heap.get_heap_ptr ^^ - set_copy ^^ + let (set_copy, get_copy) = new_local env "x'" in get_x ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) ( get_x ) - ( get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) + ( get_x ^^ + Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - get_x ^^ Heap.alloc env 2l ^^ + set_copy ^^ + + get_x ^^ + get_copy ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy env ^^ + Heap.memcpy_shifted env ^^ + get_copy ; Tagged.Reference, + Heap.alloc env 2l ^^ set_copy ^^ + get_x ^^ - Heap.alloc env 2l ^^ + get_copy ^^ compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy env ^^ + Heap.memcpy_shifted env ^^ + get_copy ; Tagged.Some, Opt.inject env ( @@ -2205,13 +2229,13 @@ module Serialization = struct get_len ^^ compile_add_const Array.header_size ^^ Heap.dyn_alloc_words env ^^ - G.i Drop ^^ + set_copy ^^ (* Copy header *) get_x ^^ get_copy ^^ compile_unboxed_const (Int32.mul Heap.word_size Array.header_size) ^^ - Heap.memcpy env ^^ + Heap.memcpy_shifted env ^^ (* Copy fields *) get_len ^^ @@ -2242,14 +2266,14 @@ module Serialization = struct get_len ^^ Heap.dyn_alloc_words env ^^ - G.i Drop ^^ + set_copy ^^ (* Copy header and data *) get_x ^^ get_copy ^^ get_len ^^ compile_mul_const Heap.word_size ^^ - Heap.memcpy env ^^ + Heap.memcpy_shifted env ^^ get_copy end @@ -2264,13 +2288,13 @@ module Serialization = struct compile_mul_const 2l ^^ compile_add_const Object.header_size ^^ Heap.dyn_alloc_words env ^^ - G.i Drop ^^ + set_copy ^^ (* Copy header *) get_x ^^ get_copy ^^ compile_unboxed_const (Int32.mul Heap.word_size Object.header_size) ^^ - Heap.memcpy env ^^ + Heap.memcpy_shifted env ^^ (* Copy fields *) get_len ^^ @@ -2290,7 +2314,6 @@ module Serialization = struct get_x ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - load_ptr ^^ store_ptr ^^ @@ -2526,11 +2549,15 @@ module Serialization = struct then Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) else Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env get_x -> let (set_start, get_start) = new_local env "old_heap" in + let (set_start_shifted, get_start_shifted) = new_local env "old_heap_shifted" in let (set_end, get_end) = new_local env "end" in + let (set_end_shifted, get_end_shifted) = new_local env "end_shifted" in let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in let (set_databuf, get_databuf) = new_local env "databuf" in (* Remember where we start to copy to *) + Heap.get_shifted_heap_ptr ^^ + set_start_shifted ^^ Heap.get_heap_ptr ^^ set_start ^^ @@ -2545,6 +2572,8 @@ module Serialization = struct store_ptr ^^ (* Remember the end *) + Heap.get_shifted_heap_ptr ^^ + set_end_shifted ^^ Heap.get_heap_ptr ^^ set_end ^^ @@ -2557,31 +2586,33 @@ module Serialization = struct G.i Drop ^^ (* Remember the end *) + Heap.get_shifted_heap_ptr ^^ + set_end_shifted ^^ Heap.get_heap_ptr ^^ set_end ^^ (* Adjust pointers *) - get_start ^^ - get_end ^^ + get_start_shifted ^^ + get_end_shifted ^^ compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ shift_pointers env ^^ (* Extract references, and remember how many there were *) - get_start ^^ - get_end ^^ - get_end ^^ + get_start_shifted ^^ + get_end_shifted ^^ + get_end_shifted ^^ extract_references env ^^ set_tbl_size ) ^^ (* Create databuf *) get_start ^^ - get_end ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ + get_end_shifted ^^ get_start_shifted ^^ 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_end_shifted ^^ get_tbl_size ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_databuf ^^ @@ -2621,7 +2652,7 @@ module Serialization = struct let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in (* new positions *) - Heap.get_heap_ptr ^^ + Heap.get_shifted_heap_ptr ^^ set_start ^^ get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ @@ -2629,11 +2660,11 @@ module Serialization = struct (* Get scratch space (one word) *) Heap.alloc env 1l ^^ G.i Drop ^^ - get_start ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const 1l ^^ Heap.set_heap_ptr ^^ (* First load databuf reference (last entry) at the heap position somehow *) (* now load the databuf *) - get_start ^^ + get_start ^^ compile_add_const 1l ^^ compile_unboxed_const 1l ^^ get_elembuf ^^ get_tbl_size ^^ compile_sub_const 1l ^^ @@ -2646,10 +2677,10 @@ module Serialization = struct (* Get some scratch space *) get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ - get_start ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const 1l ^^ Heap.set_heap_ptr ^^ (* Load data from databuf *) - get_start ^^ + get_start ^^ compile_add_const 1l ^^ get_data_len ^^ get_databuf ^^ compile_unboxed_const 0l ^^ @@ -2667,13 +2698,14 @@ module Serialization = struct get_start ^^ get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + compile_add_const 1l ^^ Heap.set_heap_ptr ^^ Heap.grow_memory env ^^ (* Fix pointers *) get_start ^^ - Heap.get_heap_ptr ^^ - get_start ^^ + Heap.get_shifted_heap_ptr ^^ + get_start ^^ compile_add_const 1l ^^ shift_pointers env ^^ (* Load references *) @@ -2686,8 +2718,8 @@ module Serialization = struct (* Fix references *) (* Extract references *) get_start ^^ - Heap.get_heap_ptr ^^ - Heap.get_heap_ptr ^^ + Heap.get_shifted_heap_ptr ^^ + Heap.get_shifted_heap_ptr ^^ intract_references env ^^ (* return allocated thing *) @@ -2711,6 +2743,8 @@ module GC = struct (could be mutable array of pointers, similar to the reference table) *) + let gc_enabled = false + (* If the pointer at ptr_loc points after begin_from_space, copy to after end_to_space, and replace it with a pointer, adjusted for where the object will be finally. *) @@ -2776,6 +2810,8 @@ module GC = struct ) let register env (end_of_static_space : int32) = Func.define_built_in env "collect" [] [] (fun env -> + if not gc_enabled then G.nop else + (* Copy all roots. *) let (set_begin_from_space, get_begin_from_space) = new_local env "begin_from_space" in let (set_begin_to_space, get_begin_to_space) = new_local env "begin_to_space" in diff --git a/test/run-dfinity/data-params.as b/test/run-dfinity/data-params.as index c47ad52ce98..514bab82b0e 100644 --- a/test/run-dfinity/data-params.as +++ b/test/run-dfinity/data-params.as @@ -43,6 +43,11 @@ let a = actor { printInt(c); print("\n"); }; + printLabeledOpt(?l:?Text) { + print l; + printInt(c); + print("\n"); + }; readCounter(f : shared Nat -> ()) : () { f(c); }; @@ -63,5 +68,6 @@ a.incopt(?14); a.increcord(shared {x = 15; y = 16}); a.increcord(shared {x = 17; y = 18; z = 19}); a.printCounter(); -a.printLabeled("Foo: "); +a.printLabeled("Foo1: "); +a.printLabeledOpt(?"Foo2: "); // a.readCounter(func (n : Nat) = { printInt n; print("\n") }); diff --git a/test/run-dfinity/ok/data-params.dvm-run.ok b/test/run-dfinity/ok/data-params.dvm-run.ok index 26d329b39b0..fb6b4a5a031 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -13,4 +13,5 @@ Top-level code done. 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index e77c77a5d0a..d1d7763fa15 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -1,3 +1,4 @@ +data-params.as:46.19-46.27: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +13,5 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index e77c77a5d0a..d1d7763fa15 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -1,3 +1,4 @@ +data-params.as:46.19-46.27: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +13,5 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index e77c77a5d0a..d1d7763fa15 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -1,3 +1,4 @@ +data-params.as:46.19-46.27: warning, this pattern does not cover all possible values 1 3 6 @@ -12,4 +13,5 @@ 1006136 1006171 1006171 -Foo: 1006171 +Foo1: 1006171 +Foo2: 1006171 diff --git a/test/run-dfinity/ok/data-params.tc.ok b/test/run-dfinity/ok/data-params.tc.ok new file mode 100644 index 00000000000..bad5a00208d --- /dev/null +++ b/test/run-dfinity/ok/data-params.tc.ok @@ -0,0 +1 @@ +data-params.as:46.19-46.27: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/data-params.wasm.stderr.ok b/test/run-dfinity/ok/data-params.wasm.stderr.ok new file mode 100644 index 00000000000..bad5a00208d --- /dev/null +++ b/test/run-dfinity/ok/data-params.wasm.stderr.ok @@ -0,0 +1 @@ +data-params.as:46.19-46.27: warning, this pattern does not cover all possible values diff --git a/test/run/text-pats.as b/test/run/text-pats.as index a030910a043..5a5a9f551ef 100644 --- a/test/run/text-pats.as +++ b/test/run/text-pats.as @@ -3,4 +3,11 @@ switch "foo" { case "" assert false; case "foo" assert true; case _ assert false; +}; + +switch (?"foo") { + case (?"bar") assert false; + case (?"") assert false; + case (?"foo") assert true; + case _ assert false; } From aa327341e0456f31ad8a5605c92ae6e7341c1676 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 6 Mar 2019 19:54:13 +0100 Subject: [PATCH 02/76] Also do GC --- src/compile.ml | 75 +++++++++++++++++++++++++++----------------------- 1 file changed, 41 insertions(+), 34 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 67f7a906ca0..7a72358622f 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -25,6 +25,10 @@ let (^^) = G.(^^) (* is this how we import a single operator from a module that (* WebAssembly pages are 64kb. *) let page_size = Int32.of_int (64*1024) +(* Pointers are shifted -1 relative to the actual offset *) +let ptr_shift = -1l +let ptr_unshift = 1l + (* Helper functions to produce annotated terms (Wasm.AST) *) let nr x = { Wasm.Source.it = x; Wasm.Source.at = Wasm.Source.no_region } (* Dito, for the Source AST *) @@ -366,7 +370,7 @@ module E = struct let add_static_bytes (env : t) data : int32 = let ptr = reserve_static_memory env (Int32.of_int (String.length data)) in env.static_memory := !(env.static_memory) @ [ (ptr, data) ]; - Int32.(add ptr (-1l)) (* Return a shifted pointer *) + Int32.(add ptr ptr_shift) (* Return a shifted pointer *) let get_end_of_static_memory env : int32 = env.static_memory_frozen := true; @@ -455,10 +459,10 @@ let store_unshifted_ptr : G.t = G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) let load_ptr : G.t = - G.i (Load {ty = I32Type; align = 2; offset = 1l; sz = None}) + G.i (Load {ty = I32Type; align = 2; offset = ptr_unshift; sz = None}) let store_ptr : G.t = - G.i (Store {ty = I32Type; align = 2; offset = 1l; sz = None}) + G.i (Store {ty = I32Type; align = 2; offset = ptr_unshift; sz = None}) module Func = struct (* This module contains basic bookkeeping functionality to define functions, @@ -522,7 +526,7 @@ module Heap = struct let heap_global = 2l let get_heap_ptr = G.i (GlobalGet (nr heap_global)) let set_heap_ptr = G.i (GlobalSet (nr heap_global)) - let get_shifted_heap_ptr = get_heap_ptr ^^ compile_add_const (-1l) + let get_shifted_heap_ptr = get_heap_ptr ^^ compile_add_const ptr_shift (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) let grow_memory env = @@ -584,21 +588,21 @@ module Heap = struct (* At this level of abstaction, heap objects are just flat arrays of words *) let load_field (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) 1l) in + let offset = Int32.(add (mul word_size i) ptr_unshift) in G.i (Load {ty = I32Type; align = 2; offset; sz = None}) let store_field (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) 1l) in + let offset = Int32.(add (mul word_size i) ptr_unshift) in G.i (Store {ty = I32Type; align = 2; offset; sz = None}) (* Although we occationally want to treat to of them as a 64 bit number *) let load_field64 (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) 1l) in + let offset = Int32.(add (mul word_size i) ptr_unshift) in G.i (Load {ty = I64Type; align = 2; offset; sz = None}) let store_field64 (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) 1l) in + let offset = Int32.(add (mul word_size i) ptr_unshift) in G.i (Store {ty = I64Type; align = 2; offset; sz = None}) (* Create a heap object with instructions that fill in each word *) @@ -639,8 +643,8 @@ module Heap = struct (* Variant for shifted memory addresses! *) let memcpy_shifted env = Func.share_code3 env "memcpy_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> - get_from ^^ compile_add_const 1l ^^ - get_to ^^ compile_add_const 1l ^^ + get_from ^^ compile_add_const ptr_unshift ^^ + get_to ^^ compile_add_const ptr_unshift ^^ get_n ^^ memcpy env ) @@ -1508,10 +1512,10 @@ module Text = struct (* Copy first string *) get_x ^^ - compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_len1 ^^ @@ -1519,10 +1523,10 @@ module Text = struct (* Copy second string *) get_y ^^ - compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ @@ -1553,13 +1557,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const (Int32.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_i ^^ 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.(add 1l (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ get_i ^^ 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)}) ^^ @@ -1972,7 +1976,7 @@ module Dfinity = struct Func.share_code1 env "databuf_of_text" ("string", I32Type) [I32Type] (fun env get_string -> (* Calculate the offset *) get_string ^^ - compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) 1l) ^^ + compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) ptr_unshift) ^^ (* Calculate the length *) get_string ^^ @@ -2660,11 +2664,11 @@ module Serialization = struct (* Get scratch space (one word) *) Heap.alloc env 1l ^^ G.i Drop ^^ - get_start ^^ compile_add_const 1l ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const ptr_unshift ^^ Heap.set_heap_ptr ^^ (* First load databuf reference (last entry) at the heap position somehow *) (* now load the databuf *) - get_start ^^ compile_add_const 1l ^^ + get_start ^^ compile_add_const ptr_unshift ^^ compile_unboxed_const 1l ^^ get_elembuf ^^ get_tbl_size ^^ compile_sub_const 1l ^^ @@ -2677,10 +2681,10 @@ module Serialization = struct (* Get some scratch space *) get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ - get_start ^^ compile_add_const 1l ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const ptr_unshift ^^ Heap.set_heap_ptr ^^ (* Load data from databuf *) - get_start ^^ compile_add_const 1l ^^ + get_start ^^ compile_add_const ptr_unshift ^^ get_data_len ^^ get_databuf ^^ compile_unboxed_const 0l ^^ @@ -2698,14 +2702,14 @@ module Serialization = struct get_start ^^ get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const 1l ^^ + compile_add_const ptr_unshift ^^ Heap.set_heap_ptr ^^ Heap.grow_memory env ^^ (* Fix pointers *) get_start ^^ Heap.get_shifted_heap_ptr ^^ - get_start ^^ compile_add_const 1l ^^ + get_start ^^ compile_add_const ptr_unshift ^^ shift_pointers env ^^ (* Load references *) @@ -2743,12 +2747,14 @@ module GC = struct (could be mutable array of pointers, similar to the reference table) *) - let gc_enabled = false + let gc_enabled = true (* If the pointer at ptr_loc points after begin_from_space, copy to after end_to_space, and replace it with a pointer, adjusted for where the object will be finally. *) + (* Returns the new end of to_space *) (* Invariant: Must not be called on the same pointer twice. *) + (* All pointers, including ptr_loc and space end markers, are shifted *) let evacuate env = Func.share_code4 env "evaucate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2781,7 +2787,7 @@ module GC = struct (* Copy the referenced object to to space *) get_obj ^^ Serialization.object_size env ^^ set_len ^^ - get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy env ^^ + get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_shifted env ^^ (* Calculate new pointer *) get_end_to_space ^^ @@ -2817,9 +2823,9 @@ module GC = struct let (set_begin_to_space, get_begin_to_space) = new_local env "begin_to_space" in 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 ^^ - Heap.get_heap_ptr ^^ set_begin_to_space ^^ - Heap.get_heap_ptr ^^ set_end_to_space ^^ + compile_unboxed_const end_of_static_space ^^ compile_add_const ptr_shift ^^ set_begin_from_space ^^ + Heap.get_shifted_heap_ptr ^^ set_begin_to_space ^^ + Heap.get_shifted_heap_ptr ^^ set_end_to_space ^^ (* Common arguments for evalcuate *) @@ -2837,11 +2843,12 @@ module GC = struct get_i ^^ compile_add_const 1l ^^ compile_mul_const Heap.word_size ^^ - compile_add_const ClosureTable.loc + compile_add_const ClosureTable.loc ^^ + compile_add_const ptr_shift )) ^^ Serialization.walk_heap_from_to env - (compile_unboxed_const ClosureTable.table_end) - (compile_unboxed_const end_of_static_space) + (compile_unboxed_const (Int32.(add ClosureTable.table_end ptr_shift))) + (compile_unboxed_const (Int32.(add end_of_static_space ptr_shift))) (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ (* Go through the to-space, and evacuate that. @@ -2853,13 +2860,13 @@ module GC = struct (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ (* Copy the to-space to the beginning of memory. *) - get_begin_to_space ^^ - get_begin_from_space ^^ + get_begin_to_space ^^ compile_add_const ptr_unshift ^^ + get_begin_from_space ^^ compile_add_const ptr_unshift ^^ 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_begin_from_space ^^ compile_add_const ptr_unshift ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.set_heap_ptr From b2f4cf64ab96ed6fbb0287d2c3e80a7740e9ae54 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 6 Mar 2019 20:19:56 +0100 Subject: [PATCH 03/76] Phrase object size in words --- src/compile.ml | 53 +++++++++++++++++++++++--------------------------- 1 file changed, 24 insertions(+), 29 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 7a72358622f..efc7419cd46 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -641,11 +641,11 @@ module Heap = struct ) (* Variant for shifted memory addresses! *) - let memcpy_shifted env = + let memcpy_words_shifted env = Func.share_code3 env "memcpy_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_from ^^ compile_add_const ptr_unshift ^^ get_to ^^ compile_add_const ptr_unshift ^^ - get_n ^^ + get_n ^^ compile_mul_const word_size ^^ memcpy env ) @@ -2200,8 +2200,8 @@ module Serialization = struct get_x ^^ get_copy ^^ - compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy_shifted env ^^ + compile_unboxed_const 2l ^^ + Heap.memcpy_words_shifted env ^^ get_copy ; Tagged.Reference, @@ -2209,8 +2209,8 @@ module Serialization = struct get_x ^^ get_copy ^^ - compile_unboxed_const (Int32.mul 2l Heap.word_size) ^^ - Heap.memcpy_shifted env ^^ + compile_unboxed_const 2l ^^ + Heap.memcpy_words_shifted env ^^ get_copy ; Tagged.Some, @@ -2238,8 +2238,8 @@ module Serialization = struct (* Copy header *) get_x ^^ get_copy ^^ - compile_unboxed_const (Int32.mul Heap.word_size Array.header_size) ^^ - Heap.memcpy_shifted env ^^ + compile_unboxed_const Array.header_size ^^ + Heap.memcpy_words_shifted env ^^ (* Copy fields *) get_len ^^ @@ -2276,8 +2276,7 @@ module Serialization = struct get_x ^^ get_copy ^^ get_len ^^ - compile_mul_const Heap.word_size ^^ - Heap.memcpy_shifted env ^^ + Heap.memcpy_words_shifted env ^^ get_copy end @@ -2297,8 +2296,8 @@ module Serialization = struct (* Copy header *) get_x ^^ get_copy ^^ - compile_unboxed_const (Int32.mul Heap.word_size Object.header_size) ^^ - Heap.memcpy_shifted env ^^ + compile_unboxed_const Object.header_size ^^ + Heap.memcpy_words_shifted env ^^ (* Copy fields *) get_len ^^ @@ -2367,44 +2366,40 @@ module Serialization = struct ) ) - (* Returns the object size (in bytes) *) + (* Returns the object size (in words) *) let object_size env = Func.share_code1 env "object_size" ("x", I32Type) [I32Type] (fun env get_x -> get_x ^^ Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, - compile_unboxed_const (Int32.mul 3l Heap.word_size) + compile_unboxed_const 3l ; Tagged.Reference, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.Some, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.ObjInd, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.MutBox, - compile_unboxed_const (Int32.mul 2l Heap.word_size) + compile_unboxed_const 2l ; Tagged.Array, get_x ^^ Heap.load_field Array.len_field ^^ - compile_add_const Array.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Array.header_size ; Tagged.Text, 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 + compile_add_const Text.header_size ; Tagged.Object, get_x ^^ Heap.load_field Object.size_field ^^ compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Object.header_size ; Tagged.Closure, get_x ^^ Heap.load_field Closure.len_field ^^ - compile_add_const Closure.header_size ^^ - compile_mul_const Heap.word_size + compile_add_const Closure.header_size ] (* Indirections have unknown size. *) ) @@ -2420,7 +2415,7 @@ module Serialization = struct ) ( mk_code get_x ^^ get_x ^^ - get_x ^^ object_size env ^^ + get_x ^^ object_size env ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_x ) @@ -2787,7 +2782,7 @@ module GC = struct (* Copy the referenced object to to space *) get_obj ^^ Serialization.object_size env ^^ set_len ^^ - get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_shifted env ^^ + get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_words_shifted env ^^ (* Calculate new pointer *) get_end_to_space ^^ @@ -2811,7 +2806,7 @@ module GC = struct (* Calculate new end of to space *) get_end_to_space ^^ - get_len ^^ + get_len ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ) From ae104fdf45b2b4d4694bf27136c7d225b255a707 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 6 Mar 2019 20:21:08 +0100 Subject: [PATCH 04/76] memcpy: Copy word by word instead of byte by byte --- src/compile.ml | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index efc7419cd46..143c4fa514a 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -622,7 +622,7 @@ module Heap = struct get_heap_obj (* Convenience functions related to memory *) - (* Works on unshifted memory addresses! *) + (* Copying bytes (works on unshifted memory addresses) *) let memcpy env = Func.share_code3 env "memcpy" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_n ^^ @@ -640,13 +640,22 @@ module Heap = struct ) ) - (* Variant for shifted memory addresses! *) + (* Copying words (works on shifted memory addresses) *) let memcpy_words_shifted env = - Func.share_code3 env "memcpy_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> - get_from ^^ compile_add_const ptr_unshift ^^ - get_to ^^ compile_add_const ptr_unshift ^^ - get_n ^^ compile_mul_const word_size ^^ - memcpy env + Func.share_code3 env "memcpy_words_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> + get_n ^^ + from_0_to_n env (fun get_i -> + get_to ^^ + get_i ^^ compile_mul_const word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + + get_from ^^ + get_i ^^ compile_mul_const word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + load_ptr ^^ + + store_ptr + ) ) end (* Heap *) From ea5be4881b78912111cf546d39680787e2f758b1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 7 Mar 2019 00:01:08 +0100 Subject: [PATCH 05/76] Apply suggestions from code review Co-Authored-By: nomeata --- src/compile.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 143c4fa514a..82e2b35acd6 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -585,7 +585,7 @@ module Heap = struct (* Heap objects *) - (* At this level of abstaction, heap objects are just flat arrays of words *) + (* At this level of abstraction, heap objects are just flat arrays of words *) let load_field (i : int32) : G.t = let offset = Int32.(add (mul word_size i) ptr_unshift) in @@ -773,7 +773,7 @@ end (* ClosureTable *) module Bool = struct (* Boolean literals are either 0 or 1 - Both are recognized as a unboxed scalar anyways, + Both are recognized as unboxed scalars anyways, This allows us to use the result of the WebAssembly comparison operators directly, and to use the booleans directly with WebAssembly’s If. *) @@ -795,7 +795,7 @@ module BitTagged = struct This means we can store an unboxed scalar x as (x << 2). It also means that 0 and 1 are recognized as non-pointers, so we can use - these for false and true, matching the result of WebAssembly’s comparision + these for false and true, matching the result of WebAssembly's comparison operators. *) let if_unboxed env retty is1 is2 = From de61c26fd7cac863b63abee0a5c431959dba4d95 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 7 Mar 2019 10:52:05 +0100 Subject: [PATCH 06/76] =?UTF-8?q?Use=20terms=20=E2=80=9Cskewed=E2=80=9D=20?= =?UTF-8?q?for=20the=20shifted=20or=20translated=20pointer?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit and improve comments a bit. --- src/compile.ml | 168 ++++++++++++++++++++++++++----------------------- 1 file changed, 90 insertions(+), 78 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 82e2b35acd6..637f63002a4 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -25,9 +25,12 @@ let (^^) = G.(^^) (* is this how we import a single operator from a module that (* WebAssembly pages are 64kb. *) let page_size = Int32.of_int (64*1024) -(* Pointers are shifted -1 relative to the actual offset *) -let ptr_shift = -1l -let ptr_unshift = 1l +(* +Pointers are shifted -1 relative to the actual offset. +See documentation of module BitTagged for more detail. +*) +let ptr_skew = -1l +let ptr_unskew = 1l (* Helper functions to produce annotated terms (Wasm.AST) *) let nr x = { Wasm.Source.it = x; Wasm.Source.at = Wasm.Source.no_region } @@ -370,7 +373,7 @@ module E = struct let add_static_bytes (env : t) data : int32 = let ptr = reserve_static_memory env (Int32.of_int (String.length data)) in env.static_memory := !(env.static_memory) @ [ (ptr, data) ]; - Int32.(add ptr ptr_shift) (* Return a shifted pointer *) + Int32.(add ptr ptr_skew) (* Return a skewed pointer *) let get_end_of_static_memory env : int32 = env.static_memory_frozen := true; @@ -452,17 +455,17 @@ let from_0_to_n env mk_body = (* Pointer reference and dereference *) -let load_unshifted_ptr : G.t = +let load_unskewed_ptr : G.t = G.i (Load {ty = I32Type; align = 2; offset = 0l; sz = None}) -let store_unshifted_ptr : G.t = +let store_unskewed_ptr : G.t = G.i (Store {ty = I32Type; align = 2; offset = 0l; sz = None}) let load_ptr : G.t = - G.i (Load {ty = I32Type; align = 2; offset = ptr_unshift; sz = None}) + G.i (Load {ty = I32Type; align = 2; offset = ptr_unskew; sz = None}) let store_ptr : G.t = - G.i (Store {ty = I32Type; align = 2; offset = ptr_unshift; sz = None}) + G.i (Store {ty = I32Type; align = 2; offset = ptr_unskew; sz = None}) module Func = struct (* This module contains basic bookkeeping functionality to define functions, @@ -522,11 +525,11 @@ module Heap = struct let word_size = 4l (* We keep track of the end of the used heap in this global, and bump it if - we allocate stuff. This the actual memory offset, not-shifted yet *) + we allocate stuff. This the actual memory offset, not-skewed yet *) let heap_global = 2l let get_heap_ptr = G.i (GlobalGet (nr heap_global)) let set_heap_ptr = G.i (GlobalSet (nr heap_global)) - let get_shifted_heap_ptr = get_heap_ptr ^^ compile_add_const ptr_shift + let get_skewed_heap_ptr = get_heap_ptr ^^ compile_add_const ptr_skew (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) let grow_memory env = @@ -557,8 +560,8 @@ module Heap = struct Func.share_code1 env "alloc_words" ("n", I32Type) [I32Type] (fun env get_n -> (* expects the size (in words), returns the pointer *) - (* return the current pointer (shifted) *) - get_shifted_heap_ptr ^^ + (* return the current pointer (skewed) *) + get_skewed_heap_ptr ^^ (* Update heap pointer *) get_heap_ptr ^^ @@ -588,21 +591,21 @@ module Heap = struct (* At this level of abstraction, heap objects are just flat arrays of words *) let load_field (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) ptr_unshift) in + let offset = Int32.(add (mul word_size i) ptr_unskew) in G.i (Load {ty = I32Type; align = 2; offset; sz = None}) let store_field (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) ptr_unshift) in + let offset = Int32.(add (mul word_size i) ptr_unskew) in G.i (Store {ty = I32Type; align = 2; offset; sz = None}) (* Although we occationally want to treat to of them as a 64 bit number *) let load_field64 (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) ptr_unshift) in + let offset = Int32.(add (mul word_size i) ptr_unskew) in G.i (Load {ty = I64Type; align = 2; offset; sz = None}) let store_field64 (i : int32) : G.t = - let offset = Int32.(add (mul word_size i) ptr_unshift) in + let offset = Int32.(add (mul word_size i) ptr_unskew) in G.i (Store {ty = I64Type; align = 2; offset; sz = None}) (* Create a heap object with instructions that fill in each word *) @@ -622,7 +625,7 @@ module Heap = struct get_heap_obj (* Convenience functions related to memory *) - (* Copying bytes (works on unshifted memory addresses) *) + (* Copying bytes (works on unskewed memory addresses) *) let memcpy env = Func.share_code3 env "memcpy" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_n ^^ @@ -640,9 +643,9 @@ module Heap = struct ) ) - (* Copying words (works on shifted memory addresses) *) - let memcpy_words_shifted env = - Func.share_code3 env "memcpy_words_shifted" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> + (* Copying words (works on skewed memory addresses) *) + let memcpy_words_skewed env = + Func.share_code3 env "memcpy_words_skewed" (("from", I32Type), ("to", I32Type), ("n", I32Type)) [] (fun env get_from get_to get_n -> get_n ^^ from_0_to_n env (fun get_i -> get_to ^^ @@ -696,7 +699,7 @@ module ElemHeap = struct compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ get_ref ^^ - store_unshifted_ptr ^^ + store_unskewed_ptr ^^ (* Bump counter *) get_ref_ctr ^^ @@ -710,7 +713,7 @@ module ElemHeap = struct get_ref_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const ref_location ^^ - load_unshifted_ptr + load_unskewed_ptr ) end (* ElemHeap *) @@ -735,7 +738,7 @@ module ClosureTable = struct (* 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_unshifted_ptr + let get_counter = compile_unboxed_const loc ^^ load_unskewed_ptr (* Assumes a reference on the stack, and replaces it with an index into the reference table *) @@ -751,13 +754,13 @@ module ClosureTable = struct compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ get_ptr ^^ - store_unshifted_ptr ^^ + store_unskewed_ptr ^^ (* Bump counter *) compile_unboxed_const loc ^^ get_counter ^^ compile_add_const 1l ^^ - store_unshifted_ptr + store_unskewed_ptr ) (* Assumes a index into the table on the stack, and replaces it with a ptr to the closure *) @@ -766,7 +769,7 @@ module ClosureTable = struct get_closure_idx ^^ compile_mul_const Heap.word_size ^^ compile_add_const loc ^^ - load_unshifted_ptr + load_unskewed_ptr ) end (* ClosureTable *) @@ -790,12 +793,21 @@ module BitTagged = struct (* This module takes care of pointer tagging: A pointer to an object at offset `i` on the heap is represented as - `i-1`, so the low two bits of the pointer are always set. + `i-1`, so the low two bits of the pointer are always set. We call + `i-1` a *skewed* pointer, in a feeble attempt to avoid the term shifted, + which may sound like a logical shift. + + We use the constants ptr_skew and ptr_unskew to change a pointer as a + signpost where we switch between raw pointers to skewed ones. + + This means we can store a small unboxed scalar x as (x << 2), and still + tell it apart from a pointer. - This means we can store an unboxed scalar x as (x << 2). + We actually use the *second* lowest bit to tell apointer apart from a + scalar. - It also means that 0 and 1 are recognized as non-pointers, so we can use - these for false and true, matching the result of WebAssembly's comparison + It means that 0 and 1 are also recognized as non-pointers, and we can use + these for false and true, matching the result of WebAssembly’s comparison operators. *) let if_unboxed env retty is1 is2 = @@ -1521,10 +1533,10 @@ module Text = struct (* Copy first string *) get_x ^^ - compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_len1 ^^ @@ -1532,10 +1544,10 @@ module Text = struct (* Copy second string *) get_y ^^ - compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_z ^^ - compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ @@ -1566,13 +1578,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const (Int32.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_i ^^ 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.(add ptr_unshift (mul Heap.word_size header_size))) ^^ + compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ get_i ^^ 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)}) ^^ @@ -1985,7 +1997,7 @@ module Dfinity = struct Func.share_code1 env "databuf_of_text" ("string", I32Type) [I32Type] (fun env get_string -> (* Calculate the offset *) get_string ^^ - compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) ptr_unshift) ^^ + compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) ptr_unskew) ^^ (* Calculate the length *) get_string ^^ @@ -2210,7 +2222,7 @@ module Serialization = struct get_x ^^ get_copy ^^ compile_unboxed_const 2l ^^ - Heap.memcpy_words_shifted env ^^ + Heap.memcpy_words_skewed env ^^ get_copy ; Tagged.Reference, @@ -2219,7 +2231,7 @@ module Serialization = struct get_x ^^ get_copy ^^ compile_unboxed_const 2l ^^ - Heap.memcpy_words_shifted env ^^ + Heap.memcpy_words_skewed env ^^ get_copy ; Tagged.Some, @@ -2248,7 +2260,7 @@ module Serialization = struct get_x ^^ get_copy ^^ compile_unboxed_const Array.header_size ^^ - Heap.memcpy_words_shifted env ^^ + Heap.memcpy_words_skewed env ^^ (* Copy fields *) get_len ^^ @@ -2285,7 +2297,7 @@ module Serialization = struct get_x ^^ get_copy ^^ get_len ^^ - Heap.memcpy_words_shifted env ^^ + Heap.memcpy_words_skewed env ^^ get_copy end @@ -2306,7 +2318,7 @@ module Serialization = struct get_x ^^ get_copy ^^ compile_unboxed_const Object.header_size ^^ - Heap.memcpy_words_shifted env ^^ + Heap.memcpy_words_skewed env ^^ (* Copy fields *) get_len ^^ @@ -2557,15 +2569,15 @@ module Serialization = struct then Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) else Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env get_x -> let (set_start, get_start) = new_local env "old_heap" in - let (set_start_shifted, get_start_shifted) = new_local env "old_heap_shifted" in + let (set_start_skewed, get_start_skewed) = new_local env "old_heap_skewed" in let (set_end, get_end) = new_local env "end" in - let (set_end_shifted, get_end_shifted) = new_local env "end_shifted" in + let (set_end_skewed, get_end_skewed) = new_local env "end_skewed" in let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in let (set_databuf, get_databuf) = new_local env "databuf" in (* Remember where we start to copy to *) - Heap.get_shifted_heap_ptr ^^ - set_start_shifted ^^ + Heap.get_skewed_heap_ptr ^^ + set_start_skewed ^^ Heap.get_heap_ptr ^^ set_start ^^ @@ -2580,8 +2592,8 @@ module Serialization = struct store_ptr ^^ (* Remember the end *) - Heap.get_shifted_heap_ptr ^^ - set_end_shifted ^^ + Heap.get_skewed_heap_ptr ^^ + set_end_skewed ^^ Heap.get_heap_ptr ^^ set_end ^^ @@ -2594,33 +2606,33 @@ module Serialization = struct G.i Drop ^^ (* Remember the end *) - Heap.get_shifted_heap_ptr ^^ - set_end_shifted ^^ + Heap.get_skewed_heap_ptr ^^ + set_end_skewed ^^ Heap.get_heap_ptr ^^ set_end ^^ (* Adjust pointers *) - get_start_shifted ^^ - get_end_shifted ^^ + get_start_skewed ^^ + get_end_skewed ^^ compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ shift_pointers env ^^ (* Extract references, and remember how many there were *) - get_start_shifted ^^ - get_end_shifted ^^ - get_end_shifted ^^ + get_start_skewed ^^ + get_end_skewed ^^ + get_end_skewed ^^ extract_references env ^^ set_tbl_size ) ^^ (* Create databuf *) get_start ^^ - get_end_shifted ^^ get_start_shifted ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ + get_end_skewed ^^ get_start_skewed ^^ 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_shifted ^^ + get_end_skewed ^^ get_tbl_size ^^ compile_mul_const Heap.word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_databuf ^^ @@ -2660,7 +2672,7 @@ module Serialization = struct let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in (* new positions *) - Heap.get_shifted_heap_ptr ^^ + Heap.get_skewed_heap_ptr ^^ set_start ^^ get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ @@ -2668,11 +2680,11 @@ module Serialization = struct (* Get scratch space (one word) *) Heap.alloc env 1l ^^ G.i Drop ^^ - get_start ^^ compile_add_const ptr_unshift ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const ptr_unskew ^^ Heap.set_heap_ptr ^^ (* First load databuf reference (last entry) at the heap position somehow *) (* now load the databuf *) - get_start ^^ compile_add_const ptr_unshift ^^ + get_start ^^ compile_add_const ptr_unskew ^^ compile_unboxed_const 1l ^^ get_elembuf ^^ get_tbl_size ^^ compile_sub_const 1l ^^ @@ -2685,10 +2697,10 @@ module Serialization = struct (* Get some scratch space *) get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ - get_start ^^ compile_add_const ptr_unshift ^^ Heap.set_heap_ptr ^^ + get_start ^^ compile_add_const ptr_unskew ^^ Heap.set_heap_ptr ^^ (* Load data from databuf *) - get_start ^^ compile_add_const ptr_unshift ^^ + get_start ^^ compile_add_const ptr_unskew ^^ get_data_len ^^ get_databuf ^^ compile_unboxed_const 0l ^^ @@ -2706,14 +2718,14 @@ module Serialization = struct get_start ^^ get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const ptr_unshift ^^ + compile_add_const ptr_unskew ^^ Heap.set_heap_ptr ^^ Heap.grow_memory env ^^ (* Fix pointers *) get_start ^^ - Heap.get_shifted_heap_ptr ^^ - get_start ^^ compile_add_const ptr_unshift ^^ + Heap.get_skewed_heap_ptr ^^ + get_start ^^ compile_add_const ptr_unskew ^^ shift_pointers env ^^ (* Load references *) @@ -2726,8 +2738,8 @@ module Serialization = struct (* Fix references *) (* Extract references *) get_start ^^ - Heap.get_shifted_heap_ptr ^^ - Heap.get_shifted_heap_ptr ^^ + Heap.get_skewed_heap_ptr ^^ + Heap.get_skewed_heap_ptr ^^ intract_references env ^^ (* return allocated thing *) @@ -2758,7 +2770,7 @@ module GC = struct the object will be finally. *) (* Returns the new end of to_space *) (* Invariant: Must not be called on the same pointer twice. *) - (* All pointers, including ptr_loc and space end markers, are shifted *) + (* All pointers, including ptr_loc and space end markers, are skewed *) let evacuate env = Func.share_code4 env "evaucate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2791,7 +2803,7 @@ module GC = struct (* Copy the referenced object to to space *) get_obj ^^ Serialization.object_size env ^^ set_len ^^ - get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_words_shifted env ^^ + get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_words_skewed env ^^ (* Calculate new pointer *) get_end_to_space ^^ @@ -2827,9 +2839,9 @@ module GC = struct let (set_begin_to_space, get_begin_to_space) = new_local env "begin_to_space" in let (set_end_to_space, get_end_to_space) = new_local env "end_to_space" in - compile_unboxed_const end_of_static_space ^^ compile_add_const ptr_shift ^^ set_begin_from_space ^^ - Heap.get_shifted_heap_ptr ^^ set_begin_to_space ^^ - Heap.get_shifted_heap_ptr ^^ set_end_to_space ^^ + compile_unboxed_const end_of_static_space ^^ compile_add_const ptr_skew ^^ set_begin_from_space ^^ + Heap.get_skewed_heap_ptr ^^ set_begin_to_space ^^ + Heap.get_skewed_heap_ptr ^^ set_end_to_space ^^ (* Common arguments for evalcuate *) @@ -2848,11 +2860,11 @@ module GC = struct compile_add_const 1l ^^ compile_mul_const Heap.word_size ^^ compile_add_const ClosureTable.loc ^^ - compile_add_const ptr_shift + compile_add_const ptr_skew )) ^^ Serialization.walk_heap_from_to env - (compile_unboxed_const (Int32.(add ClosureTable.table_end ptr_shift))) - (compile_unboxed_const (Int32.(add end_of_static_space ptr_shift))) + (compile_unboxed_const (Int32.(add ClosureTable.table_end ptr_skew))) + (compile_unboxed_const (Int32.(add end_of_static_space ptr_skew))) (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ (* Go through the to-space, and evacuate that. @@ -2864,13 +2876,13 @@ module GC = struct (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ (* Copy the to-space to the beginning of memory. *) - get_begin_to_space ^^ compile_add_const ptr_unshift ^^ - get_begin_from_space ^^ compile_add_const ptr_unshift ^^ + get_begin_to_space ^^ compile_add_const ptr_unskew ^^ + get_begin_from_space ^^ compile_add_const ptr_unskew ^^ 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 ^^ compile_add_const ptr_unshift ^^ + get_begin_from_space ^^ compile_add_const ptr_unskew ^^ get_end_to_space ^^ get_begin_to_space ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.set_heap_ptr From 7832b4c33d1b1b0bede39f293eab21c29c58af11 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 7 Mar 2019 10:56:16 +0100 Subject: [PATCH 07/76] Remove some redundant parenthesis --- src/compile.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 637f63002a4..046d77c166f 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1533,10 +1533,10 @@ module Text = struct (* Copy first string *) get_x ^^ - compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_z ^^ - compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_len1 ^^ @@ -1544,10 +1544,10 @@ module Text = struct (* Copy second string *) get_y ^^ - compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_z ^^ - compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ @@ -1578,13 +1578,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const (Int32.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_i ^^ 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.(add ptr_unskew (mul Heap.word_size header_size))) ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ get_i ^^ 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)}) ^^ @@ -1997,7 +1997,7 @@ module Dfinity = struct Func.share_code1 env "databuf_of_text" ("string", I32Type) [I32Type] (fun env get_string -> (* Calculate the offset *) get_string ^^ - compile_add_const (Int32.(add (mul Heap.word_size Text.header_size)) ptr_unskew) ^^ + compile_add_const Int32.(add (mul Heap.word_size Text.header_size) ptr_unskew) ^^ (* Calculate the length *) get_string ^^ @@ -2863,8 +2863,8 @@ module GC = struct compile_add_const ptr_skew )) ^^ Serialization.walk_heap_from_to env - (compile_unboxed_const (Int32.(add ClosureTable.table_end ptr_skew))) - (compile_unboxed_const (Int32.(add end_of_static_space ptr_skew))) + (compile_unboxed_const Int32.(add ClosureTable.table_end ptr_skew)) + (compile_unboxed_const Int32.(add end_of_static_space ptr_skew)) (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ (* Go through the to-space, and evacuate that. @@ -3048,7 +3048,7 @@ module FuncDec = struct let (env3, destruct_args_code) = mk_pat env2 in closure_code ^^ - let get i = G.i (LocalGet (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 )) @@ -3081,7 +3081,7 @@ module FuncDec = struct closure_code ^^ let get i = - G.i (LocalGet (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 ^^ From 0001d4d81e985e47a589eb7e2978ed257d2b48a1 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 7 Mar 2019 12:55:29 +0100 Subject: [PATCH 08/76] Minor typos and elim. tabs (#219) * remove tab * Update compile.ml --- src/compile.ml | 8 ++++---- src/coverage.ml | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 046d77c166f..843dec4efba 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2200,7 +2200,7 @@ module Serialization = struct pointer. * The last entry of the table is the dataref from above. Since we don't need it after this, we decrement the table reference pointer by one. - * We internalize this databuf intot the heap space, bumping the heap + * We internalize this databuf into the heap space, bumping the heap pointer. * We traverse this space and adjust all pointers. Same for indices into the reference table. @@ -2962,7 +2962,7 @@ module StackRep = struct let materialize env = function | StaticFun fi -> Var.static_fun_pointer env fi - let deferred_of_static_think env s = + let deferred_of_static_thing env s = { materialize = (fun env -> (StaticThing s, G.nop)) ; materialize_vanilla = (fun env -> materialize env s) } @@ -3391,7 +3391,7 @@ let compile_relop env t op = (* compile_lexp is used for expressions on the left of an -assignment operator, produces some code (with sideffect), and some pure code *) +assignment operator, produces some code (with side effect), and some pure code *) let rec compile_lexp (env : E.t) exp = (fun (sr,code) -> (sr, G.with_region exp.at code)) @@ match exp.it with @@ -3940,7 +3940,7 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> G.t) = (* A special case for static expressions *) | LetD ({it = VarP v; _}, e) when not (AllocHow.M.mem v.it how) -> let (static_thing, fill) = compile_static_exp pre_env how e in - let d = StackRep.deferred_of_static_think pre_env static_thing in + let d = StackRep.deferred_of_static_thing pre_env static_thing in let pre_env1 = E.add_local_deferred pre_env v.it d in ( pre_env1, G.nop, fun env -> fill env; G.nop) | LetD (p, e) -> diff --git a/src/coverage.ml b/src/coverage.ml index e70a5ae001b..6447ca60e75 100644 --- a/src/coverage.ml +++ b/src/coverage.ml @@ -178,7 +178,7 @@ let warn at fmt = ) fmt let check_cases cases t : bool = - let sets = make_sets () in + let sets = make_sets () in let exhaustive = fail (InCase (Source.no_region, cases, t)) Any sets in let unreached_cases = AtSet.diff sets.cases sets.reached_cases in let unreached_alts = AtSet.diff sets.alts sets.reached_alts in From 611006b2459d305663369dcabf837aaf853956c8 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 7 Mar 2019 17:30:13 +0100 Subject: [PATCH 09/76] Extend testsuite to allow for FileCheck assertions [FileCheck](https://llvm.org/docs/CommandGuide/FileCheck.html) is a tool created by the LLVM folks to embed textual assertions about the output code in test cases. This comment sets up our test suite so that we can put `CHECK` directives into the test files, and `run.sh` will use `FileCheck` to see if the resulting `.wat` file matchs the specs. I am using this in one example to assert that the mutually recursive functions in `mutrec2.as` are compiled to direct calls (and not closures). This requires you to have `FileCheck` in your PATH. The easiest way of doing that is to run nix-env -i -f . -A filecheck --- README.md | 6 ++++-- default.nix | 4 ++++ src/compile.ml | 2 +- test/run.sh | 11 ++++++++++- test/run/mutrec2.as | 16 ++++++++++++---- 5 files changed, 31 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 7ef013c7ad6..6496b1afd84 100644 --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ installing all required tools without nix is out of scope). ``` opam install num vlq yojson bisect_ppx bisect_ppx-ocamlbuild menhir ``` - * Install the `wasm` package. We use a newer version than is on opam, and a + * Install the `wasm` Ocaml package. We use a newer version than is on opam, and a fork that supports the multi-value extension. See `nix/ocaml-wasm.nix` for the precise repository and version. You can use `nix` to fetch the correct source for you, and run the manual installation inside: @@ -73,9 +73,11 @@ installing all required tools without nix is out of scope). cd $(nix-build -Q -A wasm.src)/interpreter make install ``` - * Install the `wasm` tool, using + * Install various command line tools used by, in particuar, the test suite: ``` nix-env -i -f . -A wasm + nix-env -i -f . -A filecheck + nix-env -i -f . -A wabt ``` * Install the `dvm` tool, using ``` diff --git a/default.nix b/default.nix index 4bad62c8ac3..feee501f625 100644 --- a/default.nix +++ b/default.nix @@ -106,6 +106,7 @@ rec { nixpkgs.wabt nixpkgs.bash nixpkgs.perl + filecheck ] ++ (if test-dvm then [ real-dvm ] else []); @@ -202,6 +203,9 @@ rec { wasm = ocaml_wasm; dvm = real-dvm; + filecheck = nixpkgs.linkFarm "FileCheck" + [ { name = "bin/FileCheck"; path = "${nixpkgs.llvm}/bin/FileCheck";} ]; + wabt = nixpkgs.wabt; all-systems-go = nixpkgs.releaseTools.aggregate { name = "all-systems-go"; diff --git a/src/compile.ml b/src/compile.ml index 843dec4efba..7a4c5423c2d 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -273,7 +273,7 @@ module E = struct let d = { materialize = (fun env -> (SR.Vanilla, materialize env)); materialize_vanilla = (fun env -> materialize env) } in - { env with local_vars_env = NameEnv.add name (Deferred d) env.local_vars_env } + add_local_deferred env name d let add_direct_local (env : t) name = let i = add_anon_local env I32Type in diff --git a/test/run.sh b/test/run.sh index 118a14c23d9..45d22c0372f 100755 --- a/test/run.sh +++ b/test/run.sh @@ -78,7 +78,7 @@ do [ -d $out ] || mkdir $out [ -d $ok ] || mkdir $ok - rm -f $out/$base.{tc,wasm,wasm.map,wasm-run,dvm-run} + rm -f $out/$base.{tc,wasm,wasm.map,wasm-run,dvm-run,filecheck,diff-ir,diff-low} # First run all the steps, and remember what to diff diff_files= @@ -132,6 +132,15 @@ do normalize $out/$base.wasm.stderr diff_files="$diff_files $base.wasm.stderr" + # Check filecheck + if grep -F -q CHECK $base.as + then + $ECHO -n " [Filecheck]" + wasm2wat --no-check --enable-multi-value $out/$base.wasm > $out/$base.wat + cat $out/$base.wat | FileCheck $base.as > $out/$base.filecheck 2>&1 + diff_files="$diff_files $base.filecheck" + fi + # Run compiled program if [ -e $out/$base.wasm ] then diff --git a/test/run/mutrec2.as b/test/run/mutrec2.as index 2b80d8dee4a..4238b383cd7 100644 --- a/test/run/mutrec2.as +++ b/test/run/mutrec2.as @@ -1,19 +1,27 @@ -var sub = 1; - func even(n : Nat) : Bool { if (n == 0) { return true; } else - return odd(n-sub); + return odd(n-1); }; func odd(n : Nat) : Bool { if (n == 0) { return false; } else - return even(n-sub); + return even(n-1); }; +// There should be a bunch of calls to known functions here, but +// no indirect calls +// CHECK: func $start +// CHECK: call $even +// CHECK: call $even +// CHECK: call $even +// CHECK: call $even +// CHECK: call $odd +// CHECK: call $odd + assert(even(0)); assert(even(2)); assert(even(4)); From 4f7f6f3239ad65231134dd203ac998f096690c4b Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 7 Mar 2019 16:34:03 +0000 Subject: [PATCH 10/76] [AST-60] fix --- src/typing.ml | 28 +++++++++++++++++++++------- test/fail/AST-60.as | 2 ++ test/fail/ok/AST-60.tc.ok | 1 + test/fail/ok/decl-clash.tc.ok | 26 +------------------------- 4 files changed, 25 insertions(+), 32 deletions(-) create mode 100644 test/fail/AST-60.as create mode 100644 test/fail/ok/AST-60.tc.ok diff --git a/src/typing.ml b/src/typing.ml index 115a3f63d3a..e7d8d95e606 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -1162,12 +1162,26 @@ and infer_dec_valdecs env dec : val_env = let check_prog scope prog : scope Diag.result = Diag.with_message_store (fun msgs -> - Definedness.check_prog msgs prog; - let env = env_of_scope msgs scope in - recover_opt (check_block env T.unit prog.it) prog.at) + recover_opt + (fun prog -> + let env = env_of_scope msgs scope in + let res = check_block env T.unit prog.it prog.at in + Definedness.check_prog msgs prog; + res) + prog + ) let infer_prog scope prog : (T.typ * scope) Diag.result = - Diag.with_message_store (fun msgs -> - Definedness.check_prog msgs prog; - let env = env_of_scope msgs scope in - recover_opt (infer_block env prog.it) prog.at) + Diag.with_message_store + (fun msgs -> + recover_opt + (fun prog -> + let env = env_of_scope msgs scope in + let res = infer_block env prog.it prog.at in + Definedness.check_prog msgs prog; + res + ) + prog + ) + + diff --git a/test/fail/AST-60.as b/test/fail/AST-60.as new file mode 100644 index 00000000000..8297bf79281 --- /dev/null +++ b/test/fail/AST-60.as @@ -0,0 +1,2 @@ +let test = (); +let test = (); \ No newline at end of file diff --git a/test/fail/ok/AST-60.tc.ok b/test/fail/ok/AST-60.tc.ok new file mode 100644 index 00000000000..e74c5ac71fc --- /dev/null +++ b/test/fail/ok/AST-60.tc.ok @@ -0,0 +1 @@ +AST-60.as:2.5-2.9: type error, duplicate definition for test in block diff --git a/test/fail/ok/decl-clash.tc.ok b/test/fail/ok/decl-clash.tc.ok index 7b59d9004e4..a8d57a3427b 100644 --- a/test/fail/ok/decl-clash.tc.ok +++ b/test/fail/ok/decl-clash.tc.ok @@ -1,25 +1 @@ -prelude:66.1-91.2: internal error, Env.Make(X).Clash("test") - -Last environment: -@new_async = func -Array_init = func -Array_tabulate = func -abs = func -ignore = func -intToWord16 = func -intToWord32 = func -intToWord8 = func -natToWord16 = func -natToWord32 = func -natToWord8 = func -print = func -printInt = func -range = func -revrange = func -word16ToInt = func -word16ToNat = func -word32ToInt = func -word32ToNat = func -word8ToInt = func -word8ToNat = func - +decl-clash.as:2.5-2.9: type error, duplicate definition for test in block From 69eb6d2e7c435a72577e10fb50988304462513a3 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 7 Mar 2019 16:40:37 +0000 Subject: [PATCH 11/76] Update AST-60.as add newline for unix police --- test/fail/AST-60.as | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/fail/AST-60.as b/test/fail/AST-60.as index 8297bf79281..7b96dceba4e 100644 --- a/test/fail/AST-60.as +++ b/test/fail/AST-60.as @@ -1,2 +1,2 @@ let test = (); -let test = (); \ No newline at end of file +let test = (); From b0a9bf8d02c4002e27b95eec0fb7241f23ef1ef0 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Fri, 8 Mar 2019 08:13:23 +0100 Subject: [PATCH 12/76] AST-67: Fix Word rotations in the interpreter (#222) * clean result of `shift_right`s * testcase --- src/value.ml | 4 +- test/run/ok/word-rotations.wasm-run.ok | 1 + test/run/ok/word-rotations.wasm.stderr.ok | 74 +++++++++++++++++++++++ test/run/word-rotations.as | 21 +++++++ 4 files changed, 98 insertions(+), 2 deletions(-) create mode 100644 test/run/ok/word-rotations.wasm-run.ok create mode 100644 test/run/ok/word-rotations.wasm.stderr.ok create mode 100644 test/run/word-rotations.as diff --git a/src/value.ml b/src/value.ml index 9a4613045ca..763fb3afc7b 100644 --- a/src/value.ml +++ b/src/value.ml @@ -61,8 +61,8 @@ struct let lognot i = inj (Rep.lognot (proj i)) let logxor i j = inj (Rep.logxor (proj i) (proj j)) let shift_left i j = Rep.shift_left i j - let shift_right = Rep.shift_right - let shift_right_logical = Rep.shift_right_logical + let shift_right i j = let res = Rep.shift_right i j in inj (proj res) + let shift_right_logical i j = let res = Rep.shift_right_logical i j in inj (proj res) let of_int i = inj (Rep.of_int i) let to_int i = Rep.to_int (proj i) let to_string i = group_num (Rep.to_string (proj i)) diff --git a/test/run/ok/word-rotations.wasm-run.ok b/test/run/ok/word-rotations.wasm-run.ok new file mode 100644 index 00000000000..8f241da436a --- /dev/null +++ b/test/run/ok/word-rotations.wasm-run.ok @@ -0,0 +1 @@ +_out/word-rotations.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/word-rotations.wasm.stderr.ok b/test/run/ok/word-rotations.wasm.stderr.ok new file mode 100644 index 00000000000..4a2e9f4a79f --- /dev/null +++ b/test/run/ok/word-rotations.wasm.stderr.ok @@ -0,0 +1,74 @@ +compile_binop: RotROp +compile_binop: RotROp +compile_eq: EqOp +of_type: Word16 +compile_lit: (Word16Lit 5_4715) +compile_binop: RotROp +of_type: Word16 +compile_lit: (Word16Lit 4) +compile_lit: (Word16Lit 23_485) +compile_eq: EqOp +of_type: Word16 +compile_lit: (Word16Lit 5_4715) +compile_binop: RotROp +of_type: Word16 +compile_lit: (Word16Lit 20) +compile_lit: (Word16Lit 23_485) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 202) +compile_binop: RotROp +of_type: Word8 +compile_lit: (Word8Lit 3) +compile_lit: (Word8Lit 86) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 202) +compile_binop: RotROp +of_type: Word8 +compile_lit: (Word8Lit 11) +compile_lit: (Word8Lit 86) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 202) +compile_binop: RotROp +of_type: Word8 +compile_lit: (Word8Lit 19) +compile_lit: (Word8Lit 86) +compile_binop: RotLOp +compile_binop: RotLOp +compile_eq: EqOp +of_type: Word16 +compile_lit: (Word16Lit 4_8085) +compile_binop: RotLOp +of_type: Word16 +compile_lit: (Word16Lit 4) +compile_lit: (Word16Lit 23_485) +compile_eq: EqOp +of_type: Word16 +compile_lit: (Word16Lit 4_8085) +compile_binop: RotLOp +of_type: Word16 +compile_lit: (Word16Lit 20) +compile_lit: (Word16Lit 23_485) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 178) +compile_binop: RotLOp +of_type: Word8 +compile_lit: (Word8Lit 3) +compile_lit: (Word8Lit 86) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 178) +compile_binop: RotLOp +of_type: Word8 +compile_lit: (Word8Lit 11) +compile_lit: (Word8Lit 86) +compile_eq: EqOp +of_type: Word8 +compile_lit: (Word8Lit 178) +compile_binop: RotLOp +of_type: Word8 +compile_lit: (Word8Lit 19) +compile_lit: (Word8Lit 86) diff --git a/test/run/word-rotations.as b/test/run/word-rotations.as new file mode 100644 index 00000000000..1f2d5d5c90c --- /dev/null +++ b/test/run/word-rotations.as @@ -0,0 +1,21 @@ +assert ((0x5bafecbd : Word32) <>> (4 : Word32) == (0xd5bafecb : Word32)); +assert ((0x5bafecbd : Word32) <>> (36 : Word32) == (0xd5bafecb : Word32)); + +assert ((0x5bbd : Word16) <>> (4 : Word16) == (0xd5bb : Word16)); +assert ((0x5bbd : Word16) <>> (20 : Word16) == (0xd5bb : Word16)); + + +assert ((0x56 : Word8) <>> (3 : Word8) == (0xca : Word8)); // 01010110 -> 11001010 +assert ((0x56 : Word8) <>> (11 : Word8) == (0xca : Word8)); +assert ((0x56 : Word8) <>> (19 : Word8) == (0xca : Word8)); + + +assert ((0x5bafecbd : Word32) <<> (4 : Word32) == (0xbafecbd5 : Word32)); +assert ((0x5bafecbd : Word32) <<> (36 : Word32) == (0xbafecbd5 : Word32)); + +assert ((0x5bbd : Word16) <<> (4 : Word16) == (0xbbd5 : Word16)); +assert ((0x5bbd : Word16) <<> (20 : Word16) == (0xbbd5 : Word16)); + +assert ((0x56 : Word8) <<> (3 : Word8) == (0xb2 : Word8)); // 01010110 -> 10110010 +assert ((0x56 : Word8) <<> (11 : Word8) == (0xb2 : Word8)); +assert ((0x56 : Word8) <<> (19 : Word8) == (0xb2 : Word8)); From 80f73df28b03ca0da489f6024bf71b36a5416347 Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Fri, 8 Mar 2019 11:06:22 -0700 Subject: [PATCH 13/76] initial ActorScript mode for emacs --- emacs/actorscript-mode.el | 131 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 131 insertions(+) create mode 100644 emacs/actorscript-mode.el diff --git a/emacs/actorscript-mode.el b/emacs/actorscript-mode.el new file mode 100644 index 00000000000..beee398754c --- /dev/null +++ b/emacs/actorscript-mode.el @@ -0,0 +1,131 @@ +;; ActorScript major mode for Emacs +;; initially based on Swift Mode. + +(setq actorscript-font-lock-keywords + (let* ( + ;; define several category of keywords + ;; these are each taken from either ActorScript's `lexer.mll' or `prelude.ml' files. + (x-types + '("Any" + "None" + "Shared" + "Null" + "Bool" + "Nat" + "Int" + "Word8" + "Word16" + "Word32" + "Word64" + "Float" + "Char" + "Text")) + (x-constants + '("null" + "true" + "false" + )) + (x-keywords + '("actor" + "and" + "async" + "assert" + "await" + "break" + "case" + "class" + "continue" + "label" + "else" + "for" + "func" + "if" + "in" + "new" + "not" + "object" + "or" + "let" + "loop" + "private" + "return" + "shared" + "switch" + "type" + "var" + "while" + "prim" )) + (x-symbols + '( ;"(" + ;")" + ;"[" + ;"]" + ;"{" + ;"}" + ;";" + ;"," + ":" + "<:" + ;"." + "?" + "=" + "<" + ">" + ;"+" + "-" + "*" + "/" + "%" + "**" + "&" + ;"|" + ;"^" + "<<" + ">>" + "<<>" + "<>>" + "#" + "==" + "!=" + ">=" + "<=" + ":=" + "+=" + "-=" + "*=" + "/=" + "%=" + "**=" + "&=" + "|=" + "^=" + "<<=" + ">>=" + "<<>=" + "<>>=" + "#=" + )) + ;; generate regex string for each category of keywords + (x-types-regexp (regexp-opt x-types 'words)) + (x-constant-regexp (regexp-opt x-constants 'words)) + (x-keywords-regexp (regexp-opt x-keywords 'words)) + (x-symbols-regexp (regexp-opt x-symbols 'words)) + ) + ;; + `( + (,x-types-regexp . font-lock-type-face) + (,x-constant-regexp . font-lock-constant-face) + (,x-keywords-regexp . font-lock-keyword-face) + (,x-symbols-regexp . font-lock-keyword-face) + ))) + +(define-derived-mode actorscript-mode + swift-mode "ActorScript" + "Major mode for ActorScript, aka 'CanisterScript'." + (setq font-lock-defaults '((actorscript-font-lock-keywords))) + ) + +(add-to-list 'auto-mode-alist '("\\.as\\'" . actorscript-mode)) + +;; add the mode to the `features' list +(provide 'actorscript-mode) From d4c763626b8b8dddc73f184ff589c180eb973757 Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Fri, 8 Mar 2019 11:18:59 -0700 Subject: [PATCH 14/76] module keyword --- emacs/actorscript-mode.el | 1 + 1 file changed, 1 insertion(+) diff --git a/emacs/actorscript-mode.el b/emacs/actorscript-mode.el index beee398754c..3fd8824683d 100644 --- a/emacs/actorscript-mode.el +++ b/emacs/actorscript-mode.el @@ -41,6 +41,7 @@ "func" "if" "in" + "module" "new" "not" "object" From ee4b495d3721c282d7f9fb71924567faee6c4b76 Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Fri, 8 Mar 2019 11:49:27 -0700 Subject: [PATCH 15/76] fix font-lock for (most) symbols; special regex symbols still broken --- emacs/actorscript-mode.el | 43 ++++++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/emacs/actorscript-mode.el b/emacs/actorscript-mode.el index 3fd8824683d..5bd83e5f4ca 100644 --- a/emacs/actorscript-mode.el +++ b/emacs/actorscript-mode.el @@ -57,30 +57,30 @@ "while" "prim" )) (x-symbols - '( ;"(" - ;")" - ;"[" - ;"]" - ;"{" - ;"}" - ;";" - ;"," + '( "(" + ")" + "[" + "]" + "{" + "}" + ";" + "," ":" "<:" - ;"." - "?" + ;"\\." + ;"\\?" "=" "<" ">" - ;"+" + ;"\\+" "-" - "*" + ;"\\*" "/" "%" "**" "&" - ;"|" - ;"^" + "|" + ;"\\^" "<<" ">>" "<<>" @@ -106,18 +106,29 @@ "<>>=" "#=" )) + ;; xxx These still don't work: + (x-symbols-more + '( "\\." + "\\?" + "\\+" + "\\-" + "\\*" + "\\^" + )) ;; generate regex string for each category of keywords (x-types-regexp (regexp-opt x-types 'words)) (x-constant-regexp (regexp-opt x-constants 'words)) (x-keywords-regexp (regexp-opt x-keywords 'words)) - (x-symbols-regexp (regexp-opt x-symbols 'words)) + (x-symbols-regexp (regexp-opt x-symbols)) + (x-symbols-more-regexp (regexp-opt x-symbols-more)) ) ;; `( (,x-types-regexp . font-lock-type-face) (,x-constant-regexp . font-lock-constant-face) (,x-keywords-regexp . font-lock-keyword-face) - (,x-symbols-regexp . font-lock-keyword-face) + (,x-symbols-regexp . font-lock-builtin-face) + (,x-symbols-more-regexp . font-lock-builtin-face) ))) (define-derived-mode actorscript-mode From 189463d1bcfbfcd7542c4e7be127bd43de3d0c65 Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Fri, 8 Mar 2019 11:56:41 -0700 Subject: [PATCH 16/76] bright braces --- emacs/actorscript-mode.el | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/emacs/actorscript-mode.el b/emacs/actorscript-mode.el index 5bd83e5f4ca..39ded3f1ab3 100644 --- a/emacs/actorscript-mode.el +++ b/emacs/actorscript-mode.el @@ -55,14 +55,20 @@ "type" "var" "while" - "prim" )) + "prim" + )) + ;; Braces introduce blocks; it's nice to make them stand + ;; out more than ordinary symbols + (x-braces + '( "{" + "}")) (x-symbols '( "(" ")" "[" "]" - "{" - "}" + ;"{" + ;"}" ";" "," ":" @@ -119,6 +125,7 @@ (x-types-regexp (regexp-opt x-types 'words)) (x-constant-regexp (regexp-opt x-constants 'words)) (x-keywords-regexp (regexp-opt x-keywords 'words)) + (x-braces-regexp (regexp-opt x-braces)) (x-symbols-regexp (regexp-opt x-symbols)) (x-symbols-more-regexp (regexp-opt x-symbols-more)) ) @@ -127,6 +134,7 @@ (,x-types-regexp . font-lock-type-face) (,x-constant-regexp . font-lock-constant-face) (,x-keywords-regexp . font-lock-keyword-face) + (,x-braces-regexp . font-lock-keyword-face) (,x-symbols-regexp . font-lock-builtin-face) (,x-symbols-more-regexp . font-lock-builtin-face) ))) From 16f26cc1af51840a87d630000c1c9016cf175512 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 9 Mar 2019 17:07:16 +0100 Subject: [PATCH 17/76] make targets 'parallel' and 'quick', speed up regression testing (#186) * In the makefile there is now 'parallel' which runs all the tests in parallel, * and 'quick' which does the same, but without the `dvm` tests. * regression tests (via `nix`) are now running the `quick` target (with unlimited parallelism) * for testing also `dvm`, we run in `run-dfinity/` parallel with at most 8 jobs, as unlimited jobs cause problems It should be checked why `-j` for the latter causes failure (some traps appear duplicated in the logs). --- default.nix | 5 ++--- src/Makefile | 6 +++++- test/Makefile | 4 +++- test/dvm.sh | 10 ++++++---- test/quick.mk | 9 +++++++-- test/run-dfinity/ok/flatten-awaitables.dvm-run.ok | 2 +- test/run.sh | 3 ++- 7 files changed, 26 insertions(+), 13 deletions(-) diff --git a/default.nix b/default.nix index feee501f625..c843d6a9560 100644 --- a/default.nix +++ b/default.nix @@ -114,11 +114,10 @@ rec { patchShebangs . asc --version make -C samples ASC=asc all - make -C test/run VERBOSE=1 ASC=asc all - make -C test/fail VERBOSE=1 ASC=asc all + make -C test VERBOSE=1 ASC=asc quick '' + (if test-dvm then '' - make -C test/run-dfinity VERBOSE=1 ASC=asc all + make --load-average -j8 -C test/run-dfinity VERBOSE=1 ASC=asc quick '' else ""); installPhase = '' diff --git a/src/Makefile b/src/Makefile index fd811340b00..57286cf567e 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,10 +21,11 @@ OCAMLBUILD = ocamlbuild $(OCAML_FLAGS) \ $(OPAM_PACKAGES:%=-pkg %) \ -tags debug -.PHONY: all quick clean test test-quick +.PHONY: all parallel quick clean test test-parallel test-quick all: $(NAME) test +parallel: $(NAME) test-parallel quick: $(NAME) test-quick $(NAME): $(MAIN).$(BUILD) @@ -55,5 +56,8 @@ test: $(NAME) accept: $(NAME) $(MAKE) -C ../test ASC=$(ASC) accept +test-parallel: $(NAME) + $(MAKE) -C ../test ASC=$(ASC) parallel + test-quick: $(NAME) $(MAKE) -C ../test ASC=$(ASC) quick diff --git a/test/Makefile b/test/Makefile index 19b6c2eec37..3163c044c2f 100644 --- a/test/Makefile +++ b/test/Makefile @@ -6,7 +6,9 @@ all: quick: $(MAKE) --no-print-directory --load-average -j -C fail quick $(MAKE) --no-print-directory --load-average -j -C run quick - $(MAKE) --no-print-directory --load-average -j -C run-dfinity _out/chatpp.done + +parallel: quick + $(MAKE) --no-print-directory --load-average -j -C run-dfinity quick coverage: rm -rf _coverage diff --git a/test/dvm.sh b/test/dvm.sh index 5ced2e91b6f..3af0e0e5468 100755 --- a/test/dvm.sh +++ b/test/dvm.sh @@ -2,11 +2,13 @@ if [ -z "$1" ] then - echo "Usage: $0 foo.wasm" + echo "Usage: $0 .wasm" exit 1 fi name="$(basename $1 .wasm)_0" +DVM_TMP=$(mktemp -d) +trap 'rm -rf $DVM_TMP' EXIT export LANG=C function dvm_ () { @@ -20,6 +22,6 @@ function dvm_ () { } -dvm_ -q reset -dvm_ -q new $1 -dvm_ -q run $name start +dvm_ -q --db $DVM_TMP reset +dvm_ -q --db $DVM_TMP new $1 +dvm_ -q --db $DVM_TMP run $name start diff --git a/test/quick.mk b/test/quick.mk index 274061b9433..73fc6def5a0 100644 --- a/test/quick.mk +++ b/test/quick.mk @@ -2,9 +2,14 @@ TO-TEST = $(patsubst %.as,_out/%.done,$(wildcard *.as)) +.PHONY: quick + quick: $(TO-TEST) +_out: + @ mkdir -p $@ + # run single test, e.g. make _out/AST-56.done -_out/%.done: %.as $(ASC) ../run.sh - @ mkdir -p _out +.SECONDEXPANSION: +_out/%.done: %.as $$(wildcard $(ASC)) ../run.sh | _out @ (../run.sh $(RUNFLAGS) $< > $@.tmp && mv $@.tmp $@) || (cat $@.tmp; rm -f $@.tmp; false) diff --git a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok index b9d940dfe06..84cb71c9839 100644 --- a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok +++ b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok @@ -4,4 +4,4 @@ # Empty MaybeLocal. # -dvm.sh: line 12: Illegal instruction dvm $@ +dvm.sh: line 14: Illegal instruction dvm $@ diff --git a/test/run.sh b/test/run.sh index 45d22c0372f..dbd3fbd81ce 100755 --- a/test/run.sh +++ b/test/run.sh @@ -8,9 +8,10 @@ # # -a: Update the files in ok/ # -d: Compile with --dfinity, use dvm to run +# -s: Be silent in sunny-day execution # -realpath() { +function realpath() { [[ $1 = /* ]] && echo "$1" || echo "$PWD/${1#./}" } From f2f213cff44e42a9ae290a188c883feffb45181c Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Mon, 11 Mar 2019 08:02:33 -0600 Subject: [PATCH 18/76] Desugar loops (#191) desugar various loop forms. --- src/construct.ml | 86 +++++++++++++++++-- src/construct.mli | 3 + src/desugar.ml | 6 +- .../ok/counter-class.wasm.stderr.ok | 10 +-- test/run/control.as | 20 ++++- 5 files changed, 110 insertions(+), 15 deletions(-) diff --git a/src/construct.ml b/src/construct.ml index 567dc8a18b9..d2f9b1f6490 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -236,6 +236,14 @@ let loopE exp1 exp2Opt = S.note_typ = Type.Non } } +(* Used to desugar for loops, while loops and loop-while loops. *) +let loopE' exp = + { it = LoopE (exp, None); + at = no_region; + note = { S.note_eff = eff exp ; + S.note_typ = T.Non } + } + let declare_idE x typ exp1 = { it = DeclareE (x, typ, exp1); at = no_region; @@ -270,15 +278,17 @@ let expD exp = let pat = { it = WildP; at = exp.at; note = exp.note.note_typ } in LetD (pat, exp) @@ exp.at +(* Derived expressions *) + +let letE x exp1 exp2 = blockE [letD x exp1] exp2 + +let thenE exp1 exp2 = blockE [expD exp1] exp2 + let ignoreE exp = if typ exp = T.unit then exp - else blockE [expD exp] (tupE []) - + else thenE exp (tupE []) -(* let expressions (derived) *) - -let letE x exp1 exp2 = blockE [letD x exp1] exp2 (* Mono-morphic function expression *) let funcE name t x exp = @@ -400,3 +410,69 @@ let prim_async typ = let prim_await typ = primE "@await" (T.Func (T.Local, T.Returns, [], [T.Async typ; contT typ], [])) + +(* derived loop forms; each can be expressed as an unconditional loop *) + +let whileE exp1 exp2 = + (* while e1 e2 + ~~> label l loop { + if e1 then { e2 } else { break l } + } + *) + let lab = fresh_id () in + labelE lab T.unit ( + loopE' ( + ifE exp1 + exp2 + (breakE lab (tupE [])) + T.unit + ) + ) + +let loopWhileE exp1 exp2 = + (* loop e1 while e2 + ~~> label l loop { + let () = e1 ; + if e2 { } else { break l } + } + *) + let lab = fresh_id () in + labelE lab T.unit ( + loopE' ( + thenE exp1 + ( ifE exp2 + (tupE []) + (breakE lab (tupE [])) + T.unit + ) + ) + ) + +let forE pat exp1 exp2 = + (* for p in e1 e2 + ~~> + let nxt = e1.next ; + label l loop { + switch nxt () { + case null { break l }; + case p { e2 }; + } + } *) + let lab = fresh_id () in + let ty1 = exp1.note.S.note_typ in + let _, tfs = Type.as_obj_sub "next" ty1 in + let tnxt = T.lookup_field "next" tfs in + let ty1_ret = match (T.as_func tnxt) with + | _,_,_,_,[x] -> x + | _ -> failwith "invalid return type" + in + let nxt = fresh_var tnxt in + letE nxt (dotE exp1 (nameN "next") tnxt) ( + labelE lab Type.unit ( + loopE' ( + switch_optE (callE nxt [] (tupE []) ty1_ret) + (breakE lab (tupE [])) + pat exp2 Type.unit + ) + ) + ) diff --git a/src/construct.mli b/src/construct.mli index 1ee80960918..073f732bf26 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -61,6 +61,9 @@ val immuteE: exp -> exp val assignE : exp -> exp -> exp val labelE : id -> typ -> exp -> exp val loopE : exp -> exp option -> exp +val forE : pat -> exp -> exp -> exp +val loopWhileE : exp -> exp -> exp +val whileE : exp -> exp -> exp val declare_idE : id -> typ -> exp -> exp val define_idE : id -> mut -> exp -> exp diff --git a/src/desugar.ml b/src/desugar.ml index dbdfc8347d8..aaa586d8fa2 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -69,10 +69,10 @@ and exp' at note = function | S.OrE (e1, e2) -> I.IfE (exp e1, trueE, 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.WhileE (e1, e2) -> (whileE (exp e1) (exp e2)).it | 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.LoopE (e1, Some e2) -> (loopWhileE (exp e1) (exp e2)).it + | S.ForE (p, e1, e2) -> (forE (pat p) (exp e1) (exp e2)).it | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp e) | S.BreakE (l, e) -> I.BreakE (l, exp e) | S.RetE e -> I.RetE (exp e) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 0e471e1e485..228392766dd 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -19,7 +19,7 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (VarP $1) + (VarP $2) () (BlockE (LetD (TupP) (TupE)) @@ -28,16 +28,16 @@ non-closed actor: (ActorE (FuncE $lambda ( 1 -> 0) - (VarP $0) + (VarP $1) () - (CallE ( 1 -> 0) (VarE $0) (VarE c)) + (CallE ( 1 -> 0) (VarE $1) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (VarP $2) + (VarP $3) () - (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) + (CallE (shared 1 -> 0) (VarE $2) (VarE $3)) ) ) ) diff --git a/test/run/control.as b/test/run/control.as index f742c71e46b..a4eeab3dbc9 100644 --- a/test/run/control.as +++ b/test/run/control.as @@ -1,6 +1,6 @@ actor class Control() { - private condition() : Bool = false; + private condition() : Bool = false; testBlock() { label l1 { @@ -25,7 +25,7 @@ actor class Control() { else continue l; }; }; - + testLoopWhile() { label l loop { if true break l @@ -33,6 +33,22 @@ actor class Control() { } while (condition()); }; + testLoopWhile2() { + loop { } while (false); + }; + + testLoopWhile3() { + label l { + loop { } + while (false and true) + }; + }; + + testLoopWhile4() { + label l loop { + } while (true and false); + }; + testNestedWhile() { label l while (condition()) { if true break l From 2bdaa997e31b63f4746e68fc06826ed74f997c67 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 11 Mar 2019 17:20:47 +0100 Subject: [PATCH 19/76] Fix problems with Int heap management (#228) * Fix serialising code for Tagged.Int * A Tagged.Int is three words (including tag), so copy all three * Refactor common code in `serialize_go`. * Improve testcase and expose (unrelated) bug --- src/compile.ml | 29 +++++++++------------- test/run-dfinity/data-params.as | 1 + test/run-dfinity/ok/data-params.dvm-run.ok | 1 + test/run-dfinity/ok/data-params.run-ir.ok | 1 + test/run-dfinity/ok/data-params.run-low.ok | 1 + test/run-dfinity/ok/data-params.run.ok | 1 + 6 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 7a4c5423c2d..9ab6882d491 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2210,30 +2210,25 @@ module Serialization = struct Func.share_code1 env "serialize_go" ("x", I32Type) [I32Type] (fun env get_x -> let (set_copy, get_copy) = new_local env "x'" in - get_x ^^ - BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - ( get_x ) - ( get_x ^^ - Tagged.branch env (ValBlockType (Some I32Type)) - [ Tagged.Int, - Heap.alloc env 2l ^^ + let purely_data n = + Heap.alloc env n ^^ set_copy ^^ get_x ^^ get_copy ^^ - compile_unboxed_const 2l ^^ + compile_unboxed_const n ^^ Heap.memcpy_words_skewed env ^^ - get_copy - ; Tagged.Reference, - Heap.alloc env 2l ^^ set_copy ^^ - - get_x ^^ - get_copy ^^ - compile_unboxed_const 2l ^^ - Heap.memcpy_words_skewed env ^^ + get_copy in - get_copy + get_x ^^ + BitTagged.if_unboxed env (ValBlockType (Some I32Type)) + ( get_x ) + ( get_x ^^ + Tagged.branch env (ValBlockType (Some I32Type)) + [ Tagged.Int, purely_data 3l + ; Tagged.SmallWord, purely_data 2l + ; Tagged.Reference, purely_data 2l ; Tagged.Some, Opt.inject env ( get_x ^^ Opt.project ^^ diff --git a/test/run-dfinity/data-params.as b/test/run-dfinity/data-params.as index 514bab82b0e..1d3359a7e43 100644 --- a/test/run-dfinity/data-params.as +++ b/test/run-dfinity/data-params.as @@ -71,3 +71,4 @@ a.printCounter(); a.printLabeled("Foo1: "); a.printLabeledOpt(?"Foo2: "); // a.readCounter(func (n : Nat) = { printInt n; print("\n") }); +a.incn(10000000000000); diff --git a/test/run-dfinity/ok/data-params.dvm-run.ok b/test/run-dfinity/ok/data-params.dvm-run.ok index fb6b4a5a031..47fc97de9b1 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -15,3 +15,4 @@ Top-level code done. 1006171 Foo1: 1006171 Foo2: 1006171 +1317141083 diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index d1d7763fa15..25d47d7f7f0 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -15,3 +15,4 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va 1006171 Foo1: 1006171 Foo2: 1006171 +10000001006171 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index d1d7763fa15..25d47d7f7f0 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -15,3 +15,4 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va 1006171 Foo1: 1006171 Foo2: 1006171 +10000001006171 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index d1d7763fa15..25d47d7f7f0 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -15,3 +15,4 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va 1006171 Foo1: 1006171 Foo2: 1006171 +10000001006171 From 9e6bee72f2ba4d2d4edb3c688c9aac1fba0dc3c2 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 11 Mar 2019 23:18:19 +0100 Subject: [PATCH 20/76] Typos (#229) * A bunch if typos in `src/compile.ml` fixed * don't use term/adjective "shifted" for pointers --- src/compile.ml | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 9ab6882d491..86676964e5c 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -26,7 +26,7 @@ let (^^) = G.(^^) (* is this how we import a single operator from a module that let page_size = Int32.of_int (64*1024) (* -Pointers are shifted -1 relative to the actual offset. +Pointers are skewed (translated) -1 relative to the actual offset. See documentation of module BitTagged for more detail. *) let ptr_skew = -1l @@ -598,7 +598,7 @@ module Heap = struct let offset = Int32.(add (mul word_size i) ptr_unskew) in G.i (Store {ty = I32Type; align = 2; offset; sz = None}) - (* Although we occationally want to treat to of them as a 64 bit number *) + (* Although we occasionally want to treat two 32 bit fields as one 64 bit number *) let load_field64 (i : int32) : G.t = let offset = Int32.(add (mul word_size i) ptr_unskew) in @@ -803,7 +803,7 @@ module BitTagged = struct This means we can store a small unboxed scalar x as (x << 2), and still tell it apart from a pointer. - We actually use the *second* lowest bit to tell apointer apart from a + We actually use the *second* lowest bit to tell a pointer apart from a scalar. It means that 0 and 1 are also recognized as non-pointers, and we can use @@ -963,7 +963,7 @@ module Var = struct | Some (Deferred d) -> G.i Unreachable | None -> G.i Unreachable - (* Returns the payload (vanialla representation) *) + (* Returns the payload (vanilla representation) *) let get_val_vanilla env var = match E.lookup_var env var with | Some (Local i) -> G.i (LocalGet (nr i)) | Some (HeapInd (i, off)) -> G.i (LocalGet (nr i)) ^^ Heap.load_field off @@ -1015,7 +1015,7 @@ module Var = struct end (* Var *) module Opt = struct - (* The Option type. Not much intereting to see here *) + (* The Option type. Not much interesting to see here *) let payload_field = Tagged.header_size @@ -2039,7 +2039,7 @@ module Dfinity = struct G.i Unreachable let default_exports env = - (* these export seems to be wanted by the hypervisor/v8 *) + (* these exports seem to be wanted by the hypervisor/v8 *) E.add_export env (nr { name = explode "mem"; edesc = nr (MemoryExport (nr 0l)) @@ -2766,7 +2766,7 @@ module GC = struct (* Returns the new end of to_space *) (* Invariant: Must not be called on the same pointer twice. *) (* All pointers, including ptr_loc and space end markers, are skewed *) - let evacuate env = Func.share_code4 env "evaucate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> + let evacuate env = Func.share_code4 env "evacuate" (("begin_from_space", I32Type), ("begin_to_space", I32Type), ("end_to_space", I32Type), ("ptr_loc", I32Type)) [I32Type] (fun env get_begin_from_space get_begin_to_space get_end_to_space get_ptr_loc -> let (set_len, get_len) = new_local env "len" in let (set_new_ptr, get_new_ptr) = new_local env "new_ptr" in @@ -2839,7 +2839,7 @@ module GC = struct Heap.get_skewed_heap_ptr ^^ set_end_to_space ^^ - (* Common arguments for evalcuate *) + (* Common arguments for evacuate *) let evac get_ptr_loc = get_begin_from_space ^^ get_begin_to_space ^^ @@ -2848,7 +2848,7 @@ module GC = struct evacuate env ^^ set_end_to_space in - (* Go through the roots, and evacaute them *) + (* Go through the roots, and evacuate them *) ClosureTable.get_counter ^^ from_0_to_n env (fun get_i -> evac ( get_i ^^ @@ -2891,7 +2891,7 @@ module StackRep = struct open SR (* - Most expression have a “preferred”, most optimal, form. Hence, + Most expressions have a “preferred”, most optimal, form. Hence, compile_exp put them on the stack in that form, and also returns the form it chose. @@ -3562,7 +3562,7 @@ and compile_exp (env : E.t) exp = (* 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. - So let’s go with Vanialla. *) + So let’s go with Vanilla. *) SR.Vanilla, G.block_ (StackRep.to_block_type env SR.Vanilla) ( G.with_current_depth (fun depth -> @@ -3744,7 +3744,7 @@ and compile_exp_unit (env : E.t) exp = (* The compilation of declarations (and patterns!) needs to handle mutual recursion. -This requires conceptually thre passes: +This requires conceptually three passes: 1. First we need to collect all names bound in a block, and find locations for then (which extends the environment). The environment is extended monotonously: The type-checker ensures that From 9563d5415df28d416a59712ff018b6a18308aec0 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 12 Mar 2019 13:01:03 +0100 Subject: [PATCH 21/76] AST-33: Codegen for Char/Word8/16/32 and operations (#216) * AST-33: codegen for Word8/16/32 operations * maintain invariant, that for `Word8/16` the 24/16 LSB are zeroed * generate special code for Word8/16 infectious operations * add `Word16/32` test actor * add GC and serialisation support for SmallWord * mini-framework for polymorphic expansion * add exotic bitwise operations * `Char` codegen, conversions and operations --- src/compile.ml | 316 +++++++++++++----- src/prelude.ml | 28 ++ test/run-dfinity/data-params.as | 151 ++++++++- test/run-dfinity/ok/data-params.dvm-run.ok | 32 ++ test/run-dfinity/ok/data-params.run-ir.ok | 34 ++ test/run-dfinity/ok/data-params.run-low.ok | 34 ++ test/run-dfinity/ok/data-params.run.ok | 34 ++ test/run-dfinity/ok/data-params.tc.ok | 2 + .../run-dfinity/ok/data-params.wasm.stderr.ok | 2 + test/run/conversions.as | 22 ++ test/run/ok/bit-ops.wasm.stderr.ok | 76 ----- test/run/ok/literals.wasm-run.ok | 1 - test/run/ok/literals.wasm.stderr.ok | 3 - test/run/ok/numeric-ops.wasm.stderr.ok | 60 ---- test/run/ok/relational-ops.wasm.stderr.ok | 80 ----- test/run/ok/word-rotations.wasm-run.ok | 1 - test/run/ok/word-rotations.wasm.stderr.ok | 74 ---- test/run/ok/words.run-ir.ok | 8 + test/run/ok/words.run-low.ok | 8 + test/run/ok/words.run.ok | 8 + test/run/ok/words.wasm.stderr.ok | 79 ----- test/run/words.as | 126 ++++++- 22 files changed, 714 insertions(+), 465 deletions(-) delete mode 100644 test/run/ok/literals.wasm-run.ok delete mode 100644 test/run/ok/literals.wasm.stderr.ok delete mode 100644 test/run/ok/word-rotations.wasm-run.ok delete mode 100644 test/run/ok/word-rotations.wasm.stderr.ok delete mode 100644 test/run/ok/words.wasm.stderr.ok diff --git a/src/compile.ml b/src/compile.ml index 86676964e5c..e1fc14b1f09 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -396,7 +396,7 @@ 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_unboxed_one = compile_unboxed_const 1l LATER*) +let compile_unboxed_one = compile_unboxed_const 1l (* Some common arithmetic, used for pointer and index arithmetic *) let compile_op_const op i = @@ -437,7 +437,7 @@ let from_0_to_n env mk_body = let (set_n, get_n) = new_local env "n" in let (set_i, get_i) = new_local env "i" in set_n ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ set_i ^^ compile_while @@ -543,13 +543,13 @@ module Heap = struct (* Check that the new heap pointer is within the memory *) get_pages_needed ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.GtU)) ^^ G.if_ (ValBlockType None) ( get_pages_needed ^^ G.i MemoryGrow ^^ (* Check result *) - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtS)) ^^ G.if_ (ValBlockType None) (G.i Unreachable) G.nop ) G.nop @@ -781,8 +781,8 @@ module Bool = struct directly, and to use the booleans directly with WebAssembly’s If. *) let lit = function - | false -> compile_unboxed_const 0l - | true -> compile_unboxed_const 1l + | false -> compile_unboxed_zero + | true -> compile_unboxed_one end (* Bool *) @@ -930,7 +930,7 @@ module Var = struct let static_fun_pointer env fi = Tagged.obj env Tagged.Closure [ compile_unboxed_const fi; - compile_unboxed_const 0l (* number of parameters: none *) + compile_unboxed_zero (* number of parameters: none *) ] (* Local variables may in general be mutable (or at least late-defined). @@ -1264,8 +1264,7 @@ module BoxedSmallWord = struct get_i ^^ compile_elem ^^ Heap.store_field payload_field ^^ get_i - let box env = Func.share_code env "box_i32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + let box env = Func.share_code1 env "box_i32" ("n", I32Type) [I32Type] (fun env get_n -> get_n ^^ compile_unboxed_const (Int32.of_int (1 lsl 10)) ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ G.if_ (ValBlockType (Some I32Type)) @@ -1273,18 +1272,44 @@ module BoxedSmallWord = struct (compile_box env get_n) ) - let unbox env = Func.share_code env "unbox_i32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + let unbox env = Func.share_code1 env "unbox_i32" ("n", I32Type) [I32Type] (fun env get_n -> get_n ^^ BitTagged.if_unboxed env (ValBlockType (Some I32Type)) ( get_n ^^ BitTagged.untag_i32 env) ( get_n ^^ Heap.load_field payload_field) ) - (*let lit env n = compile_unboxed_const n ^^ box env*) + let _lit env n = compile_unboxed_const n ^^ box env end (* BoxedSmallWord *) +module UnboxedSmallWord = struct + (* While smaller-than-32bit words are treated as i32 from the WebAssembly perspective, + there are certain differences that are type based. This module provides helpers to abstract + over those. *) + + let shift_of_type = function + | Type.Word8 -> 24l + | Type.Word16 -> 16l + | _ -> 0l + + let bitwidth_mask_of_type = function + | Type.Word8 -> 0b111l + | Type.Word16 -> 0b1111l + | p -> todo "bitwidth_mask_of_type" (Arrange_type.prim p) 0l + + let const_of_type ty n = Int32.(shift_left n (to_int (shift_of_type ty))) + + let padding_of_type ty = Int32.(sub (const_of_type ty 1l) one) + + let mask_of_type ty = Int32.lognot (padding_of_type ty) + + let name_of_type ty seed = match Arrange.prim ty with + | Wasm.Sexpr.Atom s -> seed ^ "<" ^ s ^ ">" + | wtf -> todo "name_of_type" wtf seed + +end (* UnboxedSmallWord *) + (* Primitive functions *) module Prim = struct open Wasm.Values @@ -1305,26 +1330,36 @@ module Prim = struct ) ( get_i ) - let prim_word32toNat env = + (* The Word8 and Word16 bits sit in the MSBs of the i32, in this manner + we can perform almost all operations, with the exception of + - Mul (needs shr of one operand) + - Shr (needs masking of result) + - Rot (needs duplication into LSBs, masking of amount and masking of result) + - ctz (needs shr of operand or sub from result) + + Both Word8/16 easily fit into the vanilla stackrep, so no boxing is necessary. + This MSB-stored schema is also essentially what the interpreter is using. + *) + let prim_word32toNat = G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) - let prim_maskedWord32toNat mask env = - compile_unboxed_const mask ^^ - G.i (Binary (I32 I32Op.And)) ^^ - prim_word32toNat env - let prim_by_shiftWord32toInt b env = + let prim_shiftWordNtoI32 b = compile_unboxed_const b ^^ - G.i (Binary (I32 I32Op.Shl)) ^^ + G.i (Binary (I32 I32Op.ShrU)) + let prim_shiftWordNtoUnsigned b = + prim_shiftWordNtoI32 b ^^ + prim_word32toNat + let prim_word32toInt = + G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) + let prim_shiftWordNtoSigned b = compile_unboxed_const b ^^ G.i (Binary (I32 I32Op.ShrS)) ^^ - prim_word32toNat env - let prim_intToWord32 env = + prim_word32toInt + let prim_intToWord32 = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) - let prim_word32toInt env = - G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) - let prim_maskToWord32 mask env = - prim_intToWord32 env ^^ - compile_unboxed_const mask ^^ - G.i (Binary (I32 I32Op.And)) + let prim_shiftToWordN b = + prim_intToWord32 ^^ + compile_unboxed_const b ^^ + G.i (Binary (I32 I32Op.Shl)) end (* Prim *) module Object = struct @@ -1834,7 +1869,7 @@ module Tuple = struct (* 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 + let compile_unit = compile_unboxed_one (* Expects on the stack the pointer to the array. *) let load_n n = Heap.load_field (Int32.add Array.header_size n) @@ -2122,7 +2157,7 @@ module OrthogonalPersistence = struct set_i ^^ get_i ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) (* First run, call the start function *) @@ -2389,6 +2424,8 @@ module Serialization = struct Tagged.branch env (ValBlockType (Some I32Type)) [ Tagged.Int, compile_unboxed_const 3l + ; Tagged.SmallWord, + compile_unboxed_const 2l ; Tagged.Reference, compile_unboxed_const 2l ; Tagged.Some, @@ -2513,7 +2550,7 @@ module Serialization = struct Func.share_code3 env "extract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [I32Type] (fun env get_start get_to get_tbl_area -> let (set_i, get_i) = new_local env "i" in - compile_unboxed_const 0l ^^ set_i ^^ + compile_unboxed_zero ^^ set_i ^^ walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ @@ -2593,7 +2630,7 @@ module Serialization = struct set_end ^^ (* Empty table of references *) - compile_unboxed_const 0l ^^ set_tbl_size + compile_unboxed_zero ^^ set_tbl_size ) (* We have real data on the heap. Copy. *) ( get_x ^^ @@ -2680,7 +2717,7 @@ module Serialization = struct (* First load databuf reference (last entry) at the heap position somehow *) (* now load the databuf *) get_start ^^ compile_add_const ptr_unskew ^^ - compile_unboxed_const 1l ^^ + compile_unboxed_one ^^ get_elembuf ^^ get_tbl_size ^^ compile_sub_const 1l ^^ G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ @@ -2698,7 +2735,7 @@ module Serialization = struct get_start ^^ compile_add_const ptr_unskew ^^ get_data_len ^^ get_databuf ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ (* Check if we got something unboxed (data buf size 1 word) *) @@ -2727,7 +2764,7 @@ module Serialization = struct Heap.get_heap_ptr ^^ get_tbl_size ^^ compile_sub_const 1l ^^ get_elembuf ^^ - compile_unboxed_const 0l ^^ + compile_unboxed_zero ^^ G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ (* Fix references *) @@ -2909,6 +2946,7 @@ module StackRep = struct | Type.Prim Type.Nat -> UnboxedInt64 | Type.Prim Type.Int -> UnboxedInt64 | Type.Prim Type.Word32 -> UnboxedWord32 + | Type.Prim Type.(Word8 | Word16 | Char) -> Vanilla | Type.Prim Type.Text -> Vanilla | p -> todo "of_type" (Arrange_ir.typ p) Vanilla @@ -3285,9 +3323,18 @@ let compile_lit env lit = Syntax.(match lit with | NatLit n -> SR.UnboxedInt64, (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) + | Word8Lit n -> SR.Vanilla, + (try compile_unboxed_const (Value.Word8.to_bits n) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int (Value.Word8.to_bits n)); G.i Unreachable) + | Word16Lit n -> SR.Vanilla, + (try compile_unboxed_const (Value.Word16.to_bits n) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int (Value.Word16.to_bits n)); G.i Unreachable) | Word32Lit n -> SR.UnboxedWord32, (try compile_unboxed_const n - with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int n); G.i Unreachable) (* TODO: check we are 64 bit *) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int n); G.i Unreachable) + | CharLit c -> SR.Vanilla, + (try compile_unboxed_const Int32.(shift_left (of_int c) 8) + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" c; G.i Unreachable) | NullLit -> SR.Vanilla, Opt.null | TextLit t -> SR.Vanilla, Text.lit env t | _ -> todo "compile_lit" (Arrange.lit lit) (SR.Vanilla, G.i Unreachable) @@ -3305,41 +3352,50 @@ let compile_unop env t op = Syntax.(match op, t with get_n ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub)) ) - | NegOp, Type.Prim Type.Word16 -> - SR.UnboxedWord32, - Func.share_code env "neg16" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in - compile_unboxed_zero ^^ - get_n ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - compile_unboxed_const 0xFFFFl ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) - ) - | NegOp, Type.Prim Type.Word32 -> - SR.UnboxedWord32, - Func.share_code env "neg32" ["n", I32Type] [I32Type] (fun env -> - let get_n = G.i (LocalGet (nr 0l)) in + | NegOp, Type.Prim Type.(Word8 | Word16 | Word32) -> + StackRep.of_type t, + Func.share_code1 env "neg32" ("n", I32Type) [I32Type] (fun env get_n -> compile_unboxed_zero ^^ get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ) - | PosOp, Type.Prim (Type.Int | Type.Nat) -> + | NotOp, Type.Prim Type.(Word8 | Word16 | Word32 as ty) -> + StackRep.of_type t, compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Xor)) + | PosOp, Type.Prim Type.(Int | Nat) -> SR.UnboxedInt64, G.nop - | PosOp, Type.Prim (Type.Word8 | Type.Word16 | Type.Word32) -> - SR.UnboxedWord32, + | PosOp, Type.Prim Type.(Word8 | Word16 | Word32) -> + StackRep.of_type t, G.nop | _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable) ) +(* Makes sure that we only shift/rotate the maximum number of bits available in the word. *) +let clamp_shift_amount = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (UnboxedSmallWord.bitwidth_mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + +(* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *) +let lsb_adjust = function + | Type.Word32 -> G.nop + | ty -> Prim.prim_shiftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) + +(* Makes sure that the word representation invariant is restored. *) +let sanitize_word_result = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + (* 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 t op = +let rec compile_binop env t op = StackRep.of_type t, Syntax.(match t, op with - | Type.Prim Type.Nat, AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Prim Type.(Nat | Int), AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) | Type.Prim Type.Nat, SubOp -> Func.share_code2 env "nat_sub" (("n1", I64Type), ("n2", I64Type)) [I64Type] (fun env get_n1 get_n2 -> get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ @@ -3347,14 +3403,66 @@ let compile_binop env t op = (G.i Unreachable) (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) ) - | Type.Prim Type.Nat, MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.Prim Type.(Nat | Int), 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.DivS)) | Type.Prim Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemS)) + + | Type.Prim Type.(Word8 | Word16 | Word32), AddOp -> G.i (Binary (Wasm.Values.I32 I32Op.Add)) + | Type.Prim Type.(Word8 | Word16 | Word32), SubOp -> G.i (Binary (Wasm.Values.I32 I32Op.Sub)) + | Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> lsb_adjust ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Mul)) + | Type.Prim Type.(Word8 | Word16 | Word32), DivOp -> G.i (Binary (Wasm.Values.I32 I32Op.DivU)) + | Type.Prim Type.(Word8 | Word16 | Word32), ModOp -> G.i (Binary (Wasm.Values.I32 I32Op.RemU)) + | Type.(Prim (Word8|Word16|Word32 as ty)), PowOp -> + let rec pow () = Func.share_code2 env (UnboxedSmallWord.name_of_type ty "pow") + (("n", I32Type), ("exp", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_exp -> + let one = compile_unboxed_const (UnboxedSmallWord.const_of_type ty 1l) in + let (set_res, get_res) = new_local env "res" in + let mul = snd (compile_binop env t MulOp) in + let square_recurse_with_shifted sanitize = + get_n ^^ get_exp ^^ compile_unboxed_const 1l ^^ + G.i (Binary (I32 I32Op.ShrU)) ^^ sanitize ^^ + pow () ^^ set_res ^^ get_res ^^ get_res ^^ mul + in get_exp ^^ G.i (Test (I32 I32Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedWord32) + one + (get_exp ^^ one ^^ G.i (Binary (I32 I32Op.And)) ^^ G.i (Test (I32 I32Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedWord32) + (square_recurse_with_shifted G.nop) + (get_n ^^ + square_recurse_with_shifted (sanitize_word_result ty) ^^ + mul))) + in pow () + | Type.Prim Type.(Word8 | Word16 | Word32), AndOp -> G.i (Binary (Wasm.Values.I32 I32Op.And)) + | Type.Prim Type.(Word8 | Word16 | Word32), OrOp -> G.i (Binary (Wasm.Values.I32 I32Op.Or)) + | Type.Prim Type.(Word8 | Word16 | Word32), XorOp -> G.i (Binary (Wasm.Values.I32 I32Op.Xor)) + | Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> + clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + | Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> + clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ + sanitize_word_result ty + | Type.Prim Type. Word32, RotLOp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotl)) + | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> + Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_by -> + let beside_adjust = compile_unboxed_const (Int32.sub 32l (UnboxedSmallWord.shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in + get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^ + get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^ + sanitize_word_result ty) + | Type.Prim Type. Word32, RotROp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) + | Type.Prim Type.(Word8 | Word16 as ty), RotROp -> + Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type] + Wasm.Values.(fun env get_n get_by -> + get_n ^^ get_n ^^ lsb_adjust ty ^^ G.i (Binary (I32 I32Op.Or)) ^^ + get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotr)) ^^ + sanitize_word_result ty) + | Type.Prim Type.Text, CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) ) @@ -3363,9 +3471,24 @@ let compile_eq env t = match t with | 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)) - | Type.Prim Type.Word32 -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + | Type.Prim Type.(Word8 | Word16 | Word32 | Char) -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | _ -> todo "compile_eq" (Arrange.relop Syntax.EqOp) (G.i Unreachable) +let get_relops = Syntax.(function + | GeOp -> I64Op.GeU, I64Op.GeS, I32Op.GeU, I32Op.GeS + | GtOp -> I64Op.GtU, I64Op.GtS, I32Op.GtU, I32Op.GtS + | LeOp -> I64Op.LeU, I64Op.LeS, I32Op.LeU, I32Op.LeS + | LtOp -> I64Op.LtU, I64Op.LtS, I32Op.LtU, I32Op.LtS + | _ -> failwith "uncovered relop") + +let compile_comparison t op = + let u64op, s64op, u32op, s32op = get_relops op + in Type.(match t with + | Nat -> G.i (Compare (Wasm.Values.I64 u64op)) + | Int -> G.i (Compare (Wasm.Values.I64 s64op)) + | (Word8 | Word16 | Word32 | Char) -> G.i (Compare (Wasm.Values.I32 u32op)) + | _ -> todo "compile_comparison" (Arrange.prim t) (G.i Unreachable)) + let compile_relop env t op = StackRep.of_type t, Syntax.(match t, op with @@ -3373,18 +3496,11 @@ let compile_relop env t op = | _, NeqOp -> compile_eq env t ^^ G.if_ (StackRep.to_block_type env SR.bool) (Bool.lit false) (Bool.lit true) - | 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)) + | Type.Prim Type.(Nat | Int | Word8 | Word16 | Word32 | Char as t1), op1 -> + compile_comparison t1 op1 | _ -> todo "compile_relop" (Arrange.relop op) (G.i Unreachable) ) - (* compile_lexp is used for expressions on the left of an assignment operator, produces some code (with side effect), and some pure code *) let rec compile_lexp (env : E.t) exp = @@ -3445,6 +3561,15 @@ and compile_exp (env : E.t) exp = match p with | "Array.init" -> Array.init env | "Array.tabulate" -> Array.tabulate env + | "shrs" -> + let (set_am, get_am) = new_local env "am" in + BoxedSmallWord.unbox env ^^ + set_am ^^ + BoxedSmallWord.unbox env ^^ + get_am ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + BoxedSmallWord.box env + | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end (* Unary prims *) @@ -3458,48 +3583,73 @@ and compile_exp (env : E.t) exp = | "Nat->Word8" | "Int->Word8" -> - SR.UnboxedWord32, + SR.Vanilla, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_maskToWord32 0xFFl env + Prim.prim_shiftToWordN (UnboxedSmallWord.shift_of_type Type.Word8) | "Nat->Word16" | "Int->Word16" -> - SR.UnboxedWord32, + SR.Vanilla, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_maskToWord32 0xFFFFl env + Prim.prim_shiftToWordN (UnboxedSmallWord.shift_of_type Type.Word16) | "Nat->Word32" | "Int->Word32" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedInt64 e ^^ - Prim.prim_intToWord32 env + Prim.prim_intToWord32 + + | "Char->Word32" -> + SR.UnboxedWord32, + compile_exp_vanilla env e ^^ + compile_unboxed_const 8l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) | "Word8->Nat" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_maskedWord32toNat 0xFFl env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoUnsigned (UnboxedSmallWord.shift_of_type Type.Word8) | "Word8->Int" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_by_shiftWord32toInt 24l env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoSigned (UnboxedSmallWord.shift_of_type Type.Word8) | "Word16->Nat" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_maskedWord32toNat 0xFFFFl env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoUnsigned (UnboxedSmallWord.shift_of_type Type.Word16) | "Word16->Int" -> SR.UnboxedInt64, - compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_by_shiftWord32toInt 16l env + compile_exp_vanilla env e ^^ + Prim.prim_shiftWordNtoSigned (UnboxedSmallWord.shift_of_type Type.Word16) | "Word32->Nat" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_word32toNat env + Prim.prim_word32toNat | "Word32->Int" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedWord32 e ^^ - Prim.prim_word32toInt env + Prim.prim_word32toInt + + | "Word32->Char" -> + SR.Vanilla, + compile_exp_as env SR.UnboxedWord32 e ^^ + compile_unboxed_const 8l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + + | "popcnt" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedWord32 e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | "clz" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedWord32 e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "ctz" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedWord32 e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) | "printInt" -> SR.unit, @@ -3691,7 +3841,7 @@ and compile_exp (env : E.t) exp = 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 ] ^^ + Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ] ^^ G.i (LocalSet (nr i)) ^^ code | DefineE (name, _, e) -> diff --git a/src/prelude.ml b/src/prelude.ml index 298f76496e7..11bd6da7bfc 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -50,6 +50,15 @@ func word32ToNat(n : Word32) : Nat = (prim "Word32->Nat" : Word32 -> Nat) n; func intToWord32(n : Int) : Word32 = (prim "Int->Word32" : Int -> Word32) n; func word32ToInt(n : Word32) : Int = (prim "Word32->Int" : Word32 -> Int) n; +func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; +func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; + +// Exotic bitwise operations +func shrsWord32(w : Word32, amount : Word32) : Word32 = (prim "shrs" : (Word32, Word32) -> Word32) (w, amount); +func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; +func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; +func ctzWord32(w : Word32) : Word32 = (prim "ctz" : Word32 -> Word32) w; + // This would be nicer as a objects, but lets do them as functions // until the compiler has a concept of “static objects” @@ -141,6 +150,25 @@ let prim = function in k (Int (Big_int.big_int_of_int i)) | "Word32->Int" -> fun v k -> k (Int (Big_int.big_int_of_int32 (as_word32 v))) + | "Char->Word32" -> fun v k -> + let i = as_char v + in k (Word32 (Word32.of_int_u i)) + | "Word32->Char" -> fun v k -> + let i = Conv.of_signed_Word32 (as_word32 v) + in k (Char i) + | "shrs" -> fun v k -> + let w, a = as_pair v in + let i = Word32.shr_s (as_word32 w) (as_word32 a) + in k (Word32 i) + | "popcnt" -> fun v k -> + let i = Word32.popcnt (as_word32 v) + in k (Word32 i) + | "clz" -> fun v k -> + let i = Word32.clz (as_word32 v) + in k (Word32 i) + | "ctz" -> fun v k -> + let i = Word32.ctz (as_word32 v) + in k (Word32 i) | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit | "Array.init" -> fun v k -> diff --git a/test/run-dfinity/data-params.as b/test/run-dfinity/data-params.as index 1d3359a7e43..cfa7fc937f6 100644 --- a/test/run-dfinity/data-params.as +++ b/test/run-dfinity/data-params.as @@ -10,7 +10,7 @@ let a = actor { printInt(c); print("\n"); }; - incnested(n1 : Nat, (n2 : Nat, n3: Nat)) : () { + incnested(n1 : Nat, (n2 : Nat, n3 : Nat)) : () { c += n1 + n2 + n3; printInt(c); print("\n"); @@ -72,3 +72,152 @@ a.printLabeled("Foo1: "); a.printLabeledOpt(?"Foo2: "); // a.readCounter(func (n : Nat) = { printInt n; print("\n") }); a.incn(10000000000000); + + +let w32 = actor { + private var c : Word32 = 0; + incn(n : Word32) : () { + c += n; + printInt(word32ToInt(c)); + print("\n"); + }; + incnn(n1 : Word32, n2 : Word32) : () { + c += n1 + n2; + printInt(word32ToInt(c)); + print("\n"); + }; + incnested(n1 : Word32, (n2 : Word32, n3 : Word32)) : () { + c += n1 + n2 + n3; + printInt(word32ToInt(c)); + print("\n"); + }; + incarray(a : [Word32]) : () { + for (i in a.vals()) { c += i }; + printInt(word32ToInt(c)); + print("\n"); + }; + incopt(a : ?Word32) : () { + switch a { + case null { c += 1000000 }; + case (?a) { c += a }; + }; + printInt(word32ToInt(c)); + print("\n"); + }; + increcord(a : shared { x : Word32; y : Word32 }) : () { + c += a.x; + c += a.y; + printInt(word32ToInt(c)); + print("\n"); + }; + printCounter() { + printInt(word32ToInt(c)); + print("\n"); + }; + printLabeled(l:Text) { + print l; + printInt(word32ToInt(c)); + print("\n"); + }; + printLabeledOpt(?l:?Text) { + print l; + printInt(word32ToInt(c)); + print("\n"); + }; + readCounter(f : shared Word32 -> ()) : () { + f(c); + }; +}; + + +w32.incn(1); +w32.incn(2); +w32.incn(3); +w32.incn(4); +w32.incn(1000); +w32.incnn(5,6); +w32.incnn(2000,3000); +w32.incnested(7,(8,9)); +w32.incarray([10,11,12,13]); +w32.incopt(null); +w32.incopt(?14); +w32.increcord(shared {x = 15 : Word32; y = 16 : Word32}); +w32.increcord(shared {x = 17 : Word32; y = 18 : Word32; z = 19 : Word32}); +w32.printCounter(); +w32.printLabeled("Foo1: "); +w32.printLabeledOpt(?"Foo2: "); + + + +let w16 = actor { + private var c : Word16 = 0; + incn(n : Word16) : () { + c += n; + printInt(word16ToInt(c)); + print("\n"); + }; + incnn(n1 : Word16, n2 : Word16) : () { + c += n1 + n2; + printInt(word16ToInt(c)); + print("\n"); + }; + incnested(n1 : Word16, (n2 : Word16, n3 : Word16)) : () { + c += n1 + n2 + n3; + printInt(word16ToInt(c)); + print("\n"); + }; + incarray(a : [Word16]) : () { + for (i in a.vals()) { c += i }; + printInt(word16ToInt(c)); + print("\n"); + }; + incopt(a : ?Word16) : () { + switch a { + case null { c += 10000 }; + case (?a) { c += a }; + }; + printInt(word16ToInt(c)); + print("\n"); + }; + increcord(a : shared { x : Word16; y : Word16 }) : () { + c += a.x; + c += a.y; + printInt(word16ToInt(c)); + print("\n"); + }; + printCounter() { + printInt(word16ToInt(c)); + print("\n"); + }; + printLabeled(l:Text) { + print l; + printInt(word16ToInt(c)); + print("\n"); + }; + printLabeledOpt(?l:?Text) { + print l; + printInt(word16ToInt(c)); + print("\n"); + }; + readCounter(f : shared Word16 -> ()) : () { + f(c); + }; +}; + + +w16.incn(1); +w16.incn(2); +w16.incn(3); +w16.incn(4); +w16.incn(1000); +w16.incnn(5,6); +w16.incnn(2000,3000); +w16.incnested(7,(8,9)); +w16.incarray([10,11,12,13]); +w16.incopt(null); +w16.incopt(?14); +w16.increcord(shared {x = 15 : Word16; y = 16 : Word16}); +w16.increcord(shared {x = 17 : Word16; y = 18 : Word16; z = 19 : Word16}); +w16.printCounter(); +w16.printLabeled("Foo1: "); +w16.printLabeledOpt(?"Foo2: "); diff --git a/test/run-dfinity/ok/data-params.dvm-run.ok b/test/run-dfinity/ok/data-params.dvm-run.ok index 47fc97de9b1..9884ed33c7f 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -16,3 +16,35 @@ Top-level code done. Foo1: 1006171 Foo2: 1006171 1317141083 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index 25d47d7f7f0..f879c2bfdac 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -1,4 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values +data-params.as:122.19-122.27: warning, this pattern does not cover all possible values +data-params.as:197.19-197.27: warning, this pattern does not cover all possible values 1 3 6 @@ -16,3 +18,35 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va Foo1: 1006171 Foo2: 1006171 10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index 25d47d7f7f0..f879c2bfdac 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -1,4 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values +data-params.as:122.19-122.27: warning, this pattern does not cover all possible values +data-params.as:197.19-197.27: warning, this pattern does not cover all possible values 1 3 6 @@ -16,3 +18,35 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va Foo1: 1006171 Foo2: 1006171 10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index 25d47d7f7f0..f879c2bfdac 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -1,4 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values +data-params.as:122.19-122.27: warning, this pattern does not cover all possible values +data-params.as:197.19-197.27: warning, this pattern does not cover all possible values 1 3 6 @@ -16,3 +18,35 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible va Foo1: 1006171 Foo2: 1006171 10000001006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +1006091 +1006105 +1006136 +1006171 +1006171 +Foo1: 1006171 +Foo2: 1006171 +1 +3 +6 +10 +1010 +1021 +6021 +6045 +6091 +16091 +16105 +16136 +16171 +16171 +Foo1: 16171 +Foo2: 16171 diff --git a/test/run-dfinity/ok/data-params.tc.ok b/test/run-dfinity/ok/data-params.tc.ok index bad5a00208d..1db161147e8 100644 --- a/test/run-dfinity/ok/data-params.tc.ok +++ b/test/run-dfinity/ok/data-params.tc.ok @@ -1 +1,3 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values +data-params.as:122.19-122.27: warning, this pattern does not cover all possible values +data-params.as:197.19-197.27: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/data-params.wasm.stderr.ok b/test/run-dfinity/ok/data-params.wasm.stderr.ok index bad5a00208d..1db161147e8 100644 --- a/test/run-dfinity/ok/data-params.wasm.stderr.ok +++ b/test/run-dfinity/ok/data-params.wasm.stderr.ok @@ -1 +1,3 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values +data-params.as:122.19-122.27: warning, this pattern does not cover all possible values +data-params.as:197.19-197.27: warning, this pattern does not cover all possible values diff --git a/test/run/conversions.as b/test/run/conversions.as index 35feabe47ec..cd1cf3c2021 100644 --- a/test/run/conversions.as +++ b/test/run/conversions.as @@ -135,3 +135,25 @@ println(word32ToInt 4294967295); // == (-1) // 2**32 - 1 roundtrip (-100000000); roundtrip (-1000000000); }; + + + + +// Char <--> Word32 + +assert(charToWord32 '\u{00}' == (0 : Word32)); +assert(charToWord32 '*' == (42 : Word32)); +assert(charToWord32 '\u{ffff}' == (65535 : Word32)); // 2**16 - 1 +assert(charToWord32 '\u{10ffff}' == (0x10FFFF : Word32)); + +{ + func roundtrip(w : Word32) = assert (charToWord32 (word32ToChar w) == w); + roundtrip 0; + roundtrip 10; + roundtrip 100; + roundtrip 1000; + roundtrip 10000; + roundtrip 100000; + roundtrip 1000000; + roundtrip 0x10FFFF; // largest code point +} diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok index 2a9d2f8f16e..1f8ac7bdc39 100644 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ b/test/run/ok/bit-ops.wasm.stderr.ok @@ -1,82 +1,6 @@ compile_unop: NotOp compile_unop: NotOp compile_binop: OrOp -of_type: Word8 -compile_binop: OrOp -of_type: Word8 -compile_binop: AndOp -of_type: Word8 -compile_binop: AndOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -of_type: Word16 -compile_binop: OrOp -of_type: Word16 -compile_binop: AndOp -of_type: Word16 -compile_binop: AndOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -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 of_type: Word64 compile_binop: OrOp of_type: Word64 diff --git a/test/run/ok/literals.wasm-run.ok b/test/run/ok/literals.wasm-run.ok deleted file mode 100644 index 11a148f71ae..00000000000 --- a/test/run/ok/literals.wasm-run.ok +++ /dev/null @@ -1 +0,0 @@ -_out/literals.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/literals.wasm.stderr.ok b/test/run/ok/literals.wasm.stderr.ok deleted file mode 100644 index db71b22da87..00000000000 --- a/test/run/ok/literals.wasm.stderr.ok +++ /dev/null @@ -1,3 +0,0 @@ -compile_lit: (Word8Lit 255) -compile_lit: (Word16Lit 6_5535) -compile_lit: (CharLit 2612) diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index 2230f1fa5ce..bf44ccb511d 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -31,66 +31,6 @@ of_type: Float compile_binop: PowOp of_type: Float compile_binop: AddOp -of_type: Word8 -compile_binop: AddOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_binop: AddOp -of_type: Word16 -compile_binop: AddOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_binop: AddOp -compile_binop: AddOp -compile_binop: SubOp -compile_binop: SubOp -compile_binop: MulOp -compile_binop: MulOp -compile_binop: DivOp -compile_binop: DivOp -compile_binop: ModOp -compile_binop: ModOp -compile_binop: PowOp -compile_binop: PowOp -compile_binop: AddOp of_type: Word64 compile_binop: AddOp of_type: Word64 diff --git a/test/run/ok/relational-ops.wasm.stderr.ok b/test/run/ok/relational-ops.wasm.stderr.ok index 339785ac3b0..3b0ee159540 100644 --- a/test/run/ok/relational-ops.wasm.stderr.ok +++ b/test/run/ok/relational-ops.wasm.stderr.ok @@ -23,62 +23,6 @@ of_type: Float compile_relop: GeOp of_type: Float compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_eq: EqOp -of_type: Word8 -compile_relop: LtOp -of_type: Word8 -compile_relop: LtOp -of_type: Word8 -compile_relop: LeOp -of_type: Word8 -compile_relop: LeOp -of_type: Word8 -compile_relop: GtOp -of_type: Word8 -compile_relop: GtOp -of_type: Word8 -compile_relop: GeOp -of_type: Word8 -compile_relop: GeOp -of_type: Word8 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_eq: EqOp -of_type: Word16 -compile_relop: LtOp -of_type: Word16 -compile_relop: LtOp -of_type: Word16 -compile_relop: LeOp -of_type: Word16 -compile_relop: LeOp -of_type: Word16 -compile_relop: GtOp -of_type: Word16 -compile_relop: GtOp -of_type: Word16 -compile_relop: GeOp -of_type: Word16 -compile_relop: GeOp -of_type: Word16 -compile_relop: LtOp -compile_relop: LtOp -compile_relop: LeOp -compile_relop: LeOp -compile_relop: GtOp -compile_relop: GtOp -compile_relop: GeOp -compile_relop: GeOp -compile_eq: EqOp of_type: Word64 compile_eq: EqOp of_type: Word64 @@ -102,30 +46,6 @@ compile_relop: GeOp of_type: Word64 compile_relop: GeOp of_type: Word64 -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_eq: EqOp -of_type: Char -compile_relop: LtOp -of_type: Char -compile_relop: LtOp -of_type: Char -compile_relop: LeOp -of_type: Char -compile_relop: LeOp -of_type: Char -compile_relop: GtOp -of_type: Char -compile_relop: GtOp -of_type: Char -compile_relop: GeOp -of_type: Char -compile_relop: GeOp -of_type: Char compile_relop: LtOp compile_relop: LtOp compile_relop: LeOp diff --git a/test/run/ok/word-rotations.wasm-run.ok b/test/run/ok/word-rotations.wasm-run.ok deleted file mode 100644 index 8f241da436a..00000000000 --- a/test/run/ok/word-rotations.wasm-run.ok +++ /dev/null @@ -1 +0,0 @@ -_out/word-rotations.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/ok/word-rotations.wasm.stderr.ok b/test/run/ok/word-rotations.wasm.stderr.ok deleted file mode 100644 index 4a2e9f4a79f..00000000000 --- a/test/run/ok/word-rotations.wasm.stderr.ok +++ /dev/null @@ -1,74 +0,0 @@ -compile_binop: RotROp -compile_binop: RotROp -compile_eq: EqOp -of_type: Word16 -compile_lit: (Word16Lit 5_4715) -compile_binop: RotROp -of_type: Word16 -compile_lit: (Word16Lit 4) -compile_lit: (Word16Lit 23_485) -compile_eq: EqOp -of_type: Word16 -compile_lit: (Word16Lit 5_4715) -compile_binop: RotROp -of_type: Word16 -compile_lit: (Word16Lit 20) -compile_lit: (Word16Lit 23_485) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 202) -compile_binop: RotROp -of_type: Word8 -compile_lit: (Word8Lit 3) -compile_lit: (Word8Lit 86) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 202) -compile_binop: RotROp -of_type: Word8 -compile_lit: (Word8Lit 11) -compile_lit: (Word8Lit 86) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 202) -compile_binop: RotROp -of_type: Word8 -compile_lit: (Word8Lit 19) -compile_lit: (Word8Lit 86) -compile_binop: RotLOp -compile_binop: RotLOp -compile_eq: EqOp -of_type: Word16 -compile_lit: (Word16Lit 4_8085) -compile_binop: RotLOp -of_type: Word16 -compile_lit: (Word16Lit 4) -compile_lit: (Word16Lit 23_485) -compile_eq: EqOp -of_type: Word16 -compile_lit: (Word16Lit 4_8085) -compile_binop: RotLOp -of_type: Word16 -compile_lit: (Word16Lit 20) -compile_lit: (Word16Lit 23_485) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 178) -compile_binop: RotLOp -of_type: Word8 -compile_lit: (Word8Lit 3) -compile_lit: (Word8Lit 86) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 178) -compile_binop: RotLOp -of_type: Word8 -compile_lit: (Word8Lit 11) -compile_lit: (Word8Lit 86) -compile_eq: EqOp -of_type: Word8 -compile_lit: (Word8Lit 178) -compile_binop: RotLOp -of_type: Word8 -compile_lit: (Word8Lit 19) -compile_lit: (Word8Lit 86) diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index e55f4fecf66..150b24d3944 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -1,5 +1,6 @@ 8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +12,16 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -30,6 +37,7 @@ 28083 28083 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index e55f4fecf66..150b24d3944 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -1,5 +1,6 @@ 8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +12,16 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -30,6 +37,7 @@ 28083 28083 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index e55f4fecf66..150b24d3944 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -1,5 +1,6 @@ 8912765 8912765 4286054531 -8912765 +4286054530 -8912766 8917332 8917332 8908198 8908198 31969 31969 @@ -11,10 +12,16 @@ 8908458 8908458 584576 584576 35 35 +4294967294 -2 +4218928893 -76038403 1140833920 1140833920 4194373630 -100593666 +29 29 +17 17 +5 5 55734 -9802 9802 9802 +9801 9801 60301 -5235 51167 -14369 31969 31969 @@ -30,6 +37,7 @@ 28083 28083 34 34 222 -34 +221 -35 101 101 223 -33 213 -43 diff --git a/test/run/ok/words.wasm.stderr.ok b/test/run/ok/words.wasm.stderr.ok deleted file mode 100644 index df2dd2439f9..00000000000 --- a/test/run/ok/words.wasm.stderr.ok +++ /dev/null @@ -1,79 +0,0 @@ -compile_binop: AddOp -compile_binop: SubOp -compile_binop: MulOp -compile_binop: DivOp -compile_binop: ModOp -compile_binop: PowOp -compile_binop: AndOp -compile_binop: OrOp -compile_binop: XorOp -compile_binop: ShiftLOp -compile_binop: ShiftROp -compile_binop: RotLOp -compile_binop: RotROp -compile_lit: (Word16Lit 4_567) -compile_lit: (Word16Lit 7) -compile_lit: (Word16Lit 5_5734) -compile_lit: (Word16Lit 15) -compile_lit: (Word16Lit 20_000) -compile_binop: AddOp -of_type: Word16 -compile_binop: SubOp -of_type: Word16 -compile_binop: MulOp -of_type: Word16 -compile_binop: DivOp -of_type: Word16 -compile_binop: ModOp -of_type: Word16 -compile_binop: PowOp -of_type: Word16 -compile_lit: (Word16Lit 2) -compile_binop: AndOp -of_type: Word16 -compile_binop: OrOp -of_type: Word16 -compile_binop: XorOp -of_type: Word16 -compile_binop: ShiftLOp -of_type: Word16 -compile_binop: ShiftROp -of_type: Word16 -compile_binop: RotLOp -of_type: Word16 -compile_binop: RotROp -of_type: Word16 -compile_lit: (Word8Lit 67) -compile_lit: (Word8Lit 7) -compile_lit: (Word8Lit 34) -compile_unop: NegOp -compile_lit: (Word8Lit 15) -compile_lit: (Word8Lit 200) -compile_unop: NegOp -compile_binop: AddOp -of_type: Word8 -compile_binop: SubOp -of_type: Word8 -compile_binop: MulOp -of_type: Word8 -compile_binop: DivOp -of_type: Word8 -compile_binop: ModOp -of_type: Word8 -compile_binop: PowOp -of_type: Word8 -compile_lit: (Word8Lit 2) -compile_binop: AndOp -of_type: Word8 -compile_binop: OrOp -of_type: Word8 -compile_binop: XorOp -of_type: Word8 -compile_binop: ShiftLOp -of_type: Word8 -compile_binop: ShiftROp -of_type: Word8 -compile_binop: RotLOp -of_type: Word8 -compile_binop: RotROp -of_type: Word8 diff --git a/test/run/words.as b/test/run/words.as index e2a2132b80b..f1c52165cee 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -1,3 +1,4 @@ +// CHECK: func $start // Word32 operations { func printW32ln(w : Word32) { printInt(word32ToNat w); print " "; printInt(word32ToInt w); print "\n" }; @@ -8,27 +9,58 @@ let d : Word32 = -15; let e : Word32 = 20000; - +// CHECK: get_local $c +// LATER: HECK-NOT: call $box_i32 +// CHECK: call $printW32ln printW32ln(+c); +// CHECK: call $printW32ln printW32ln(-c); +// CHECK: call $printW32ln + printW32ln(^c); +// CHECK: call $printW32ln printW32ln(a + c); +// CHECK: call $printW32ln printW32ln(c - a); + +// CHECK-NOT: i32.shr_u +// CHECK: call $printW32ln printW32ln(a * b); +// CHECK: call $printW32ln printW32ln(a / b); +// CHECK: call $printW32ln printW32ln(c % a); +// CHECK: call $printW32ln printW32ln(a ** 2); +// CHECK: call $printW32ln printW32ln(a & c); +// CHECK: call $printW32ln printW32ln(a | c); +// CHECK: call $printW32ln printW32ln(a ^ c); +// CHECK: call $printW32ln printW32ln(a << b); +// CHECK: call $printW32ln printW32ln(a >> b); - // printW32ln(shrs d b); // TODO(Gabor) +// CHECK: call $printW32ln + printW32ln(shrsWord32(d, 3)); +// CHECK: call $printW32ln + printW32ln(shrsWord32(-1216614433, 4)); // 0b10110111011110111110111111011111l == -1216614433l --> -76038403 +// CHECK: call $printW32ln printW32ln(c <<> b); +// CHECK: call $printW32ln printW32ln(c <>> b); - // printW32ln(lognot d); // TODO(Gabor) - // printW32ln(clz c); // TODO(Gabor) - // printW32ln(ctz e); // TODO(Gabor) +// CHECK: call $printW32ln + printW32ln(popcntWord32 d); // -15 = 0xfffffff1 = 0b1111_1111_1111_1111_1111_1111_1111_0001 (population = 29) +// CHECK: call $printW32ln + printW32ln(clzWord32 e); // 20000 = 0x00004e20 (leading zeros = 17) +// CHECK: call $printW32ln + printW32ln(ctzWord32 e); // 20000 = 0x00004e20 (trailing zeros = 5) + + assert (3 : Word32 ** (4 : Word32) == (81 : Word32)); + assert (3 : Word32 ** (7 : Word32) == (2187 : Word32)); + assert (3 : Word32 ** (14 : Word32) == (4782969 : Word32)); + assert (3 : Word32 ** (20 : Word32) == (3486784401 : Word32)); }; // Word16 operations @@ -42,26 +74,68 @@ let e : Word16 = 20000; +// CHECK: call $printW16ln printW16ln(+c); +// CHECK: call $printW16ln printW16ln(-c); +// CHECK: call $printW16ln + printW16ln(^c); +// CHECK: call $printW16ln printW16ln(a + c); +// CHECK: call $printW16ln printW16ln(c - a); + +// CHECK: get_local $a +// CHECK-NEXT: get_local $b +// CHECK-NEXT: i32.const 16 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.mul +// CHECK-NEXT: call $printW16ln printW16ln(a * b); +// CHECK: call $printW16ln printW16ln(a / b); +// CHECK: call $printW16ln printW16ln(c % a); +// CHECK: call $printW16ln printW16ln(a ** 2); +// CHECK: call $printW16ln printW16ln(a & c); +// CHECK: call $printW16ln printW16ln(a | c); +// CHECK: call $printW16ln printW16ln(a ^ c); +// CHECK: call $printW16ln printW16ln(a << b); + +// CHECK: get_local $b +// CHECK-NEXT: i32.const 15 +// CHECK-NEXT: i32.and +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.const -65536 +// CHECK-NEXT: i32.and +// CHECK-NEXT: call $printW16ln printW16ln(a >> b); // printW16ln(shrs d b); // TODO(Gabor) + +// CHECK: get_local $b +// CHECK-NEXT: call $rotl +// CHECK-NEXT: call $printW16ln printW16ln(c <<> b); + +// CHECK: get_local $b +// CHECK-NEXT: call $rotr +// CHECK-NEXT: call $printW16ln printW16ln(c <>> b); - // printW16ln(lognot d); // TODO(Gabor) + // printW16ln(popcnt d); // TODO(Gabor) // printW16ln(clz c); // TODO(Gabor) // printW16ln(ctz e); // TODO(Gabor) + + + assert (3 : Word16 ** (0 : Word16) == (1 : Word16)); + assert (3 : Word16 ** (1 : Word16) == (3 : Word16)); + assert (3 : Word16 ** (4 : Word16) == (81 : Word16)); + assert (3 : Word16 ** (7 : Word16) == (2187 : Word16)); }; // Word8 operations @@ -75,24 +149,62 @@ let e : Word8 = 200; +// CHECK: call $printW8ln printW8ln(+c); +// CHECK: call $printW8ln printW8ln(-c); +// CHECK: call $printW8ln + printW8ln(^c); +// CHECK: call $printW8ln printW8ln(a + c); +// CHECK: call $printW8ln printW8ln(c - a); +// CHECK: get_local $b +// CHECK-NEXT: i32.const 24 +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.mul +// CHECK-NEXT: call $printW8ln printW8ln(a * b); +// CHECK: call $printW8ln printW8ln(a / b); +// CHECK: call $printW8ln printW8ln(c % a); +// CHECK: call $printW8ln printW8ln(a ** 2); +// CHECK: call $printW8ln printW8ln(a & c); +// CHECK: call $printW8ln printW8ln(a | c); +// CHECK: call $printW8ln printW8ln(a ^ c); +// CHECK: call $printW8ln printW8ln(a << b); + +// CHECK: get_local $b +// CHECK-NEXT: i32.const 7 +// CHECK-NEXT: i32.and +// CHECK-NEXT: i32.shr_u +// CHECK-NEXT: i32.const -16777216 +// CHECK-NEXT: i32.and +// CHECK-NEXT: call $printW8ln printW8ln(a >> b); // printW8ln(shrs d b); // TODO(Gabor) + +// CHECK: get_local $b +// CHECK-NEXT: call $rotl +// CHECK-NEXT: call $printW8ln printW8ln(c <<> b); +// CHECK: get_local $b +// CHECK-NEXT: call $rotr +// CHECK-NEXT: call $printW8ln printW8ln(c <>> b); - // printW8ln(lognot d); // TODO(Gabor) + // printW8ln(popcnt d); // TODO(Gabor) // printW8ln(clz c); // TODO(Gabor) // printW8ln(ctz e); // TODO(Gabor) + + assert (3 : Word8 ** (0 : Word8) == (1 : Word8)); + assert (3 : Word8 ** (3 : Word8) == (27 : Word8)); + assert (3 : Word8 ** (4 : Word8) == (81 : Word8)); + assert (3 : Word8 ** (5 : Word8) == (243 : Word8)); }; From 21ee7ab157749f61866956ee1c10a8b7c36a7388 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Tue, 12 Mar 2019 14:45:04 +0100 Subject: [PATCH 22/76] M1-390 Fetch `dev` via nix (#227) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit so that we don’t have to deal with submodules. also bumps `dev` along the way, and updates output. It seems that the V8 bug (https://dfinity.atlassian.net/browse/M1-513) has gone away. --- .gitignore | 2 -- Jenkinsfile | 35 ------------------- README.md | 23 ------------ ci.nix | 5 +-- default.nix | 15 ++++---- .../ok/array-out-of-bounds.dvm-run.ok | 1 + .../ok/flatten-awaitables.dvm-run.ok | 11 +++--- test/run-dfinity/ok/overflow.dvm-run.ok | 1 + update-dvm.sh | 13 ------- 9 files changed, 16 insertions(+), 90 deletions(-) delete mode 100644 Jenkinsfile delete mode 100755 update-dvm.sh diff --git a/.gitignore b/.gitignore index 6782ebc900b..4bf016557dd 100644 --- a/.gitignore +++ b/.gitignore @@ -2,8 +2,6 @@ .dvm /result* -nix/dev-in-nix - **/*~ **/_build **/_output diff --git a/Jenkinsfile b/Jenkinsfile deleted file mode 100644 index da8573475b7..00000000000 --- a/Jenkinsfile +++ /dev/null @@ -1,35 +0,0 @@ -pipeline { - agent any - stages { - stage ('git submodule') { - 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 e588f0efa687667076dfab52fddde6ff29e0d82c' - sh 'git -C nix/dev submodule update --init --recursive' - } - } - - stage('Build (native)') { - steps { - sh 'nix-build -A native --arg test-dvm true' - } - } - stage('Test (native)') { - steps { - sh 'nix-build -A native_test --arg test-dvm true' - } - } - stage('Build and test (js)') { - steps { - sh 'nix-build -A js' - } - } - } - // Workspace Cleanup plugin - post { - always { - cleanWs() - } - } -} diff --git a/README.md b/README.md index 6496b1afd84..7bf10ac6076 100644 --- a/README.md +++ b/README.md @@ -13,21 +13,6 @@ To install the `asc` binary into your nix environment, use $ nix-env -i -f . -A native ``` -## Setup of `dev` - -Until we join the monorepo, we need a checkout the `dev` repository in -`nix/dev`; see the `Jenkinsfile` the precise revision to use. - -For a fresh checkout, run -``` -git clone --recursive git@github.com:dfinity-lab/dev nix/dev -git -C nix/dev checkout 2bc6…see…Jenkinsfile…fecd -git -C nix/dev submodule update --init --recursive -``` - -To update, just run the last two commands again. - - ## Development using Nix This is the command that should always pass on master is the following, which builds everything: @@ -78,16 +63,8 @@ installing all required tools without nix is out of scope). nix-env -i -f . -A wasm nix-env -i -f . -A filecheck nix-env -i -f . -A wabt - ``` - * Install the `dvm` tool, using - ``` nix-env -i -f . -A dvm ``` - or simply - ``` - ./update-dvm.sh - ``` - which also updates the `dev` checkout. ## Create a coverage report diff --git a/ci.nix b/ci.nix index 7453ecd04e5..e861ec7c2d9 100644 --- a/ci.nix +++ b/ci.nix @@ -1,4 +1 @@ -# We need to set test-dvm to false because hydra has -# no access to the `dev` repo. This can go away once we join -# the monorepo. -import ./default.nix { test-dvm = false; } +import ./default.nix { } diff --git a/default.nix b/default.nix index f1f1fc02e0a..6a910edcfcd 100644 --- a/default.nix +++ b/default.nix @@ -30,12 +30,13 @@ let real-dvm = then if test-dvm then - if !builtins.pathExists ./nix/dev/default.nix - then - throw "\"test-dvm = true\" requires a checkout of dev in ./nix.\nSee Jenkinsfile for the required revision. " - else - # Pass devel = true until the dev test suite runs on MacOS again - ((import ./nix/dev) { devel = true; }).dvm + let dev = builtins.fetchGit { + url = "ssh://git@github.com/dfinity-lab/dev"; + rev = "1ab8900eafb3a588372a9d71294df75b504539eb"; + ref = "master"; + }; in + # Pass devel = true until the dev test suite runs on MacOS again + (import dev { devel = true; }).dvm else null else dvm; in @@ -111,7 +112,7 @@ rec { nixpkgs.wabt nixpkgs.bash nixpkgs.perl - filecheck + filecheck ] ++ (if test-dvm then [ real-dvm ] else []); 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 index 4a1af3b7fa5..e6d1727cfb6 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1,2 +1,3 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable Top-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 84cb71c9839..c8ab234ed8e 100644 --- a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok +++ b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok @@ -1,7 +1,6 @@ +Top-level code done. -# -# Fatal error in v8::ToLocalChecked -# Empty MaybeLocal. -# - -dvm.sh: line 14: Illegal instruction dvm $@ +first-order +,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, +higher-order +,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok index 501d4e74886..5db4566da42 100644 --- a/test/run-dfinity/ok/overflow.dvm-run.ok +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -1,4 +1,5 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable Top-level code done. This is reachable. This is reachable. diff --git a/update-dvm.sh b/update-dvm.sh deleted file mode 100755 index 4e4aa39362d..00000000000 --- a/update-dvm.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -# This is a small convenience script that ensures that `nix/dev` is up-to-date - -set -e - -if [ ! -e nix/dev ] -then git clone --recursive git@github.com:dfinity-lab/dev nix/dev -else git -C nix/dev fetch -fi -$(grep checkout Jenkinsfile |cut -d\' -f2) -git -C nix/dev submodule update --init --recursive -nix-env -i -f . -A dvm From fdb4aca0efe67d22213a9bb2795b70a64b33b024 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 11 Mar 2019 15:09:51 +0100 Subject: [PATCH 23/76] Ir: Remove all loop forms but `LoopE exp --- src/arrange_ir.ml | 5 +-- src/async.ml | 8 +--- src/await.ml | 97 +++------------------------------------------ src/check_ir.ml | 36 +---------------- src/compile.ml | 58 +-------------------------- src/construct.ml | 20 +++------- src/construct.mli | 2 +- src/desugar.ml | 2 +- src/effect.ml | 7 +--- src/freevars.ml | 5 +-- src/interpret_ir.ml | 38 +----------------- src/ir.ml | 4 +- src/rename.ml | 6 +-- src/tailcall.ml | 15 +++---- 14 files changed, 30 insertions(+), 273 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index badcddbb85d..55342674817 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -25,10 +25,7 @@ let rec exp e = match e.it with | BlockE (ds, e1) -> "BlockE" $$ List.map dec ds @ [exp e1] | IfE (e1, e2, e3) -> "IfE" $$ [exp e1; exp e2; exp e3] | SwitchE (e, cs) -> "SwitchE" $$ [exp e] @ List.map case cs - | WhileE (e1, e2) -> "WhileE" $$ [exp e1; exp e2] - | LoopE (e1, None) -> "LoopE" $$ [exp e1] - | LoopE (e1, Some e2) -> "LoopE" $$ [exp e1; exp e2] - | ForE (p, e1, e2) -> "ForE" $$ [pat p; exp e1; exp e2] + | LoopE e1 -> "LoopE" $$ [exp e1] | LabelE (i, t, e) -> "LabelE" $$ [id i; typ t; exp e] | BreakE (i, e) -> "BreakE" $$ [id i; exp e] | RetE e -> "RetE" $$ [exp e] diff --git a/src/async.ml b/src/async.ml index 0925f758615..3ff158b8cac 100644 --- a/src/async.ml +++ b/src/async.ml @@ -304,12 +304,8 @@ module Transform() = struct cases in SwitchE (t_exp exp1, cases') - | WhileE (exp1, exp2) -> - WhileE (t_exp exp1, t_exp exp2) - | LoopE (exp1, exp2_opt) -> - LoopE (t_exp exp1, Lib.Option.map t_exp exp2_opt) - | ForE (pat, exp1, exp2) -> - ForE (t_pat pat, t_exp exp1, t_exp exp2) + | LoopE exp1 -> + LoopE (t_exp exp1) | LabelE (id, typ, exp1) -> LabelE (id, t_typ typ, t_exp exp1) | BreakE (id, exp1) -> diff --git a/src/await.ml b/src/await.ml index b35c5014fc4..c6403777e73 100644 --- a/src/await.ml +++ b/src/await.ml @@ -97,12 +97,8 @@ and t_exp' context exp' = cases in SwitchE (t_exp context exp1, cases') - | WhileE (exp1, exp2) -> - WhileE (t_exp context exp1, t_exp context exp2) - | LoopE (exp1, exp2_opt) -> - LoopE (t_exp context exp1, Lib.Option.map (t_exp context) exp2_opt) - | ForE (pat, exp1, exp2) -> - ForE (pat, t_exp context exp1, t_exp context exp2) + | LoopE exp1 -> + LoopE (t_exp context exp1) | LabelE (id, _typ, exp1) -> let context' = LabelEnv.add id.it Label context in LabelE (id, _typ, t_exp context' exp1) @@ -214,32 +210,7 @@ and c_if context k e1 e2 e3 = c_exp context e1 (meta (typ e1) (fun v1 -> ifE v1 e2 e3 answerT)) ) -and c_while context k e1 e2 = - let loop = fresh_var (contT T.unit) in - let v2 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> loop -*- t_exp context e2 - | T.Await -> c_exp context e2 (ContVar loop) - in - match eff e1 with - | T.Triv -> - blockE [funcD loop v2 - (ifE (t_exp context e1) - e2 - (k -@- unitE) - answerT)] - (loop -*- unitE) - | T.Await -> - blockE [funcD loop v2 - (c_exp context e1 (meta (T.bool) - (fun v1 -> - ifE v1 - e2 - (k -@- unitE) - answerT)))] - (loop -*- unitE) - -and c_loop_none context k e1 = +and c_loop context k e1 = let loop = fresh_var (contT T.unit) in match eff e1 with | T.Triv -> @@ -250,58 +221,6 @@ and c_loop_none context k e1 = (c_exp context e1 (ContVar loop))] (loop -*- unitE) -and c_loop_some context k e1 e2 = - let loop = fresh_var (contT T.unit) in - let u = fresh_var T.unit in - let v1 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> ifE (t_exp context e2) - (loop -*- unitE) - (k -@- unitE) - answerT - | T.Await -> - c_exp context e2 - (meta (typ e2) - (fun v2 -> ifE v2 - (loop -*- unitE) - (k -@- unitE) - answerT)) - in - match eff e1 with - | T.Triv -> - blockE [funcD loop u - (letE v1 (t_exp context e1) e2)] - (loop -*- unitE) - | T.Await -> - blockE [funcD loop u - (c_exp context e1 (meta (typ e1) (fun v1 -> e2)))] - (loop -*- unitE) - -and c_for context k pat e1 e2 = - let v1 = fresh_var (typ e1) in - let next_typ = (T.Func(T.Local, T.Returns, [], [], [T.Opt pat.note])) in - let dotnext v = dotE v nextN next_typ -*- unitE in - let loop = fresh_var (contT T.unit) in - let v2 = fresh_var T.unit in - let e2 = match eff e2 with - | T.Triv -> loop -*- t_exp context e2 - | T.Await -> c_exp context e2 (ContVar loop) in - let body v1 = - blockE - [funcD loop v2 - (switch_optE (dotnext v1) - (k -@- unitE) - pat e2 - T.unit)] - (loop -*- unitE) - in - match eff e1 with - | T.Triv -> - letE v1 (t_exp context e1) - (body v1) - | T.Await -> - c_exp context e1 (meta (typ e1) (fun v1 -> body v1)) - and c_exp context exp = c_exp' context exp @@ -365,14 +284,8 @@ and c_exp' context exp k = (meta (typ exp1) (fun v1 -> {exp with it = SwitchE(v1,cases')})) end) - | WhileE (exp1, exp2) -> - c_while context k exp1 exp2 - | LoopE (exp1, None) -> - c_loop_none context k exp1 - | LoopE (exp1, Some exp2) -> - c_loop_some context k exp1 exp2 - | ForE (pat, exp1, exp2) -> - c_for context k pat exp1 exp2 + | LoopE exp1 -> + c_loop context k exp1 | LabelE (id, _typ, exp1) -> letcont k (fun k -> diff --git a/src/check_ir.ml b/src/check_ir.ml index 76512bfe4e3..4facadbdfdc 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -394,42 +394,10 @@ let rec check_exp env (exp:Ir.exp) : unit = warn env exp.at "the cases in this switch do not cover all possible values"; *) check_cases env t1 t cases; - | WhileE (exp1, exp2) -> - check_exp env exp1; - typ exp1 <: T.bool; - check_exp env exp2; - typ exp2 <: T.unit; - T.unit <: t; - | LoopE (exp1, expo) -> + | LoopE exp1 -> check_exp env exp1; typ exp1 <: T.unit; - begin match expo with - | Some exp2 -> - check_exp env exp2; - typ exp2 <: T.bool; - T.unit <: t; - | _ -> - T.Non <: t; (* vacuously true *) - end; - | ForE (pat, exp1, exp2) -> - begin - check_exp env exp1; - let t1 = T.promote (typ exp1) in - try - let _, tfs = T.as_obj_sub "next" t1 in - let t0 = T.lookup_field "next" tfs in - let t1, t2 = T.as_mono_func_sub t0 in - T.unit <: t1; - let t2' = T.as_opt_sub t2 in - let ve = check_pat_exhaustive env pat in - pat.note <: t2'; - check_exp (adjoin_vals env ve) exp2; - typ exp2 <: T.unit; - T.unit <: t - with Invalid_argument _ -> - error env exp1.at "expected iterable type, but expression has type\n %s" - (T.string_of_typ_expand t1) - end; + T.Non <: t (* vacuously true *) | LabelE (id, t0, exp1) -> assert (t0 <> T.Pre); check_typ env t0; diff --git a/src/compile.ml b/src/compile.ml index e1fc14b1f09..508b0fe13e0 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1500,11 +1500,6 @@ module Object = struct idx env obj_type f ^^ load_ptr - let load_idx_immut env name = - compile_unboxed_const (hash_field_name name) ^^ - idx_hash env false ^^ - load_ptr - end (* Object *) module Text = struct @@ -3725,28 +3720,12 @@ and compile_exp (env : E.t) exp = SR.Unreachable, compile_exp_vanilla env e ^^ G.branch_to_ d - | LoopE (e, None) -> + | LoopE e -> SR.Unreachable, G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i (Br (nr 0l)) ) ^^ G.i Unreachable - | LoopE (e1, Some e2) -> - SR.unit, - G.loop_ (ValBlockType None) ( - compile_exp_unit env e1 ^^ - compile_exp_as env SR.bool e2 ^^ - G.if_ (ValBlockType None) (G.i (Br (nr 1l))) G.nop - ) - | WhileE (e1, e2) -> - SR.unit, - G.loop_ (ValBlockType None) ( - compile_exp_as env SR.bool e1 ^^ - G.if_ (ValBlockType None) ( - compile_exp_unit env e2 ^^ - G.i (Br (nr 1l)) - ) G.nop - ) | RetE e -> SR.Unreachable, compile_exp_as env (StackRep.of_arity (E.get_n_res env)) e ^^ @@ -3806,36 +3785,6 @@ and compile_exp (env : E.t) exp = in let code2 = go env cs in code1 ^^ set_i ^^ orTrap code2 ^^ get_j - | ForE (p, e1, e2) -> - SR.unit, - let code1 = compile_exp_vanilla env e1 in - let (env1, code2) = compile_mono_pat env 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_ (ValBlockType None) ( - get_i ^^ - Object.load_idx_immut env1 (nr_ (Name "next")) ^^ - get_i ^^ - Object.load_idx_immut env1 (nr_ (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 ^^ - Opt.null ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) - G.nop - ( 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 @@ -4009,11 +3958,6 @@ and compile_pat_local env pat : E.t * patternCode = let fill_code = fill_pat env1 pat in (env1, fill_code) -(* Used for mono patterns (ForE) *) -and compile_mono_pat env pat = - let (env1, fill_code) = compile_pat_local env pat in - (env1, orTrap fill_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. *) diff --git a/src/construct.ml b/src/construct.ml index d2f9b1f6490..ccaf69a51ec 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -226,19 +226,9 @@ let labelE l typ exp = S.note_typ = typ } } -let loopE exp1 exp2Opt = - { it = LoopE (exp1, exp2Opt); - at = no_region; - note = { S.note_eff = Effect.max_eff (eff exp1) - (match exp2Opt with - | Some exp2 -> eff exp2 - | None -> Type.Triv); - S.note_typ = Type.Non } - } - (* Used to desugar for loops, while loops and loop-while loops. *) -let loopE' exp = - { it = LoopE (exp, None); +let loopE exp = + { it = LoopE exp; at = no_region; note = { S.note_eff = eff exp ; S.note_typ = T.Non } @@ -421,7 +411,7 @@ let whileE exp1 exp2 = *) let lab = fresh_id () in labelE lab T.unit ( - loopE' ( + loopE ( ifE exp1 exp2 (breakE lab (tupE [])) @@ -438,7 +428,7 @@ let loopWhileE exp1 exp2 = *) let lab = fresh_id () in labelE lab T.unit ( - loopE' ( + loopE ( thenE exp1 ( ifE exp2 (tupE []) @@ -469,7 +459,7 @@ let forE pat exp1 exp2 = let nxt = fresh_var tnxt in letE nxt (dotE exp1 (nameN "next") tnxt) ( labelE lab Type.unit ( - loopE' ( + loopE ( switch_optE (callE nxt [] (tupE []) ty1_ret) (breakE lab (tupE [])) pat exp2 Type.unit diff --git a/src/construct.mli b/src/construct.mli index 073f732bf26..24bf5e7178b 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -60,7 +60,7 @@ val retE: exp -> exp val immuteE: exp -> exp val assignE : exp -> exp -> exp val labelE : id -> typ -> exp -> exp -val loopE : exp -> exp option -> exp +val loopE : exp -> exp val forE : pat -> exp -> exp -> exp val loopWhileE : exp -> exp -> exp val whileE : exp -> exp -> exp diff --git a/src/desugar.ml b/src/desugar.ml index aaa586d8fa2..7b3eb00c68a 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -70,7 +70,7 @@ and exp' at note = function | 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) -> (whileE (exp e1) (exp e2)).it - | S.LoopE (e1, None) -> I.LoopE (exp e1, None) + | S.LoopE (e1, None) -> I.LoopE (exp e1) | S.LoopE (e1, Some e2) -> (loopWhileE (exp e1) (exp e2)).it | S.ForE (p, e1, e2) -> (forE (pat p) (exp e1) (exp e2)).it | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp e) diff --git a/src/effect.ml b/src/effect.ml index 6f434dd9ef9..9d913ea50d7 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -130,16 +130,13 @@ module Ir = | LabelE (_, _, exp1) | BreakE (_, exp1) | RetE exp1 - | LoopE (exp1, None) -> + | LoopE exp1 -> effect_exp exp1 | BinE (_, exp1, _, exp2) | IdxE (exp1, exp2) | RelE (_, exp1, _, exp2) | AssignE (exp1, exp2) - | CallE (_, exp1, _, exp2) - | WhileE (exp1, exp2) - | LoopE (exp1, Some exp2) - | ForE (_, exp1, exp2) -> + | CallE (_, exp1, _, exp2) -> let t1 = effect_exp exp1 in let t2 = effect_exp exp2 in max_eff t1 t2 diff --git a/src/freevars.ml b/src/freevars.ml index 731dde8e39f..e70a34f4c58 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -76,10 +76,7 @@ let rec exp e : f = match e.it with | BlockE (ds, e1) -> close (decs ds +++ exp e1) | IfE (e1, e2, e3) -> exps [e1; e2; e3] | SwitchE (e, cs) -> exp e ++ cases cs - | WhileE (e1, e2) -> exps [e1; e2] - | LoopE (e1, None) -> exp e1 - | LoopE (e1, Some e2) -> exps [e1; e2] - | ForE (p, e1, e2) -> exp e1 ++ (exp e2 /// pat p) + | LoopE e1 -> exp e1 | LabelE (i, t, e) -> exp e | BreakE (i, e) -> exp e | RetE e -> exp e diff --git a/src/interpret_ir.ml b/src/interpret_ir.ml index 9cda67fe4c4..65863d12a6e 100644 --- a/src/interpret_ir.ml +++ b/src/interpret_ir.ml @@ -352,44 +352,8 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (fun v1 -> interpret_cases env cases exp.at v1 k ) - | WhileE (exp1, exp2) -> - let k_continue = fun v -> V.as_unit v; interpret_exp env exp k in - interpret_exp env exp1 (fun v1 -> - if V.as_bool v1 - then interpret_exp env exp2 k_continue - else k V.unit - ) - | LoopE (exp1, None) -> + | LoopE exp1 -> interpret_exp env exp1 (fun v -> V.as_unit v; interpret_exp env exp k) - | LoopE (exp1, Some exp2) -> - interpret_exp env exp1 (fun v1 -> - V.as_unit v1; - interpret_exp env exp2 (fun v2 -> - if V.as_bool v2 - then interpret_exp env exp k - else k V.unit - ) - ) - | ForE (pat, exp1, exp2) -> - interpret_exp env exp1 (fun v1 -> - let fs = V.as_obj v1 in - let _, next = V.as_func (find "next" fs) in - let rec k_continue = fun v -> - V.as_unit v; - next V.unit (fun v' -> - match v' with - | V.Opt v1 -> - (match match_pat pat v1 with - | None -> - trap pat.at "value %s does not match pattern" (V.string_of_val v') - | Some ve -> - interpret_exp (adjoin_vals env ve) exp2 k_continue - ) - | V.Null -> k V.unit - | _ -> assert false - ) - in k_continue V.unit - ) | LabelE (id, _typ, exp1) -> let env' = {env with labs = V.Env.add id.it k env.labs} in interpret_exp env' exp1 k diff --git a/src/ir.ml b/src/ir.ml index 4dad57d9a8d..a23bfb909ca 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -46,9 +46,7 @@ and exp' = | BlockE of (dec list * exp) (* block *) | IfE of exp * exp * exp (* conditional *) | SwitchE of exp * case list (* switch *) - | WhileE of exp * exp (* while-do loop *) - | LoopE of exp * exp option (* do-while loop *) - | ForE of pat * exp * exp (* iteration *) + | LoopE of exp (* do-while loop *) | LabelE of id * Type.typ * exp (* label *) | BreakE of id * exp (* break *) | RetE of exp (* return *) diff --git a/src/rename.ml b/src/rename.ml index 20741e6fa0b..a36275d3f2f 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -47,11 +47,7 @@ and exp' rho e = match e with in BlockE (ds', exp rho' e1) | IfE (e1, e2, e3) -> IfE (exp rho e1, exp rho e2, exp rho e3) | SwitchE (e, cs) -> SwitchE (exp rho e, cases rho cs) - | WhileE (e1, e2) -> WhileE (exp rho e1, exp rho e2) - | LoopE (e1, None) -> LoopE (exp rho e1, None) - | LoopE (e1, Some e2) -> LoopE (exp rho e1, Some (exp rho e2)) - | ForE (p, e1, e2) -> let p',rho' = pat rho p in - ForE (p', exp rho e1, exp rho' e2) + | LoopE e1 -> LoopE (exp rho e1) | LabelE (i, t, e) -> let i',rho' = id_bind rho i in LabelE(i', t, exp rho' e) | BreakE (i, e) -> BreakE(id rho i,exp rho e) diff --git a/src/tailcall.ml b/src/tailcall.ml index 6968903f8d7..57bf761897a 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -105,11 +105,7 @@ and exp' env e : exp' = match e.it with | BlockE (ds, e) -> BlockE (block env ds e) | IfE (e1, e2, e3) -> IfE (exp env e1, tailexp env e2, tailexp env e3) | SwitchE (e, cs) -> SwitchE (exp env e, cases env cs) - | WhileE (e1, e2) -> WhileE (exp env e1, exp env e2) - | LoopE (e1, None) -> LoopE (exp env e1, None) - | LoopE (e1, Some e2) -> LoopE (exp env e1, Some (exp env e2)) - | ForE (p, e1, e2) -> let env1 = pat env p in - ForE (p, exp env e1, exp env1 e2) + | LoopE e1 -> LoopE (exp env e1) | LabelE (i, t, e) -> let env1 = bind env i None in LabelE(i, t, exp env1 e) | BreakE (i, e) -> BreakE(i,exp env e) @@ -196,10 +192,11 @@ and dec' env d = let args = seqP (List.map varP ids) in let l_typ = Type.unit in let body = - blockE [varD (id_of_exp temp) (seqE ids)] - (loopE - (labelE l l_typ - (blockE [letP p (immuteE temp)] (retE exp0'))) None) + blockE [varD (id_of_exp temp) (seqE ids)] ( + loopE ( + labelE l l_typ (blockE [letP p (immuteE temp)] (retE exp0')) + ) + ) in LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, args, typT, body)}) else From f349e36de1ded1be154571cb9032801dd1c61c15 Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Tue, 12 Mar 2019 09:37:23 -0600 Subject: [PATCH 24/76] review comments --- stdlib/assocList.as | 2 +- stdlib/list.as | 16 ++-------------- stdlib/setDb.as | 1 - stdlib/trie.as | 32 ++++++++++++++++---------------- 4 files changed, 19 insertions(+), 32 deletions(-) diff --git a/stdlib/assocList.as b/stdlib/assocList.as index 50c00358b5c..67d2b40bf81 100644 --- a/stdlib/assocList.as +++ b/stdlib/assocList.as @@ -61,7 +61,7 @@ let AssocList = new { rec(al) }; - // The key-value pairs of the final list consists of those pairs of + // The key-value pairs of the final list consist of those pairs of // the left list whose keys are not present in the right list; the // values of the right list are irrelevant. func diff(al1: AssocList, diff --git a/stdlib/list.as b/stdlib/list.as index 87dcb4c47f7..d9fe19613b8 100644 --- a/stdlib/list.as +++ b/stdlib/list.as @@ -276,13 +276,7 @@ let List = new { switch (l1, l2) { case (null, _) { true }; case (_, null) { false }; - case (?(h1,t1), ?(h2,t2)) { - if (lte(h1,h2)) { - rec(t1, t2) - } else { - false - } - }; + case (?(h1,t1), ?(h2,t2)) { lte(h1,h2) and rec(t1, t2) }; } }; rec(l1, l2) @@ -296,13 +290,7 @@ let List = new { case (null, null) { true }; case (null, _) { false }; case (_, null) { false }; - case (?(h1,t1), ?(h2,t2)) { - if (eq(h1,h2)) { - rec(t1, t2) - } else { - false - } - }; + case (?(h1,t1), ?(h2,t2)) { eq(h1,h2) and rec(t1, t2) }; } }; rec(l1, l2) diff --git a/stdlib/setDb.as b/stdlib/setDb.as index 7fa41a221b0..84351439ff9 100644 --- a/stdlib/setDb.as +++ b/stdlib/setDb.as @@ -103,7 +103,6 @@ let SetDb = new { // also: test that merge agrees with disj: let r1 = Set.union(s1, s2, natEq); let r2 = Trie.disj(s1, s2, natEq, func (_:?(),_:?()):(())=()); - //xxx assert(Trie.equalStructure(r1, r2, natEq, Set.unitEq)); print ";\n"; setDbPrint(r1); diff --git a/stdlib/trie.as b/stdlib/trie.as index 5bdc836968d..2791c47bdf6 100644 --- a/stdlib/trie.as +++ b/stdlib/trie.as @@ -118,8 +118,8 @@ let Trie = new { // XXX: until AST-42: func assertIsNull(x : ?X) { switch x { - case null { assert(true) }; - case (?_) { assert(false) }; + case null { assert true }; + case (?_) { assert false }; }; }; @@ -143,8 +143,8 @@ let Trie = new { // XXX: until AST-42: func assertIsEmpty(t : Trie) { switch t { - case null { assert(true) }; - case (?_) { assert(false) }; + case null { assert true }; + case (?_) { assert false }; }; }; @@ -199,7 +199,7 @@ let Trie = new { // XXX: until AST-42: func assertIsBin(t : Trie) { switch t { - case null { assert(false) }; + case null { assert false }; case (?n) { assertIsNull<((Key,V),AssocList,V>)>(n.keyvals); }; @@ -270,11 +270,11 @@ let Trie = new { // create new bin node for this bit of the hash let path = rec(bitpos+1); let bit = getHashBit(k.hash, bitpos); - if (not bit) { - ?(new {left=path; right=null; keyvals=null}) + if bit { + ?(new {left=null; right=path; keyvals=null}) } else { - ?(new {left=null; right=path; keyvals=null}) + ?(new {left=path; right=null; keyvals=null}) } } else { // create new leaf for (k,v) pair, if the value is non-null: @@ -387,12 +387,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tr }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tr }; @@ -435,12 +435,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tl }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption tl }; @@ -506,12 +506,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; @@ -551,12 +551,12 @@ let Trie = new { makeBin(t0, t1) }; case (false, true) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; case (true, false) { - assert(false); + assert false; // XXX impossible, until we lift uniform depth assumption makeEmpty() }; From 49e139af60b0e2fd711e4339f50e50291a10308d Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 18:17:12 +0100 Subject: [PATCH 25/76] Do not run FileCheck checks when building coverage report (#236) --- test/run.sh | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/test/run.sh b/test/run.sh index dbd3fbd81ce..287eb517336 100755 --- a/test/run.sh +++ b/test/run.sh @@ -134,12 +134,15 @@ do diff_files="$diff_files $base.wasm.stderr" # Check filecheck - if grep -F -q CHECK $base.as + if [ "$SKIP_RUNNING" != yes ] then - $ECHO -n " [Filecheck]" - wasm2wat --no-check --enable-multi-value $out/$base.wasm > $out/$base.wat - cat $out/$base.wat | FileCheck $base.as > $out/$base.filecheck 2>&1 - diff_files="$diff_files $base.filecheck" + if grep -F -q CHECK $base.as + then + $ECHO -n " [FileCheck]" + wasm2wat --no-check --enable-multi-value $out/$base.wasm > $out/$base.wat + cat $out/$base.wat | FileCheck $base.as > $out/$base.filecheck 2>&1 + diff_files="$diff_files $base.filecheck" + fi fi # Run compiled program From cc2c36754501829a0d724407f20817a717eaccb4 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 13 Mar 2019 20:15:45 +0100 Subject: [PATCH 26/76] AST-33: Word64 and operations (#235) * AST-33: Word64 codegen, all ops * compile PosOp as the identity regardless of type * implement pow for all 64-bit types * add comment about representation equivalence of `Word64` with `Int` and `Nat`, currently. * better FileCheck and a bugfix --- src/compile.ml | 142 +++++++++++++++------- src/prelude.ml | 35 ++++++ test/run/ok/bit-ops.wasm.stderr.ok | 30 ----- test/run/ok/numeric-ops.wasm.stderr.ok | 34 ------ test/run/ok/relational-ops.wasm.stderr.ok | 24 ---- test/run/ok/words.run-ir.ok | 21 ++++ test/run/ok/words.run-low.ok | 21 ++++ test/run/ok/words.run.ok | 21 ++++ test/run/words.as | 137 ++++++++++++++------- 9 files changed, 290 insertions(+), 175 deletions(-) delete mode 100644 test/run/ok/bit-ops.wasm.stderr.ok diff --git a/src/compile.ml b/src/compile.ml index 508b0fe13e0..07de524678b 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -421,7 +421,7 @@ let 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 new_local64 env name = let (set_i, get_i, _) = new_local_ env I64Type name in (set_i, get_i) @@ -1209,6 +1209,11 @@ module BoxedInt = struct │ tag │ i64 │ └─────┴─────┴─────┘ + Note, that due to the equivalence of in-memory and on-stack + representations, the 64-bit word type is also represented in this + way. As we get proper bigints, the memory representations should + be disambiguated and stack representations adapted. (Renaming + those will point out where the backend needs adjustments.) *) let payload_field = Tagged.header_size @@ -2236,7 +2241,7 @@ module Serialization = struct Same for indices into the reference table. *) - let serialize_go env = + let rec serialize_go env = Func.share_code1 env "serialize_go" ("x", I32Type) [I32Type] (fun env get_x -> let (set_copy, get_copy) = new_local env "x'" in @@ -2262,12 +2267,12 @@ module Serialization = struct ; Tagged.Some, Opt.inject env ( get_x ^^ Opt.project ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) + serialize_go env ) ; Tagged.ObjInd, Tagged.obj env Tagged.ObjInd [ get_x ^^ Heap.load_field 1l ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) + serialize_go env ] ; Tagged.Array, begin @@ -2298,7 +2303,7 @@ module Serialization = struct get_i ^^ Array.idx env ^^ load_ptr ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) ^^ + serialize_go env ^^ store_ptr ) ^^ get_copy @@ -2385,7 +2390,7 @@ module Serialization = struct compile_add_const Heap.word_size ^^ load_ptr ^^ - G.i (Call (nr (E.built_in env "serialize_go"))) ^^ + serialize_go env ^^ store_ptr ) ^^ get_copy @@ -2940,6 +2945,7 @@ module StackRep = struct | Type.Prim Type.Bool -> bool | Type.Prim Type.Nat -> UnboxedInt64 | Type.Prim Type.Int -> UnboxedInt64 + | Type.Prim Type.Word64 -> UnboxedInt64 | Type.Prim Type.Word32 -> UnboxedWord32 | Type.Prim Type.(Word8 | Word16 | Char) -> Vanilla | Type.Prim Type.Text -> Vanilla @@ -3327,6 +3333,9 @@ let compile_lit env lit = Syntax.(match lit with | Word32Lit n -> SR.UnboxedWord32, (try compile_unboxed_const n with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int32.to_int n); G.i Unreachable) + | Word64Lit n -> SR.UnboxedInt64, + (try compile_const_64 n + with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" (Int64.to_int n); G.i Unreachable) | CharLit c -> SR.Vanilla, (try compile_unboxed_const Int32.(shift_left (of_int c) 8) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %d\n" c; G.i Unreachable) @@ -3340,7 +3349,7 @@ let compile_lit_as env sr_out lit = code ^^ StackRep.adjust env sr_in sr_out let compile_unop env t op = Syntax.(match op, t with - | NegOp, Type.Prim Type.Int -> + | NegOp, Type.(Prim (Int | Word64)) -> SR.UnboxedInt64, Func.share_code1 env "neg" ("n", I64Type) [I64Type] (fun env get_n -> compile_const_64 0L ^^ @@ -3354,15 +3363,13 @@ let compile_unop env t op = Syntax.(match op, t with get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ) + | NotOp, Type.(Prim Word64) -> + SR.UnboxedInt64, + compile_const_64 (-1L) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.Xor)) | NotOp, Type.Prim Type.(Word8 | Word16 | Word32 as ty) -> StackRep.of_type t, compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ G.i (Binary (Wasm.Values.I32 I32Op.Xor)) - | PosOp, Type.Prim Type.(Int | Nat) -> - SR.UnboxedInt64, - G.nop - | PosOp, Type.Prim Type.(Word8 | Word16 | Word32) -> - StackRep.of_type t, - G.nop | _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable) ) @@ -3390,20 +3397,20 @@ let sanitize_word_result = function let rec compile_binop env t op = StackRep.of_type t, Syntax.(match t, op with - | Type.Prim Type.(Nat | Int), AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) - | Type.Prim Type.Nat, SubOp -> + | Type.(Prim (Nat | Int | Word64)), AddOp -> G.i (Binary (Wasm.Values.I64 I64Op.Add)) + | Type.Prim Type.Nat, SubOp -> Func.share_code2 env "nat_sub" (("n1", I64Type), ("n2", I64Type)) [I64Type] (fun env get_n1 get_n2 -> get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ G.if_ (StackRep.to_block_type env SR.UnboxedInt64) (G.i Unreachable) (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) ) - | Type.Prim Type.(Nat | Int), 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, SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) - | Type.Prim Type.Int, DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivS)) - | Type.Prim Type.Int, ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemS)) + | Type.(Prim (Nat | Int | Word64)), MulOp -> G.i (Binary (Wasm.Values.I64 I64Op.Mul)) + | Type.(Prim (Nat | Word64)), DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivU)) + | Type.(Prim (Nat | Word64)), ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemU)) + | Type.(Prim (Int | Word64)), SubOp -> G.i (Binary (Wasm.Values.I64 I64Op.Sub)) + | Type.(Prim Int), DivOp -> G.i (Binary (Wasm.Values.I64 I64Op.DivS)) + | Type.(Prim Int), ModOp -> G.i (Binary (Wasm.Values.I64 I64Op.RemS)) | Type.Prim Type.(Word8 | Word16 | Word32), AddOp -> G.i (Binary (Wasm.Values.I32 I32Op.Add)) | Type.Prim Type.(Word8 | Word16 | Word32), SubOp -> G.i (Binary (Wasm.Values.I32 I32Op.Sub)) @@ -3432,16 +3439,51 @@ let rec compile_binop env t op = square_recurse_with_shifted (sanitize_word_result ty) ^^ mul))) in pow () + | Type.(Prim Int), PowOp -> + let _, pow = compile_binop env Type.(Prim Nat) PowOp in + let (set_n, get_n) = new_local64 env "n" in + let (set_exp, get_exp) = new_local64 env "exp" + in set_exp ^^ set_n ^^ get_exp ^^ compile_const_64 0L ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtS)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + (G.i Unreachable) + (get_n ^^ get_exp ^^ pow) + | Type.(Prim (Nat|Word64)), PowOp -> + let rec pow () = Func.share_code2 env "pow" + (("n", I64Type), ("exp", I64Type)) [I64Type] + Wasm.Values.(fun env get_n get_exp -> + let one = compile_const_64 1L in + let (set_res, get_res) = new_local64 env "res" in + let mul = snd (compile_binop env t MulOp) in + let square_recurse_with_shifted = + get_n ^^ get_exp ^^ one ^^ + G.i (Binary (I64 I64Op.ShrU)) ^^ + pow () ^^ set_res ^^ get_res ^^ get_res ^^ mul + in get_exp ^^ G.i (Test (I64 I64Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + one + (get_exp ^^ one ^^ G.i (Binary (I64 I64Op.And)) ^^ G.i (Test (I64 I64Op.Eqz)) ^^ + G.if_ (StackRep.to_block_type env SR.UnboxedInt64) + square_recurse_with_shifted + (get_n ^^ + square_recurse_with_shifted ^^ + mul))) + in pow () + | Type.(Prim Word64), AndOp -> G.i (Binary (Wasm.Values.I64 I64Op.And)) | Type.Prim Type.(Word8 | Word16 | Word32), AndOp -> G.i (Binary (Wasm.Values.I32 I32Op.And)) + | Type.(Prim Word64), OrOp -> G.i (Binary (Wasm.Values.I64 I64Op.Or)) | Type.Prim Type.(Word8 | Word16 | Word32), OrOp -> G.i (Binary (Wasm.Values.I32 I32Op.Or)) + | Type.(Prim Word64), XorOp -> G.i (Binary (Wasm.Values.I64 I64Op.Xor)) | Type.Prim Type.(Word8 | Word16 | Word32), XorOp -> G.i (Binary (Wasm.Values.I32 I32Op.Xor)) + | Type.(Prim Word64), ShLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Shl)) | Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> - clamp_shift_amount ty ^^ + lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + | Type.(Prim Word64), ShROp -> G.i (Binary (Wasm.Values.I64 I64Op.ShrU)) | Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> - clamp_shift_amount ty ^^ + lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ sanitize_word_result ty + | Type.(Prim Word64), RotLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotl)) | Type.Prim Type. Word32, RotLOp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotl)) | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] @@ -3450,6 +3492,7 @@ let rec compile_binop env t op = get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^ get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^ sanitize_word_result ty) + | Type.(Prim Word64), RotROp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotr)) | Type.Prim Type. Word32, RotROp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) | Type.Prim Type.(Word8 | Word16 as ty), RotROp -> Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type] @@ -3465,8 +3508,8 @@ let rec compile_binop env t op = let compile_eq env t = match t with | 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)) - | Type.Prim Type.(Word8 | Word16 | Word32 | Char) -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) + | Type.(Prim (Nat | Int | Word64)) -> G.i (Compare (Wasm.Values.I64 I64Op.Eq)) + | Type.(Prim (Word8 | Word16 | Word32 | Char)) -> G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | _ -> todo "compile_eq" (Arrange.relop Syntax.EqOp) (G.i Unreachable) let get_relops = Syntax.(function @@ -3479,7 +3522,7 @@ let get_relops = Syntax.(function let compile_comparison t op = let u64op, s64op, u32op, s32op = get_relops op in Type.(match t with - | Nat -> G.i (Compare (Wasm.Values.I64 u64op)) + | (Nat | Word64) -> G.i (Compare (Wasm.Values.I64 u64op)) | Int -> G.i (Compare (Wasm.Values.I64 s64op)) | (Word8 | Word16 | Word32 | Char) -> G.i (Compare (Wasm.Values.I32 u32op)) | _ -> todo "compile_comparison" (Arrange.prim t) (G.i Unreachable)) @@ -3491,7 +3534,7 @@ let compile_relop env t op = | _, NeqOp -> compile_eq env t ^^ G.if_ (StackRep.to_block_type env SR.bool) (Bool.lit false) (Bool.lit true) - | Type.Prim Type.(Nat | Int | Word8 | Word16 | Word32 | Char as t1), op1 -> + | Type.Prim Type.(Nat | Int | Word8 | Word16 | Word32 | Word64 | Char as t1), op1 -> compile_comparison t1 op1 | _ -> todo "compile_relop" (Arrange.relop op) (G.i Unreachable) ) @@ -3549,23 +3592,15 @@ and compile_exp (env : E.t) exp = (* 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]; _}) -> - SR.Vanilla, begin - compile_exp_vanilla env e1 ^^ - compile_exp_vanilla env e2 ^^ - match p with - | "Array.init" -> Array.init env - | "Array.tabulate" -> Array.tabulate env - | "shrs" -> - let (set_am, get_am) = new_local env "am" in - BoxedSmallWord.unbox env ^^ - set_am ^^ - BoxedSmallWord.unbox env ^^ - get_am ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ - BoxedSmallWord.box env - - | _ -> todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + let compile_kernel_as sr inst = sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ inst + in match p with + | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) + | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) + | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) + | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) + + | _ -> SR.Vanilla, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end (* Unary prims *) | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> @@ -3594,6 +3629,10 @@ and compile_exp (env : E.t) exp = compile_exp_as env SR.UnboxedInt64 e ^^ Prim.prim_intToWord32 + | "Nat->Word64" + | "Int->Word64" -> + let sr, code = compile_exp env e in sr, code ^^ G.nop + | "Char->Word32" -> SR.UnboxedWord32, compile_exp_vanilla env e ^^ @@ -3627,6 +3666,10 @@ and compile_exp (env : E.t) exp = compile_exp_as env SR.UnboxedWord32 e ^^ Prim.prim_word32toInt + | "Word64->Nat" + | "Word64->Int" -> + let sr, code = compile_exp env e in sr, code ^^ G.nop + | "Word32->Char" -> SR.Vanilla, compile_exp_as env SR.UnboxedWord32 e ^^ @@ -3637,14 +3680,26 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | "popcnt64" -> + SR.UnboxedInt64, + compile_exp_as env SR.UnboxedInt64 e ^^ + G.i (Unary (Wasm.Values.I64 I64Op.Popcnt)) | "clz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "clz64" -> + SR.UnboxedInt64, + compile_exp_as env SR.UnboxedInt64 e ^^ + G.i (Unary (Wasm.Values.I64 I64Op.Clz)) | "ctz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | "ctz64" -> + SR.UnboxedInt64, + compile_exp_as env SR.UnboxedInt64 e ^^ + G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) | "printInt" -> SR.unit, @@ -3672,6 +3727,7 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_as env SR.bool e1 ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) + | UnE (_, Syntax.PosOp, e1) -> compile_exp env e1 | UnE (t, op, e1) -> let sr, code = compile_unop env t op in sr, diff --git a/src/prelude.ml b/src/prelude.ml index 11bd6da7bfc..ef9b6ea5b8c 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -50,6 +50,11 @@ func word32ToNat(n : Word32) : Nat = (prim "Word32->Nat" : Word32 -> Nat) n; func intToWord32(n : Int) : Word32 = (prim "Int->Word32" : Int -> Word32) n; func word32ToInt(n : Word32) : Int = (prim "Word32->Int" : Word32 -> Int) n; +func natToWord64(n : Nat) : Word64 = (prim "Nat->Word64" : Nat -> Word64) n; +func word64ToNat(n : Word64) : Nat = (prim "Word64->Nat" : Word64 -> Nat) n; +func intToWord64(n : Int) : Word64 = (prim "Int->Word64" : Int -> Word64) n; +func word64ToInt(n : Word64) : Int = (prim "Word64->Int" : Word64 -> Int) n; + func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; @@ -59,6 +64,11 @@ func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; func ctzWord32(w : Word32) : Word32 = (prim "ctz" : Word32 -> Word32) w; +func shrsWord64(w : Word64, amount : Word64) : Word64 = (prim "shrs64" : (Word64, Word64) -> Word64) (w, amount); +func popcntWord64(w : Word64) : Word64 = (prim "popcnt64" : Word64 -> Word64) w; +func clzWord64(w : Word64) : Word64 = (prim "clz64" : Word64 -> Word64) w; +func ctzWord64(w : Word64) : Word64 = (prim "ctz64" : Word64 -> Word64) w; + // This would be nicer as a objects, but lets do them as functions // until the compiler has a concept of “static objects” @@ -133,6 +143,13 @@ let prim = function let i = Big_int.int_of_big_int (as_int v) in k (Word32 (Word32.of_int_s i)) + | "Nat->Word64" -> fun v k -> + let i = Big_int.int_of_big_int (as_int v) + in k (Word64 (Word64.of_int_u i)) + | "Int->Word64" -> fun v k -> + let i = Big_int.int_of_big_int (as_int v) + in k (Word64 (Word64.of_int_s i)) + | "Word8->Nat" -> fun v k -> let i = Int32.to_int (Int32.shift_right_logical (Word8.to_bits (as_word8 v)) 24) in k (Int (Big_int.big_int_of_int i)) @@ -150,6 +167,11 @@ let prim = function in k (Int (Big_int.big_int_of_int i)) | "Word32->Int" -> fun v k -> k (Int (Big_int.big_int_of_int32 (as_word32 v))) + | "Word64->Nat" -> fun v k -> + let i = Int64.to_int (as_word64 v) (* ! *) + in k (Int (Big_int.big_int_of_int i)) + | "Word64->Int" -> fun v k -> k (Int (Big_int.big_int_of_int64 (as_word64 v))) + | "Char->Word32" -> fun v k -> let i = as_char v in k (Word32 (Word32.of_int_u i)) @@ -160,15 +182,28 @@ let prim = function let w, a = as_pair v in let i = Word32.shr_s (as_word32 w) (as_word32 a) in k (Word32 i) + | "shrs64" -> fun v k -> + let w, a = as_pair v in + let i = Word64.shr_s (as_word64 w) (as_word64 a) + in k (Word64 i) | "popcnt" -> fun v k -> let i = Word32.popcnt (as_word32 v) in k (Word32 i) + | "popcnt64" -> fun v k -> + let i = Word64.popcnt (as_word64 v) + in k (Word64 i) | "clz" -> fun v k -> let i = Word32.clz (as_word32 v) in k (Word32 i) + | "clz64" -> fun v k -> + let i = Word64.clz (as_word64 v) + in k (Word64 i) | "ctz" -> fun v k -> let i = Word32.ctz (as_word32 v) in k (Word32 i) + | "ctz64" -> fun v k -> + let i = Word64.ctz (as_word64 v) + in k (Word64 i) | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit | "Array.init" -> fun v k -> diff --git a/test/run/ok/bit-ops.wasm.stderr.ok b/test/run/ok/bit-ops.wasm.stderr.ok deleted file mode 100644 index 1f8ac7bdc39..00000000000 --- a/test/run/ok/bit-ops.wasm.stderr.ok +++ /dev/null @@ -1,30 +0,0 @@ -compile_unop: NotOp -compile_unop: NotOp -compile_binop: OrOp -of_type: Word64 -compile_binop: OrOp -of_type: Word64 -compile_binop: AndOp -of_type: Word64 -compile_binop: AndOp -of_type: Word64 -compile_binop: XorOp -of_type: Word64 -compile_binop: XorOp -of_type: Word64 -compile_binop: ShiftLOp -of_type: Word64 -compile_binop: ShiftLOp -of_type: Word64 -compile_binop: ShiftROp -of_type: Word64 -compile_binop: ShiftROp -of_type: Word64 -compile_binop: RotLOp -of_type: Word64 -compile_binop: RotLOp -of_type: Word64 -compile_binop: RotROp -of_type: Word64 -compile_binop: RotROp -of_type: Word64 diff --git a/test/run/ok/numeric-ops.wasm.stderr.ok b/test/run/ok/numeric-ops.wasm.stderr.ok index bf44ccb511d..20555433169 100644 --- a/test/run/ok/numeric-ops.wasm.stderr.ok +++ b/test/run/ok/numeric-ops.wasm.stderr.ok @@ -1,13 +1,3 @@ -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_unop: PosOp -compile_unop: PosOp compile_unop: NegOp compile_unop: NegOp compile_binop: AddOp @@ -30,27 +20,3 @@ compile_binop: PowOp of_type: Float compile_binop: PowOp of_type: Float -compile_binop: AddOp -of_type: Word64 -compile_binop: AddOp -of_type: Word64 -compile_binop: SubOp -of_type: Word64 -compile_binop: SubOp -of_type: Word64 -compile_binop: MulOp -of_type: Word64 -compile_binop: MulOp -of_type: Word64 -compile_binop: DivOp -of_type: Word64 -compile_binop: DivOp -of_type: Word64 -compile_binop: ModOp -of_type: Word64 -compile_binop: ModOp -of_type: Word64 -compile_binop: PowOp -of_type: Word64 -compile_binop: PowOp -of_type: Word64 diff --git a/test/run/ok/relational-ops.wasm.stderr.ok b/test/run/ok/relational-ops.wasm.stderr.ok index 3b0ee159540..509dff09494 100644 --- a/test/run/ok/relational-ops.wasm.stderr.ok +++ b/test/run/ok/relational-ops.wasm.stderr.ok @@ -22,30 +22,6 @@ compile_relop: GeOp of_type: Float compile_relop: GeOp of_type: Float -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_eq: EqOp -of_type: Word64 -compile_relop: LtOp -of_type: Word64 -compile_relop: LtOp -of_type: Word64 -compile_relop: LeOp -of_type: Word64 -compile_relop: LeOp -of_type: Word64 -compile_relop: GtOp -of_type: Word64 -compile_relop: GtOp -of_type: Word64 -compile_relop: GeOp -of_type: Word64 -compile_relop: GeOp -of_type: Word64 compile_relop: LtOp compile_relop: LtOp compile_relop: LeOp diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index 150b24d3944..4eaea15a04f 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -1,4 +1,25 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +8912765 8912765 4286054531 -8912765 4286054530 -8912766 8917332 8917332 diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index 150b24d3944..4eaea15a04f 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -1,4 +1,25 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +8912765 8912765 4286054531 -8912765 4286054530 -8912766 8917332 8917332 diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index 150b24d3944..4eaea15a04f 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -1,4 +1,25 @@ 8912765 8912765 +-8912765 -8912765 +-8912766 -8912766 +8917332 8917332 +8908198 8908198 +31969 31969 +652 652 +2548 2548 +20857489 20857489 +4437 4437 +8912895 8912895 +8908458 8908458 +584576 584576 +35 35 +-2 -2 +-326582449863721025 -326582449863721025 +1140833920 1140833920 +-432345564227497986 -432345564227497986 +61 61 +49 49 +5 5 +8912765 8912765 4286054531 -8912765 4286054530 -8912766 8917332 8917332 diff --git a/test/run/words.as b/test/run/words.as index f1c52165cee..30179b9091b 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -1,4 +1,67 @@ // CHECK: func $start + +func checkpointAlpha() {}; +func checkpointBravo() {}; +func checkpointCharlie() {}; +func checkpointDelta() {}; +func checkpointEcho() {}; +func checkpointFoxtrot() {}; +func checkpointGolf() {}; +func checkpointHotel() {}; +func checkpointIndia() {}; +func checkpointJuliett() {}; + +// Word64 operations +{ + func printW64ln(w : Word64) { printInt(word64ToNat w); print " "; printInt(word64ToInt w); print "\n" }; + + let a : Word64 = 4567; + let b : Word64 = 7; + let c : Word64 = 8912765; + let d : Word64 = -15; + let e : Word64 = 20000; + +// CHECK: get_local $c +// CHECK-NOT: call $box_i64 +// CHECK: call $printW64ln + printW64ln(+c); + printW64ln(-c); + printW64ln(^c); + printW64ln(a + c); + printW64ln(c - a); + +// CHECK: call $checkpointAlpha + checkpointAlpha(); +// This is a native Wasm i64 multiplication, there should be no shift involved! +// CHECK-NOT: i64.shr_u +// CHECK: call $printW64ln + printW64ln(a * b); + + printW64ln(a / b); + printW64ln(c % a); + printW64ln(a ** 2); + + printW64ln(a & c); + printW64ln(a | c); + printW64ln(a ^ c); + printW64ln(a << b); + printW64ln(a >> b); + printW64ln(shrsWord64(d, 3)); + printW64ln(shrsWord64(-5225319197819536385, 4)); // 0b1011011101111011111011111101111111011111111011111111101111111111L == -5225319197819536385L --> -326582449863721025L + printW64ln(c <<> b); + printW64ln(c <>> b); + printW64ln(popcntWord64 d); // -15 = 0xfffffffffffffff1 = 0b1111_..._1111_1111_0001 (population = 61) + printW64ln(clzWord64 e); // 20000 = 0x0000000000004e20 (leading zeros = 49) + printW64ln(ctzWord64 e); // 20000 = 0x0000000000004e20 (trailing zeros = 5) + + assert (3 : Word64 ** (4 : Word64) == (81 : Word64)); + assert (3 : Word64 ** (7 : Word64) == (2187 : Word64)); + assert (3 : Word64 ** (14 : Word64) == (4782969 : Word64)); + assert (3 : Word64 ** (20 : Word64) == (3486784401 : Word64)); +}; + + + // Word32 operations { func printW32ln(w : Word32) { printInt(word32ToNat w); print " "; printInt(word32ToInt w); print "\n" }; @@ -9,52 +72,38 @@ let d : Word32 = -15; let e : Word32 = 20000; +// CHECK: call $checkpointBravo + checkpointBravo(); // CHECK: get_local $c -// LATER: HECK-NOT: call $box_i32 +// CHECK-NOT: call $box_i32 // CHECK: call $printW32ln printW32ln(+c); -// CHECK: call $printW32ln printW32ln(-c); -// CHECK: call $printW32ln printW32ln(^c); -// CHECK: call $printW32ln printW32ln(a + c); -// CHECK: call $printW32ln printW32ln(c - a); +// CHECK: call $checkpointCharlie + checkpointCharlie(); +// This is a native Wasm i32 multiplication, there should be no shift involved! // CHECK-NOT: i32.shr_u // CHECK: call $printW32ln printW32ln(a * b); -// CHECK: call $printW32ln printW32ln(a / b); -// CHECK: call $printW32ln printW32ln(c % a); -// CHECK: call $printW32ln printW32ln(a ** 2); -// CHECK: call $printW32ln printW32ln(a & c); -// CHECK: call $printW32ln printW32ln(a | c); -// CHECK: call $printW32ln printW32ln(a ^ c); -// CHECK: call $printW32ln printW32ln(a << b); -// CHECK: call $printW32ln printW32ln(a >> b); -// CHECK: call $printW32ln printW32ln(shrsWord32(d, 3)); -// CHECK: call $printW32ln printW32ln(shrsWord32(-1216614433, 4)); // 0b10110111011110111110111111011111l == -1216614433l --> -76038403 -// CHECK: call $printW32ln printW32ln(c <<> b); -// CHECK: call $printW32ln printW32ln(c <>> b); -// CHECK: call $printW32ln printW32ln(popcntWord32 d); // -15 = 0xfffffff1 = 0b1111_1111_1111_1111_1111_1111_1111_0001 (population = 29) -// CHECK: call $printW32ln printW32ln(clzWord32 e); // 20000 = 0x00004e20 (leading zeros = 17) -// CHECK: call $printW32ln printW32ln(ctzWord32 e); // 20000 = 0x00004e20 (trailing zeros = 5) assert (3 : Word32 ** (4 : Word32) == (81 : Word32)); @@ -74,55 +123,56 @@ let e : Word16 = 20000; -// CHECK: call $printW16ln printW16ln(+c); -// CHECK: call $printW16ln printW16ln(-c); -// CHECK: call $printW16ln printW16ln(^c); -// CHECK: call $printW16ln printW16ln(a + c); -// CHECK: call $printW16ln printW16ln(c - a); +// CHECK: call $checkpointDelta + checkpointDelta(); // CHECK: get_local $a +// This is not a native Wasm i32 multiplication, we need to shift one of the args left by 16 bits! // CHECK-NEXT: get_local $b // CHECK-NEXT: i32.const 16 // CHECK-NEXT: i32.shr_u // CHECK-NEXT: i32.mul // CHECK-NEXT: call $printW16ln printW16ln(a * b); -// CHECK: call $printW16ln printW16ln(a / b); -// CHECK: call $printW16ln printW16ln(c % a); -// CHECK: call $printW16ln printW16ln(a ** 2); -// CHECK: call $printW16ln printW16ln(a & c); -// CHECK: call $printW16ln printW16ln(a | c); -// CHECK: call $printW16ln printW16ln(a ^ c); -// CHECK: call $printW16ln printW16ln(a << b); +// CHECK: call $checkpointEcho + checkpointEcho(); // CHECK: get_local $b +// This is not a native Wasm i32 left shift, we need to shift the second arg left by 16 bits and clamp it to 4 bits! +// CHECK-NEXT: i32.const 16 +// CHECK-NEXT: i32.shr_u // CHECK-NEXT: i32.const 15 // CHECK-NEXT: i32.and // CHECK-NEXT: i32.shr_u +// Then the result must be sanitised. // CHECK-NEXT: i32.const -65536 // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW16ln printW16ln(a >> b); // printW16ln(shrs d b); // TODO(Gabor) +// CHECK: call $checkpointFoxtrot + checkpointFoxtrot(); // CHECK: get_local $b // CHECK-NEXT: call $rotl // CHECK-NEXT: call $printW16ln printW16ln(c <<> b); +// CHECK: call $checkpointGolf + checkpointGolf(); // CHECK: get_local $b // CHECK-NEXT: call $rotr // CHECK-NEXT: call $printW16ln @@ -149,48 +199,47 @@ let e : Word8 = 200; -// CHECK: call $printW8ln printW8ln(+c); -// CHECK: call $printW8ln printW8ln(-c); -// CHECK: call $printW8ln printW8ln(^c); -// CHECK: call $printW8ln printW8ln(a + c); -// CHECK: call $printW8ln printW8ln(c - a); +// CHECK: call $checkpointHotel + checkpointHotel(); // CHECK: get_local $b +// This is not a native Wasm i32 multiplication, we need to shift one of the args left by 24 bits! // CHECK-NEXT: i32.const 24 // CHECK-NEXT: i32.shr_u // CHECK-NEXT: i32.mul // CHECK-NEXT: call $printW8ln printW8ln(a * b); -// CHECK: call $printW8ln printW8ln(a / b); -// CHECK: call $printW8ln printW8ln(c % a); -// CHECK: call $printW8ln printW8ln(a ** 2); -// CHECK: call $printW8ln printW8ln(a & c); -// CHECK: call $printW8ln printW8ln(a | c); -// CHECK: call $printW8ln printW8ln(a ^ c); -// CHECK: call $printW8ln printW8ln(a << b); +// CHECK: call $checkpointIndia + checkpointIndia(); // CHECK: get_local $b +// This is not a native Wasm i32 left shift, we need to shift the second arg left by 24 bits and clamp it to 3 bits! +// CHECK-NEXT: i32.const 24 +// CHECK-NEXT: i32.shr_u // CHECK-NEXT: i32.const 7 // CHECK-NEXT: i32.and // CHECK-NEXT: i32.shr_u +// Then the result must be sanitised. // CHECK-NEXT: i32.const -16777216 // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW8ln printW8ln(a >> b); // printW8ln(shrs d b); // TODO(Gabor) +// CHECK: call $checkpointJuliett + checkpointJuliett(); // CHECK: get_local $b // CHECK-NEXT: call $rotl // CHECK-NEXT: call $printW8ln From 1f220c5ac4b41e967fe62febd9b15950733f29dd Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 14 Mar 2019 15:19:42 +0100 Subject: [PATCH 27/76] AST-33: Support popcnt/clz/ctz/shrs for Word8/Word16 (#238) * codegen for popcntWord8/16, also refactoring * interp/codegen clz/ctz for Word8/16 * interp/codegen shrs for Word8/16 --- src/compile.ml | 47 ++++++++++++++++++++++-- src/prelude.ml | 70 ++++++++++++++++++++++++------------ test/run/ok/words.run-ir.ok | 8 +++++ test/run/ok/words.run-low.ok | 8 +++++ test/run/ok/words.run.ok | 8 +++++ test/run/words.as | 16 ++++----- 6 files changed, 125 insertions(+), 32 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 07de524678b..f23aee91997 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1361,10 +1361,12 @@ module Prim = struct prim_word32toInt let prim_intToWord32 = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) - let prim_shiftToWordN b = - prim_intToWord32 ^^ + let prim_shift_leftWordNtoI32 b = compile_unboxed_const b ^^ G.i (Binary (I32 I32Op.Shl)) + let prim_shiftToWordN b = + prim_intToWord32 ^^ + prim_shift_leftWordNtoI32 b end (* Prim *) module Object = struct @@ -3384,12 +3386,23 @@ let lsb_adjust = function | Type.Word32 -> G.nop | ty -> Prim.prim_shiftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) +(* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) +let msb_adjust = function + | Type.Word32 -> G.nop + | ty -> Prim.prim_shift_leftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) + (* Makes sure that the word representation invariant is restored. *) let sanitize_word_result = function | Type.Word32 -> G.nop | ty -> compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ G.i (Binary (Wasm.Values.I32 I32Op.And)) +(* Makes sure that the word representation invariant is restored. *) +let compile_word_padding = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (UnboxedSmallWord.padding_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) + (* 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. @@ -3597,6 +3610,12 @@ and compile_exp (env : E.t) exp = in match p with | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) + | "shrs8" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word8 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word8) + | "shrs16" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word16 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word16) | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) @@ -3680,6 +3699,12 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) + | "popcnt8" + | "popcnt16" -> + SR.Vanilla, + compile_exp_vanilla env e ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ + msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) | "popcnt64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ @@ -3688,6 +3713,14 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "clz8" + | "clz16" -> + SR.Vanilla, + let ty = match p with | "clz8" -> Type.Word8 | _ -> Type.Word16 + in compile_exp_vanilla env e ^^ + compile_word_padding ty ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^ + msb_adjust ty | "clz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ @@ -3696,6 +3729,16 @@ and compile_exp (env : E.t) exp = SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | "ctz8" + | "ctz16" -> + SR.Vanilla, + let ty = match p with | "ctz8" -> Type.Word8 | _ -> Type.Word16 + in compile_exp_vanilla env e ^^ + compile_word_padding ty ^^ + compile_unboxed_const (UnboxedSmallWord.shift_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^ + msb_adjust ty | "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ diff --git a/src/prelude.ml b/src/prelude.ml index ef9b6ea5b8c..46eb20bc132 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -59,6 +59,16 @@ func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; // Exotic bitwise operations +func shrsWord8(w : Word8, amount : Word8) : Word8 = (prim "shrs8" : (Word8, Word8) -> Word8) (w, amount); +func popcntWord8(w : Word8) : Word8 = (prim "popcnt8" : Word8 -> Word8) w; +func clzWord8(w : Word8) : Word8 = (prim "clz8" : Word8 -> Word8) w; +func ctzWord8(w : Word8) : Word8 = (prim "ctz8" : Word8 -> Word8) w; + +func shrsWord16(w : Word16, amount : Word16) : Word16 = (prim "shrs16" : (Word16, Word16) -> Word16) (w, amount); +func popcntWord16(w : Word16) : Word16 = (prim "popcnt16" : Word16 -> Word16) w; +func clzWord16(w : Word16) : Word16 = (prim "clz16" : Word16 -> Word16) w; +func ctzWord16(w : Word16) : Word16 = (prim "ctz16" : Word16 -> Word16) w; + func shrsWord32(w : Word32, amount : Word32) : Word32 = (prim "shrs" : (Word32, Word32) -> Word32) (w, amount); func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; @@ -178,32 +188,48 @@ let prim = function | "Word32->Char" -> fun v k -> let i = Conv.of_signed_Word32 (as_word32 v) in k (Char i) - | "shrs" -> fun v k -> - let w, a = as_pair v in - let i = Word32.shr_s (as_word32 w) (as_word32 a) - in k (Word32 i) + | "shrs8" + | "shrs16" + | "shrs" | "shrs64" -> fun v k -> - let w, a = as_pair v in - let i = Word64.shr_s (as_word64 w) (as_word64 a) - in k (Word64 i) - | "popcnt" -> fun v k -> - let i = Word32.popcnt (as_word32 v) - in k (Word32 i) + let w, a = as_pair v + in k (match w with + | Word8 y -> Word8 (Word8 .shr_s y (as_word8 a)) + | Word16 y -> Word16 (Word16.shr_s y (as_word16 a)) + | Word32 y -> Word32 (Word32.shr_s y (as_word32 a)) + | Word64 y -> Word64 (Word64.shr_s y (as_word64 a)) + | _ -> failwith "shrs") + | "popcnt8" + | "popcnt16" + | "popcnt" | "popcnt64" -> fun v k -> - let i = Word64.popcnt (as_word64 v) - in k (Word64 i) - | "clz" -> fun v k -> - let i = Word32.clz (as_word32 v) - in k (Word32 i) + k (match v with + | Word8 w -> Word8 (Word8. popcnt w) + | Word16 w -> Word16 (Word16.popcnt w) + | Word32 w -> Word32 (Word32.popcnt w) + | Word64 w -> Word64 (Word64.popcnt w) + | _ -> failwith "popcnt") + | "clz8" + | "clz16" + | "clz" | "clz64" -> fun v k -> - let i = Word64.clz (as_word64 v) - in k (Word64 i) - | "ctz" -> fun v k -> - let i = Word32.ctz (as_word32 v) - in k (Word32 i) + k (match v with + | Word8 w -> Word8 (Word8. clz w) + | Word16 w -> Word16 (Word16.clz w) + | Word32 w -> Word32 (Word32.clz w) + | Word64 w -> Word64 (Word64.clz w) + | _ -> failwith "clz") + | "ctz8" + | "ctz16" + | "ctz" | "ctz64" -> fun v k -> - let i = Word64.ctz (as_word64 v) - in k (Word64 i) + k (match v with + | Word8 w -> Word8 (Word8. ctz w) + | Word16 w -> Word16 (Word16.ctz w) + | Word32 w -> Word32 (Word32.ctz w) + | Word64 w -> Word64 (Word64.ctz w) + | _ -> failwith "ctz") + | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit | "Array.init" -> fun v k -> diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index 4eaea15a04f..15c4b3b8c29 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -54,8 +54,12 @@ 51297 -14239 60288 -5248 35 35 +65534 -2 56172 -9364 28083 28083 +13 13 +1 1 +5 5 34 34 222 -34 221 -35 @@ -70,5 +74,9 @@ 97 97 128 -128 0 0 +254 -2 17 17 68 68 +5 5 +0 0 +3 3 diff --git a/test/run/words.as b/test/run/words.as index 30179b9091b..a6a2cd0128a 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -162,7 +162,7 @@ func checkpointJuliett() {}; // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW16ln printW16ln(a >> b); - // printW16ln(shrs d b); // TODO(Gabor) + printW16ln(shrsWord16(d, 3 : Word16)); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (shifted = 0b1111_1111_1111_1110 = -2) // CHECK: call $checkpointFoxtrot checkpointFoxtrot(); @@ -177,9 +177,9 @@ func checkpointJuliett() {}; // CHECK-NEXT: call $rotr // CHECK-NEXT: call $printW16ln printW16ln(c <>> b); - // printW16ln(popcnt d); // TODO(Gabor) - // printW16ln(clz c); // TODO(Gabor) - // printW16ln(ctz e); // TODO(Gabor) + printW16ln(popcntWord16 d); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (population = 13) + printW16ln(clzWord16 e); // 20000 = 0x4e20 (leading zeros = 1) + printW16ln(ctzWord16 e); // 20000 = 0x4e20 (trailing zeros = 5) assert (3 : Word16 ** (0 : Word16) == (1 : Word16)); @@ -236,7 +236,7 @@ func checkpointJuliett() {}; // CHECK-NEXT: i32.and // CHECK-NEXT: call $printW8ln printW8ln(a >> b); - // printW8ln(shrs d b); // TODO(Gabor) + printW8ln(shrsWord8(d, 3 : Word8)); // -15 = 0xf1 = 0b1111_0001 (shifted = 0b1111_1110 = -2) // CHECK: call $checkpointJuliett checkpointJuliett(); @@ -248,9 +248,9 @@ func checkpointJuliett() {}; // CHECK-NEXT: call $rotr // CHECK-NEXT: call $printW8ln printW8ln(c <>> b); - // printW8ln(popcnt d); // TODO(Gabor) - // printW8ln(clz c); // TODO(Gabor) - // printW8ln(ctz e); // TODO(Gabor) + printW8ln(popcntWord8 d); // -15 = 0xf1 = 0b1111_0001 (population = 5) + printW8ln(clzWord8 e); // 200 = 0xC8 (leading zeros = 0) + printW8ln(ctzWord8 e); // 200 = 0xC8 (trailing zeros = 3) assert (3 : Word8 ** (0 : Word8) == (1 : Word8)); assert (3 : Word8 ** (3 : Word8) == (27 : Word8)); From 39945d96054719e71a283fadf2cc9805fd557361 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 23:37:13 +0100 Subject: [PATCH 28/76] Remove asyncreturn test case we do not support polymorphic messages --- test/run/asyncreturn.as | 18 ------------------ test/run/ok/asyncreturn.run-ir.ok | 1 - test/run/ok/asyncreturn.run-low.ok | 1 - test/run/ok/asyncreturn.run.ok | 1 - test/run/ok/asyncreturn.wasm-run.ok | 1 - 5 files changed, 22 deletions(-) delete mode 100644 test/run/asyncreturn.as delete mode 100644 test/run/ok/asyncreturn.run-ir.ok delete mode 100644 test/run/ok/asyncreturn.run-low.ok delete mode 100644 test/run/ok/asyncreturn.run.ok delete mode 100644 test/run/ok/asyncreturn.wasm-run.ok diff --git a/test/run/asyncreturn.as b/test/run/asyncreturn.as deleted file mode 100644 index 177e40c68d7..00000000000 --- a/test/run/asyncreturn.as +++ /dev/null @@ -1,18 +0,0 @@ -// works -func call1(f : shared () -> ()) : () { f(); }; -func call2(f : shared () -> async B) : async B { await f(); }; -// does not work -// func call3(f : shared () -> C) : C { f (); }; - -let a = actor { get42() : async Nat = async { 42 }; }; -let _ = async { printInt(await (call2(a.get42))); }; - - -//func call3(f : shared () -> async B) : async B { f(); }; - -func call3(f : shared () -> async B) : async B = f() ; - -// illegal: -// shared func call4(f : shared () -> async B) : async B = f() ; - -shared func call4(f : shared () -> async B) : async B = async await f() ; \ No newline at end of file diff --git a/test/run/ok/asyncreturn.run-ir.ok b/test/run/ok/asyncreturn.run-ir.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run-ir.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.run-low.ok b/test/run/ok/asyncreturn.run-low.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run-low.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.run.ok b/test/run/ok/asyncreturn.run.ok deleted file mode 100644 index d81cc0710eb..00000000000 --- a/test/run/ok/asyncreturn.run.ok +++ /dev/null @@ -1 +0,0 @@ -42 diff --git a/test/run/ok/asyncreturn.wasm-run.ok b/test/run/ok/asyncreturn.wasm-run.ok deleted file mode 100644 index 0b80fcc95f3..00000000000 --- a/test/run/ok/asyncreturn.wasm-run.ok +++ /dev/null @@ -1 +0,0 @@ -_out/asyncreturn.wasm:0x___: runtime trap: unreachable executed From 979665cae23cd7f0f723f2a978105ab49ab8f065 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 14:41:18 +0100 Subject: [PATCH 29/76] Introduce a primitive type for elembufs --- src/arrange_type.ml | 1 + src/type.ml | 3 +++ src/type.mli | 1 + 3 files changed, 5 insertions(+) diff --git a/src/arrange_type.ml b/src/arrange_type.ml index f6a2762e7bd..e6e0d54749e 100644 --- a/src/arrange_type.ml +++ b/src/arrange_type.ml @@ -30,6 +30,7 @@ let prim p = match p with | Float -> Atom "Float" | Char -> Atom "Char" | Text -> Atom "Text" + | ElemBuf -> Atom "ElemBuf" let con c = Atom (Con.to_string c) diff --git a/src/type.ml b/src/type.ml index 18db3887d21..33fbcde6f98 100644 --- a/src/type.ml +++ b/src/type.ml @@ -20,6 +20,7 @@ type prim = | Float | Char | Text + | ElemBuf type t = typ and typ = @@ -324,6 +325,7 @@ let rec span = function | Prim Word8 -> Some 0x100 | Prim Word16 -> Some 0x10000 | Prim (Word32 | Word64 | Char) -> None (* for all practical purpuses *) + | Prim ElemBuf -> None | Obj _ | Tup _ | Async _ -> Some 1 | Array _ | Func _ | Shared | Any -> None | Opt _ -> Some 2 @@ -571,6 +573,7 @@ let string_of_prim = function | Word64 -> "Word64" | Char -> "Char" | Text -> "Text" + | ElemBuf -> "ElemBuf" let string_of_var (x, i) = if i = 0 then sprintf "%s" x else sprintf "%s.%d" x i diff --git a/src/type.mli b/src/type.mli index 9fb29dd4d07..47a55f04311 100644 --- a/src/type.mli +++ b/src/type.mli @@ -20,6 +20,7 @@ type prim = | Float | Char | Text + | ElemBuf type t = typ and typ = From 7f12768adea476ec53e1bc6d80438af67e574124 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 17:48:12 +0100 Subject: [PATCH 30/76] Create a pass that inserts calls to serialize/deserialize which requires a new primitive type for `elembufs` (the current representation of data). This prepares for type-driven serialization, by isolating the points where serialization happens. Serialization is still based on the dynamic type. The failing `asyncreturn` is because of the polymorphic message type there, which we do not support. There is some extra reference boxing/unboxing introduced now, which I will get rid of separately. --- src/compile.ml | 43 ++- src/pipeline.ml | 5 + src/prelude.ml | 2 + src/serialization.ml | 261 ++++++++++++++++++ src/value.ml | 2 + src/value.mli | 2 + .../ok/counter-class.wasm.stderr.ok | 41 +-- test/run.sh | 21 +- 8 files changed, 335 insertions(+), 42 deletions(-) create mode 100644 src/serialization.ml diff --git a/src/compile.ml b/src/compile.ml index f23aee91997..1b245137971 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2685,19 +2685,6 @@ 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, I32Type) 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 (LocalGet (nr (Int32.of_int i))) ^^ serialize env - ) - ) - let deserialize env = Func.share_code1 env "deserialize" ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> let (set_databuf, get_databuf) = new_local env "databuf" in @@ -3030,6 +3017,21 @@ module StackRep = struct (to_string sr_in) (to_string sr_out); G.nop + (* TODO: Replace this hack with nested stackreps *) + let unbox_reference_n env n = match n with + | 0 -> G.nop + | 1 -> adjust env SR.Vanilla SR.UnboxedReference + | _ -> + let name = Printf.sprintf "unbox_reference_n %i" n 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 -> + G.i (LocalGet (nr (Int32.of_int i))) ^^ adjust env SR.Vanilla SR.UnboxedReference + ) + ) + + end (* StackRep *) @@ -3118,7 +3120,8 @@ module FuncDec = struct closure_code ^^ let get i = G.i (LocalGet (nr Int32.(add 1l (of_int i)))) ^^ - Serialization.deserialize env in + (* TODO: Expose unboxed reference here *) + StackRep.adjust env SR.UnboxedReference SR.Vanilla in destruct_args_code get ^^ mk_body env3 ^^ @@ -3625,6 +3628,16 @@ and compile_exp (env : E.t) exp = | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> begin match p with + | "@serialize" -> + SR.UnboxedReference, + compile_exp_vanilla env e ^^ + Serialization.serialize env + + | "@deserialize" -> + SR.Vanilla, + compile_exp_as env SR.UnboxedReference e ^^ + Serialization.deserialize env + | "abs" -> SR.Vanilla, compile_exp_vanilla env e ^^ @@ -3863,7 +3876,7 @@ and compile_exp (env : E.t) exp = code1 ^^ StackRep.adjust env fun_sr SR.UnboxedReference ^^ set_funcref ^^ compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ - Serialization.serialize_n env cc.Value.n_args ^^ + StackRep.unbox_reference_n env cc.Value.n_args ^^ FuncDec.call_funcref env cc get_funcref end | SwitchE (e, cs) -> diff --git a/src/pipeline.ml b/src/pipeline.ml index eb59f78b963..675f1064d89 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -132,6 +132,9 @@ let await_lowering = let async_lowering = transform_ir "Async Lowering" Async.transform +let serialization = + transform_ir "Synthesizing serialization code" Serialization.transform + let tailcall_optimization = transform_ir "Tailcall optimization" (fun _ -> Tailcall.transform) @@ -168,6 +171,7 @@ let interpret_prog (senv,denv) name prog : (Value.value * Interpret.scope) optio Check_ir.check_prog senv "desugaring" prog_ir; let prog_ir = await_lowering (!Flags.await_lowering) senv prog_ir name in let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in + let prog_ir = serialization (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in let prog_ir = tailcall_optimization true senv prog_ir name in Interpret_ir.interpret_prog denv prog_ir else Interpret.interpret_prog denv prog in @@ -294,6 +298,7 @@ let compile_with check mode name : compile_result = Check_ir.check_prog initial_stat_env "desugaring" prog; let prog = await_lowering true initial_stat_env prog name in let prog = async_lowering true initial_stat_env prog name in + let prog = serialization true initial_stat_env prog name in let prog = tailcall_optimization true initial_stat_env prog name in phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in diff --git a/src/prelude.ml b/src/prelude.ml index 46eb20bc132..41deded215d 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -232,6 +232,8 @@ let prim = function | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit + | "@serialize" -> fun v k -> k (Serialized v) + | "@deserialize" -> fun v k -> k (as_serialized v) | "Array.init" -> fun v k -> (match Value.as_tup v with | [len; x] -> diff --git a/src/serialization.ml b/src/serialization.ml new file mode 100644 index 00000000000..32403bfc3d4 --- /dev/null +++ b/src/serialization.ml @@ -0,0 +1,261 @@ +open Source +open Ir +module T = Type +open Construct + +(* +This transforms + * the types of shared functions to pass ElemBufs (according to their arity) + * shared function definitions to call deserialize on the arguments + * calls to shared functions to call serialize on the arguments +*) + +module Transform() = struct + + module ConRenaming = Env.Make(struct type t = T.con let compare = Con.compare end) + + (* the state *) + + (* maps constructors to new constructors (new name, new stamp, new kind) + it is initialized with the type constructors defined outside here, which are + not rewritten. + + If we run this translation on two program fragments (e.g. prelude and program) + we would have to pass down the `con_renaming`. But this is simply the right thing + to do for a pass that changes the context. + *) + + let con_renaming = ref ConRenaming.empty + + (* The type of a serialized argument *) + let arg_t = T.Prim T.ElemBuf + + let deserialize e t = + primE "@deserialize" (T.Func (T.Local, T.Returns, [], [arg_t], [t])) + -*- e + let serialize e = + primE "@serialize" (T.Func (T.Local, T.Returns, [], [e.note.note_typ], [arg_t])) + -*- e + + let map_tuple n f e = + if n = 0 then e else + (* TODO: optimize if e is a manifest tuple *) + let ts = T.as_tup e.note.note_typ in + assert (List.length ts = n); + let vs = List.map fresh_var ts in + blockE [letP (seqP (List.map varP vs)) e] + (tupE (List.map serialize vs)) + + let rec t_typ (t:T.typ) = + match t with + | T.Prim _ + | T.Shared + | T.Any + | T.Non + | T.Pre + | T.Var _ -> t + + | T.Con (c, ts) -> + T.Con (t_con c, List.map t_typ ts) + | T.Array t -> T.Array (t_typ t) + | T.Tup ts -> T.Tup (List.map t_typ ts) + | T.Func (T.Sharable, c, tbs, t1, t2) -> + assert (c = T.Returns); + assert (tbs = []); (* We do not support parametric messages *) + assert (t2 = []); (* A returning sharable function has no return values *) + T.Func (T.Sharable, T.Returns, [], List.map (fun _ -> arg_t) t1, []) + | T.Func (T.Local, c, tbs, t1, t2) -> + T.Func (T.Local, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2) + | T.Opt t -> T.Opt (t_typ t) + | T.Obj (s, fs) -> T.Obj (s, List.map t_field fs) + | T.Mut t -> T.Mut (t_typ t) + + | T.Async t -> assert false (* Should happen after async-translation *) + + and t_bind {T.var; T.bound} = + {T.var; T.bound = t_typ bound} + + and t_binds typbinds = List.map t_bind typbinds + + and t_kind k = + match k with + | T.Abs(typ_binds,typ) -> + T.Abs(t_binds typ_binds, t_typ typ) + | T.Def(typ_binds,typ) -> + T.Def(t_binds typ_binds, t_typ typ) + + and t_con c = + match ConRenaming.find_opt c (!con_renaming) with + | Some c' -> c' + | None -> + let clone = Con.clone c (T.Abs ([], T.Pre)) in + con_renaming := ConRenaming.add c clone (!con_renaming); + (* Need to extend con_renaming before traversing the kind *) + Type.set_kind clone (t_kind (Con.kind c)); + clone + + and t_field {T.lab; T.typ} = + { T.lab; T.typ = t_typ typ } + + let rec t_exp (exp: exp) = + { it = t_exp' exp; + note = { note_typ = t_typ exp.note.note_typ; + note_eff = exp.note.note_eff}; + at = exp.at; + } + and t_exp' (exp:exp) = + let exp' = exp.it in + match exp' with + | CallE (cc, exp1, typs, exp2) -> + begin match cc.Value.sort with + | T.Local -> + CallE(cc, t_exp exp1, List.map t_typ typs, t_exp exp2) + | T.Sharable -> + assert (typs = []); + assert (T.is_unit exp.note.note_typ); + if cc.Value.n_args = 1 + then + let exp2' = serialize (t_exp exp2) in + CallE (cc, t_exp exp1, [], exp2') + else + let exp2' = map_tuple cc.Value.n_args serialize (t_exp exp2) in + CallE (cc, t_exp exp1, [], exp2') + end + | FuncE (x, cc, typbinds, pat, typT, exp) -> + begin match cc.Value.sort with + | T.Local -> + FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + | T.Sharable -> + assert (typbinds = []); + assert (T.is_unit typT); + match cc.Value.n_args with + | 0 -> FuncE (x, cc, [], t_pat pat, T.unit, t_exp exp) + | 1 -> + let arg_ty = t_typ pat.note in + let arg_v = fresh_var arg_t in + let pat' = varP arg_v in + let body' = + blockE [letP (t_pat pat) (deserialize arg_v arg_ty) ] + (t_exp exp) in + FuncE (x, cc, [], pat', T.unit, body') + | _ -> + let arg_tys = List.map t_typ (T.as_tup pat.note) in + let arg_vs = Lib.List.table cc.Value.n_args (fun _ -> fresh_var arg_t) in + let pat' = seqP (List.map varP arg_vs) in + let body' = + (* TODO: Optimize if pat is a manifest tuple pattern *) + blockE [letP (t_pat pat) (tupE (List.map2 deserialize arg_vs arg_tys)) ] + (t_exp exp) in + FuncE (x, cc, [], pat', T.unit, body') + end + | PrimE _ + | LitE _ -> exp' + | VarE id -> exp' + | UnE (ot, op, exp1) -> + UnE (t_typ ot, op, t_exp exp1) + | BinE (ot, exp1, op, exp2) -> + BinE (t_typ ot, t_exp exp1, op, t_exp exp2) + | RelE (ot, exp1, op, exp2) -> + RelE (t_typ ot, t_exp exp1, op, t_exp exp2) + | TupE exps -> + TupE (List.map t_exp exps) + | OptE exp1 -> + OptE (t_exp exp1) + | ProjE (exp1, n) -> + ProjE (t_exp exp1, n) + | DotE (exp1, id) -> + DotE (t_exp exp1, id) + | ActorDotE (exp1, id) -> + ActorDotE (t_exp exp1, id) + | AssignE (exp1, exp2) -> + AssignE (t_exp exp1, t_exp exp2) + | ArrayE (mut, t, exps) -> + ArrayE (mut, t_typ t, List.map t_exp exps) + | IdxE (exp1, exp2) -> + IdxE (t_exp exp1, t_exp exp2) + | BlockE b -> + BlockE (t_block b) + | IfE (exp1, exp2, exp3) -> + IfE (t_exp exp1, t_exp exp2, t_exp exp3) + | SwitchE (exp1, cases) -> + let cases' = List.map + (fun {it = {pat;exp}; at; note} -> + {it = {pat = t_pat pat ;exp = t_exp exp}; at; note}) + cases + in + SwitchE (t_exp exp1, cases') + | LoopE exp1 -> + LoopE (t_exp exp1) + | LabelE (id, typ, exp1) -> + LabelE (id, t_typ typ, t_exp exp1) + | BreakE (id, exp1) -> + BreakE (id, t_exp exp1) + | RetE exp1 -> + RetE (t_exp exp1) + | AsyncE _ -> assert false + | AwaitE _ -> assert false + | AssertE exp1 -> + AssertE (t_exp exp1) + | DeclareE (id, typ, exp1) -> + DeclareE (id, t_typ typ, t_exp exp1) + | DefineE (id, mut ,exp1) -> + DefineE (id, mut, t_exp exp1) + | ActorE (id, ds, fs, typ) -> + ActorE (id, t_decs ds, t_fields fs, t_typ typ) + | NewObjE (sort, ids, t) -> + NewObjE (sort, t_fields ids, t_typ t) + + and t_dec dec = { dec with it = t_dec' dec.it } + + and t_dec' dec' = + match dec' with + | TypD con_id -> TypD (t_con con_id) + | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) + | VarD (id,exp) -> VarD (id,t_exp exp) + + and t_decs decs = List.map t_dec decs + + and t_block (ds, exp) = (t_decs ds, t_exp exp) + + and t_fields fs = + List.map (fun f -> { f with note = t_typ f.note }) fs + + and t_pat pat = + { pat with + it = t_pat' pat.it; + note = t_typ pat.note } + + and t_pat' pat = + match pat with + | WildP + | LitP _ + | VarP _ -> + pat + | TupP pats -> + TupP (List.map t_pat pats) + | OptP pat1 -> + OptP (t_pat pat1) + | AltP (pat1, pat2) -> + AltP (t_pat pat1, t_pat pat2) + + and t_typ_bind' {con; bound} = + {con = t_con con; bound = t_typ bound} + + and t_typ_bind typ_bind = + { typ_bind with it = t_typ_bind' typ_bind.it } + + and t_typ_binds typbinds = List.map t_typ_bind typbinds + + and t_prog (prog, flavor) = (t_block prog, flavor) + +end + +let transform env prog = + let module T = Transform() in + (* + Initialized the con_renaming with those type constructors already in scope. + Eventually, pipeline will allow us to pass the con_renaming to downstream program + fragments, then we would simply start with an empty con_renaming and the prelude. + *) + Type.ConSet.iter (fun c -> T.con_renaming := T.ConRenaming.add c c (!T.con_renaming)) env.Typing.con_env; + T.t_prog prog diff --git a/src/value.ml b/src/value.ml index 763fb3afc7b..e264740a87e 100644 --- a/src/value.ml +++ b/src/value.ml @@ -222,6 +222,7 @@ and value = | Func of call_conv * func | Async of async | Mut of value ref + | Serialized of value and async = {result : def; mutable waiters : value cont list} and def = value Lib.Promise.t @@ -258,6 +259,7 @@ let as_opt = function Opt v -> v | _ -> invalid "as_opt" let as_tup = function Tup vs -> vs | _ -> invalid "as_tup" let as_unit = function Tup [] -> () | _ -> invalid "as_unit" let as_pair = function Tup [v1; v2] -> v1, v2 | _ -> invalid "as_pair" +let as_serialized = function Serialized v -> v | _ -> invalid "as_serialized" let obj_of_array a = let get = local_func 1 1 @@ fun v k -> diff --git a/src/value.mli b/src/value.mli index c0362d0f063..7d51d1042ab 100644 --- a/src/value.mli +++ b/src/value.mli @@ -87,6 +87,7 @@ and value = | Func of call_conv * func | Async of async | Mut of value ref + | Serialized of value and async = {result : def; mutable waiters : value cont list} and def = value Lib.Promise.t @@ -129,6 +130,7 @@ val as_obj : value -> value Env.t val as_func : value -> call_conv * func val as_async : value -> async val as_mut : value -> value ref +val as_serialized : value -> value (* Ordering *) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 228392766dd..57deb5948b5 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -19,25 +19,32 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (VarP $2) + (VarP $4) () (BlockE - (LetD (TupP) (TupE)) - (CallE - ( 1 -> 0) - (FuncE - $lambda + (LetD (VarP $2) (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $4))) + (BlockE + (LetD (TupP) (TupE)) + (CallE ( 1 -> 0) - (VarP $1) - () - (CallE ( 1 -> 0) (VarE $1) (VarE c)) - ) - (FuncE - $lambda - ( 1 -> 0) - (VarP $3) - () - (CallE (shared 1 -> 0) (VarE $2) (VarE $3)) + (FuncE + $lambda + ( 1 -> 0) + (VarP $1) + () + (CallE ( 1 -> 0) (VarE $1) (VarE c)) + ) + (FuncE + $lambda + ( 1 -> 0) + (VarP $3) + () + (CallE + (shared 1 -> 0) + (VarE $2) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $3)) + ) + ) ) ) ) @@ -45,5 +52,5 @@ non-closed actor: (ActorE ) (read read) (dec dec) - actor {dec : shared () -> (); read : shared (shared Int -> ()) -> ()} + actor {dec : shared () -> (); read : shared ElemBuf -> ()} ) diff --git a/test/run.sh b/test/run.sh index 287eb517336..cebe0283ca6 100755 --- a/test/run.sh +++ b/test/run.sh @@ -101,16 +101,6 @@ do normalize $out/$base.run diff_files="$diff_files $base.run" - # Interpret with lowering - $ECHO -n " [run-low]" - $ASC $ASC_FLAGS -r -a -A $base.as > $out/$base.run-low 2>&1 - normalize $out/$base.run-low - diff_files="$diff_files $base.run-low" - - # Diff interpretations without/with lowering - diff -u -N --label "$base.run" $out/$base.run --label "$base.run-low" $out/$base.run-low > $out/$base.diff-low - diff_files="$diff_files $base.diff-low" - # Interpret IR $ECHO -n " [run-ir]" $ASC $ASC_FLAGS -r -iR $base.as > $out/$base.run-ir 2>&1 @@ -120,6 +110,17 @@ do # Diff interpretations without/with lowering diff -u -N --label "$base.run" $out/$base.run --label "$base.run-ir" $out/$base.run-ir > $out/$base.diff-ir diff_files="$diff_files $base.diff-ir" + + # Interpret IR with lowering + $ECHO -n " [run-low]" + $ASC $ASC_FLAGS -r -iR -a -A $base.as > $out/$base.run-low 2>&1 + normalize $out/$base.run-low + diff_files="$diff_files $base.run-low" + + # Diff interpretations without/with lowering + diff -u -N --label "$base.run" $out/$base.run --label "$base.run-low" $out/$base.run-low > $out/$base.diff-low + diff_files="$diff_files $base.diff-low" + fi # Compile From 4efd91586f3cb3d5b8354186494a062353541353 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 22:40:22 +0100 Subject: [PATCH 31/76] Ir: FuncE takes a list of names, not a full pattern if we have n-ary functions, then really a function definition ought to have n named arguments, rather than a full pattern, and the desugarer should move the pattern into a `LetD`, if necessary. I did this in order to unbox function arguments more easily, but I think it is generally a useful direction. --- src/arrange_ir.ml | 9 +- src/async.ml | 27 ++-- src/check_ir.ml | 21 ++- src/compile.ml | 129 +++++++++--------- src/construct.ml | 51 +++++-- src/construct.mli | 6 +- src/desugar.ml | 68 +++++++-- src/freevars.ml | 10 +- src/interpret_ir.ml | 60 ++++---- src/ir.ml | 5 +- src/rename.ml | 14 +- src/serialization.ml | 35 ++--- src/tailcall.ml | 56 +++++--- .../fail/ok/use-before-define5.wasm.stderr.ok | 1 - .../ok/counter-class.wasm.stderr.ok | 45 +++--- 15 files changed, 332 insertions(+), 205 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 55342674817..3d5a48fb29a 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -36,13 +36,18 @@ let rec exp e = match e.it with | PrimE p -> "PrimE" $$ [Atom p] | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1] | DefineE (i, m, e1) -> "DefineE" $$ [id i; Arrange.mut m; exp e1] - | FuncE (x, cc, tp, p, t, e) -> - "FuncE" $$ [Atom x; call_conv cc] @ List.map typ_bind tp @ [pat p; typ t; exp e] + | FuncE (x, cc, tp, as_, t, e) -> + "FuncE" $$ [Atom x; call_conv cc] @ List.map typ_bind tp @ args as_@ [ typ t; exp e] | ActorE (i, ds, fs, t) -> "ActorE" $$ [id i] @ List.map dec ds @ fields fs @ [typ t] | NewObjE (s, fs, t) -> "NewObjE" $$ (Arrange.obj_sort' s :: fields fs @ [typ t]) and fields fs = List.fold_left (fun flds f -> (name f.it.name $$ [ id f.it.var ]):: flds) [] fs +and args = function + | [] -> [] + | as_ -> ["params" $$ List.map arg as_] + +and arg a = Atom a.it and pat p = match p.it with | WildP -> Atom "WildP" diff --git a/src/async.ml b/src/async.ml index 3ff158b8cac..9d8f505c68d 100644 --- a/src/async.ml +++ b/src/async.ml @@ -117,16 +117,6 @@ module Transform() = struct let extendTup ts t2 = ts @ [t2] - let extendTupP p1 p2 = - match p1.it with - | TupP ps -> - begin - match ps with - | [] -> p2, fun e -> blockE [letP p1 (tupE [])] e - | ps -> tupP (ps@[p2]), fun e -> e - end - | _ -> tupP [p1;p2], fun e -> e - (* Given sequence type ts, bind e of type (seq ts) to a sequence of expressions supplied to decs d_of_es, preserving effects of e when the sequence type is empty. @@ -320,25 +310,24 @@ module Transform() = struct DeclareE (id, t_typ typ, t_exp exp1) | DefineE (id, mut ,exp1) -> DefineE (id, mut, t_exp exp1) - | FuncE (x, cc, typbinds, pat, typT, exp) -> + | FuncE (x, cc, typbinds, args, typT, exp) -> let s = cc.Value.sort in begin match s with | T.Local -> - FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Sharable -> begin match typ exp with | T.Tup [] -> - FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Async res_typ -> let cc' = Value.message_cc (cc.Value.n_args + 1) in let res_typ = t_typ res_typ in - let pat = t_pat pat in let reply_typ = replyT nary res_typ in let typ' = T.Tup [] in let k = fresh_var reply_typ in - let pat',d = extendTupP pat (varP k) in + let args' = t_args args @ [ arg_of_exp k ] in let typbinds' = t_typ_binds typbinds in let y = fresh_var res_typ in let exp' = @@ -346,12 +335,12 @@ module Transform() = struct | CallE(_, async,_,cps) -> begin match async.it with - | PrimE("@async") -> d ((t_exp cps) -*- (y --> (k -*- y))) + | PrimE("@async") -> ((t_exp cps) -*- (y --> (k -*- y))) | _ -> assert false end | _ -> assert false in - FuncE (x, cc', typbinds', pat', typ', exp') + FuncE (x, cc', typbinds', args', typ', exp') | _ -> assert false end end @@ -375,6 +364,10 @@ module Transform() = struct and t_fields fs = List.map (fun f -> { f with note = t_typ f.note }) fs + and t_args as_ = List.map t_arg as_ + + and t_arg a = { a with note = t_typ a.note } + and t_pat pat = { pat with it = t_pat' pat.it; diff --git a/src/check_ir.ml b/src/check_ir.ml index 4facadbdfdc..266b7e51776 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -470,10 +470,10 @@ let rec check_exp env (exp:Ir.exp) : unit = typ exp1 <: t0 end; T.unit <: t - | FuncE (x, cc, typ_binds, pat, ret_ty, exp) -> + | FuncE (x, cc, typ_binds, args, ret_ty, exp) -> let cs, tbs, ce = check_open_typ_binds env typ_binds in let env' = adjoin_cons env ce in - let ve = check_pat_exhaustive env' pat in + let ve = check_args env' args in check_typ env' ret_ty; check ((cc.Value.sort = T.Sharable && Type.is_async ret_ty) ==> isAsyncE exp) @@ -483,10 +483,7 @@ let rec check_exp env (exp:Ir.exp) : unit = check_exp (adjoin_vals env'' ve) exp; check_sub env' exp.at (typ exp) ret_ty; (* Now construct the function type and compare with the annotation *) - let arg_ty = pat.note in - let ts1 = if cc.Value.n_args = 1 - then [arg_ty] - else T.as_seq arg_ty in + let ts1 = List.map (fun a -> a.note) args in let ts2 = if cc.Value.n_res = 1 then [ret_ty] else T.as_seq ret_ty in @@ -523,6 +520,18 @@ and check_case env t_pat t {it = {pat; exp}; _} = if not (T.sub (typ exp) t) then error env exp.at "bad case" +(* Arguments *) + +and check_args env args = + let rec go ve = function + | [] -> ve + | a::as_ -> + if T.Env.mem a.it ve + then error env a.at "duplicate binding for %s in argument list" a.it; + check_typ env a.note; + go (T.Env.add a.it a.note ve) as_ + in go T.Env.empty args + (* Patterns *) and gather_pat env ve0 pat : val_env = diff --git a/src/compile.ml b/src/compile.ml index 1b245137971..9e13d9f6474 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -132,6 +132,7 @@ type 'env varloc = and 'env deferred_loc = { materialize : 'env -> (SR.t * G.t) ; materialize_vanilla : 'env -> G.t + ; is_local : bool (* Only valid within the current function *) } module E = struct @@ -222,7 +223,7 @@ module E = struct | Local _ -> false | HeapInd _ -> false | Static _ -> true - | Deferred _ -> true + | Deferred d -> not d.is_local let mk_fun_env env n_param n_res = { env with n_param; @@ -272,7 +273,9 @@ module E = struct let add_local_deferred_vanilla (env : t) name materialize = let d = { materialize = (fun env -> (SR.Vanilla, materialize env)); - materialize_vanilla = (fun env -> materialize env) } in + materialize_vanilla = materialize; + is_local = false + } in add_local_deferred env name d let add_direct_local (env : t) name = @@ -999,7 +1002,17 @@ module Var = struct | Some (Static i) -> ( compile_unboxed_zero, fun env1 -> (E.add_local_static env1 var i, G.i Drop)) | Some (Deferred d) -> - ( compile_unboxed_zero, fun env1 -> (E.add_local_deferred env1 var d, G.i Drop)) + if d.is_local + then + ( d.materialize_vanilla env, + fun env1 -> + let (env2, j) = E.add_direct_local env1 var in + let restore_code = G.i (LocalSet (nr j)) + in (env2, restore_code) + ) + else + ( 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. @@ -2988,6 +3001,7 @@ module StackRep = struct let deferred_of_static_thing env s = { materialize = (fun env -> (StaticThing s, G.nop)) ; materialize_vanilla = (fun env -> materialize env s) + ; is_local = false } let adjust env (sr_in : t) sr_out = @@ -3074,20 +3088,30 @@ module FuncDec = struct (* Create a WebAssembly func from a pattern (for the argument) and the body. 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, I32Type) in + let compile_local_function env cc restore_env args mk_body at = + let arg_names = 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 ( + Func.of_body env (["clos", I32Type] @ arg_names) retty (fun env1 -> G.with_region at ( let get_closure = G.i (LocalGet (nr 0l)) in let (env2, closure_code) = restore_env env1 get_closure in - (* Destruct the argument *) - let (env3, destruct_args_code) = mk_pat env2 in + (* Add arguments to the environment *) + let env3 = + let rec go i env = function + | [] -> env + | a::as_ -> + let get env = G.i (LocalGet (nr (Int32.of_int i))) in + let env' = + E.add_local_deferred env a.it + { materialize = (fun env -> SR.Vanilla, get env) + ; materialize_vanilla = get + ; is_local = true + } in + go (i+1) env' as_ in + go 1 (* skip closure*) env2 args in closure_code ^^ - let get i = G.i (LocalGet (nr Int32.(add 1l (of_int i)))) in - destruct_args_code get ^^ mk_body env3 )) @@ -3099,10 +3123,10 @@ module FuncDec = struct - Do GC at the end - 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, I32Type) in + let compile_message env cc restore_env args mk_body at = + let arg_names = 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", I32Type] @ args) [] (fun env1 -> G.with_region at ( + Func.of_body env (["clos", I32Type] @ arg_names) [] (fun env1 -> G.with_region at ( (* Restore memory *) OrthogonalPersistence.restore_mem env1 ^^ @@ -3114,15 +3138,25 @@ module FuncDec = struct let (env2, closure_code) = restore_env env1 get_closure in - (* Destruct the argument *) - let (env3, destruct_args_code) = mk_pat env2 in + (* Add arguments to the environment *) + let env3 = + let rec go i env = function + | [] -> env + | a::as_ -> + let get env = G.i (LocalGet (nr Int32.(of_int i))) ^^ + (* TODO: Expose unboxed reference here *) + StackRep.adjust env SR.UnboxedReference SR.Vanilla + in + let env' = + E.add_local_deferred env a.it + { materialize = (fun env -> SR.Vanilla, get env) + ; materialize_vanilla = (fun env -> get env) + ; is_local = true + } in + go (i+1) env' as_ in + go 1 (* skip closure*) env2 args in closure_code ^^ - let get i = - G.i (LocalGet (nr Int32.(add 1l (of_int i)))) ^^ - (* TODO: Expose unboxed reference here *) - StackRep.adjust env SR.UnboxedReference SR.Vanilla in - destruct_args_code get ^^ mk_body env3 ^^ (* Collect garbage *) @@ -3158,16 +3192,16 @@ module FuncDec = struct ) (* Compile a closed function declaration (has no free variables) *) - let closed pre_env cc name mk_pat mk_body at = + let closed pre_env cc name args mk_body at = let (fi, fill) = E.reserve_fun pre_env name in ( SR.StaticFun fi, fun env -> 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 + let f = compile_local_function env cc restore_no_env args mk_body at in fill f ) (* Compile a closure declaration (has free variables) *) - let closure env cc name captured mk_pat mk_body at = + let closure env cc name captured args mk_body at = let is_local = cc.Value.sort <> Type.Sharable in let (set_clos, get_clos) = new_local env (name ^ "_clos") in @@ -3198,8 +3232,8 @@ module FuncDec = struct let f = if is_local - then compile_local_function env cc restore_env mk_pat mk_body at - else compile_message env cc restore_env mk_pat mk_body at in + then compile_local_function env cc restore_env args mk_body at + else compile_message env cc restore_env args mk_body at in let fi = E.add_fun env f name in @@ -3246,14 +3280,14 @@ module FuncDec = struct ClosureTable.remember_closure env ^^ G.i (Call (nr (Dfinity.func_bind_i env))) - let lit env how name cc captured mk_pat mk_body at = + let lit env how name cc captured args mk_body at = let is_local = cc.Value.sort <> Type.Sharable in if not is_local && E.mode env <> DfinityMode then SR.Unreachable, G.i Unreachable else (* TODO: Can we create a static function here? Do we ever have to? *) - closure env cc name captured mk_pat mk_body at + closure env cc name captured args mk_body at end (* FuncDec *) @@ -3909,11 +3943,10 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it - | FuncE (x, cc, typ_binds, p, _rt, e) -> - let captured = Freevars.captured p e in - let mk_pat env1 = compile_func_pat env1 cc p in + | FuncE (x, cc, typ_binds, args, _rt, e) -> + let captured = Freevars.captured exp in let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - FuncDec.lit env typ_binds x cc captured mk_pat mk_body exp.at + FuncDec.lit env typ_binds x cc captured args mk_body exp.at | ActorE (i, ds, fs, _) -> SR.UnboxedReference, let captured = Freevars.exp exp in @@ -4102,35 +4135,6 @@ and compile_n_ary_pat env how pat = 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. - If the function is unary, that’s great. - If the pattern is a tuple pattern, that is great as well. - But if not, we need to construct the tuple first. -*) -and compile_func_pat env cc pat = - let env1 = alloc_pat_local env pat in - let fill_code get = - G.with_region pat.at @@ - if cc.Value.n_args = 1 - then - (* Easy case: unary *) - get 0 ^^ orTrap (fill_pat env1 pat) - else - match pat.it with - (* Another easy case: Nothing to match *) - | WildP -> G.nop - (* The good case: We have a tuple pattern *) - | TupP ps -> - assert (List.length ps = cc.Value.n_args); - G.concat_mapi (fun i p -> get i ^^ orTrap (fill_pat env1 p)) ps - (* The general case: Construct the tuple, and apply the full pattern *) - | _ -> - Array.lit env (Lib.List.table cc.Value.n_args (fun i -> get i)) ^^ - orTrap (fill_pat env1 pat) in - (env1, fill_code) - and compile_dec pre_env how dec : E.t * G.t * (E.t -> G.t) = (fun (pre_env,alloc_code,mk_code) -> (pre_env, G.with_region dec.at alloc_code, fun env -> @@ -4184,11 +4188,10 @@ and compile_prog env (ds, e) = (env', code1 ^^ code2 ^^ StackRep.drop env' sr) and compile_static_exp env how exp = match exp.it with - | FuncE (name, cc, typ_binds, p, _rt, e) -> + | FuncE (name, cc, typ_binds, args, _rt, e) -> (* Get captured variables *) - let mk_pat env1 = compile_func_pat env1 cc p in let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - FuncDec.closed env cc name mk_pat mk_body exp.at + FuncDec.closed env cc name args mk_body exp.at | _ -> assert false and compile_prelude env = diff --git a/src/construct.ml b/src/construct.ml index ccaf69a51ec..500a4f724f4 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -33,6 +33,13 @@ let id_of_exp x = | VarE x -> x | _ -> failwith "Impossible: id_of_exp" +let arg_of_exp x = + match x.it with + | VarE i -> { i with note = x.note.note_typ } + | _ -> failwith "Impossible: arg_of_exp" + +let exp_of_arg a = idE {a with note = () } a.note + (* Fresh id generation *) let id_stamp = ref 0 @@ -99,18 +106,24 @@ let dec_eff dec = match dec.it with | TypD _ -> T.Triv | LetD (_,e) | VarD (_,e) -> eff e +let is_useful_dec dec = match dec.it with + | LetD ({it = WildP;_}, {it = TupE [];_}) -> false + | LetD ({it = TupP [];_}, {it = TupE [];_}) -> false + | _ -> true + let blockE decs exp = - match decs with + let decs' = List.filter is_useful_dec decs in + match decs' with | [] -> exp | _ -> - let es = List.map dec_eff decs in - let typ = typ exp in - let e = List.fold_left max_eff (eff exp) es in - { it = BlockE (decs, exp); - at = no_region; - note = {S.note_typ = typ; - S.note_eff = e } - } + let es = List.map dec_eff decs' in + let typ = typ exp in + let e = List.fold_left max_eff (eff exp) es in + { it = BlockE (decs', exp); + at = no_region; + note = {S.note_typ = typ; + S.note_eff = e } + } let textE s = { it = LitE (S.TextLit s); @@ -282,18 +295,27 @@ let ignoreE exp = (* Mono-morphic function expression *) let funcE name t x exp = - let retty = match t with - | T.Func(_, _, _, _, ts2) -> T.seq ts2 + let arg_tys, retty = match t with + | T.Func(_, _, _, ts1, ts2) -> ts1, T.seq ts2 | _ -> assert false in let cc = Value.call_conv_of_typ t in + let args, exp' = + if cc.Value.n_args = 1; + then + [ arg_of_exp x ], exp + else + let vs = List.map fresh_var arg_tys in + List.map arg_of_exp vs, + blockE [letD x (tupE vs)] exp + in ({it = FuncE ( name, cc, [], - varP x, + args, (* TODO: Assert invariant: retty has no free (unbound) DeBruijn indices -- Claudio *) retty, - exp + exp' ); at = no_region; note = { S.note_eff = T.Triv; S.note_typ = t } @@ -304,11 +326,12 @@ let nary_funcE name t xs exp = | T.Func(_, _, _, _, ts2) -> T.seq ts2 | _ -> assert false in let cc = Value.call_conv_of_typ t in + assert (cc.Value.n_args = List.length xs); ({it = FuncE ( name, cc, [], - seqP (List.map varP xs), + List.map arg_of_exp xs, retty, exp ); diff --git a/src/construct.mli b/src/construct.mli index 24bf5e7178b..ea5bf6b5832 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -1,4 +1,4 @@ -open Ir +open Ir open Type (* A miscellany of helpers to construct typed terms from typed terms *) @@ -27,7 +27,9 @@ val fresh_id : unit -> id val fresh_var : typ -> var val idE : id -> typ -> exp -val id_of_exp : exp -> id +val id_of_exp : var -> id +val arg_of_exp : var -> arg +val exp_of_arg : arg -> var (* Patterns *) diff --git a/src/desugar.ml b/src/desugar.ml index 7b3eb00c68a..b3161cf514b 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -56,7 +56,8 @@ and exp' at note = function | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) | S.FuncE (name, s, tbs, p, ty, e) -> let cc = Value.call_conv_of_typ note.S.note_typ in - I.FuncE (name, cc, typ_binds tbs, param p, ty.note, exp e) + let args, wrap = to_args cc p in + I.FuncE (name, cc, typ_binds tbs, args, ty.note, wrap (exp e)) | 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.note) inst in @@ -156,12 +157,6 @@ and decs ds = extra_typDs ds @ List.map dec ds and dec d = { (phrase' dec' d) with note = () } -and param p = - pat (match p.it, p.note with - | S.ParP p1, _ -> p1 - | S.TupP [p1], Type.Tup [n] -> { p with it = p1.it; note = n } - | _ -> p) - and dec' at n d = match d with | S.ExpD e -> (expD (exp e)).it | S.LetD (p, e) -> @@ -195,8 +190,9 @@ and dec' at n d = match d with | _ -> assert false in let varPat = {it = I.VarP id'; at = at; note = fun_typ } in + let args, wrap = to_args cc p in let fn = { - it = I.FuncE (id.it, cc, typ_binds tbs, param p, obj_typ, + it = I.FuncE (id.it, cc, typ_binds tbs, args, obj_typ, wrap { it = obj at s (Some self_id) es obj_typ; at = at; note = { S.note_typ = obj_typ; S.note_eff = T.Triv } }); @@ -226,6 +222,62 @@ and pat' = function | S.AnnotP (p, _) | S.ParP p -> pat' p.it +and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) = + match p.it with + | S.VarP i -> + { i with note = p.note }, + (fun e -> e) + | S.WildP -> + let v = fresh_var p.note in + arg_of_exp v, + (fun e -> e) + | _ -> + let v = fresh_var p.note in + arg_of_exp v, + (fun e -> blockE [letP (pat p) v] e) + + +and to_args cc p0 : (Ir.arg list * (Ir.exp -> Ir.exp)) = + let p = match p0.it, p0.note with + | S.ParP p1, _ -> p1 + | S.TupP [p1], Type.Tup [n] -> { p0 with it = p1.it; note = n } + | _ -> p0 in + + let n = cc.Value.n_args in + let tys = if n = 1 then [p.note] else T.as_seq p.note in + + let args, wrap = + match n, p.it with + | _, S.WildP -> + let vs = List.map fresh_var tys in + List.map arg_of_exp vs, + (fun e -> e) + | 1, _ -> + let a, wrap = to_arg p in + [a], wrap + | 0, S.TupP [] -> + [] , (fun e -> e) + | _, S.TupP ps -> + assert (List.length ps = n); + List.fold_right (fun p (args, wrap) -> + let (a, wrap1) = to_arg p in + (a::args, fun e -> wrap1 (wrap e)) + ) ps ([], (fun e -> e)) + | _, _ -> + let vs = List.map fresh_var tys in + List.map arg_of_exp vs, + (fun e -> blockE [letP (pat p) (tupE vs)] e) + in + + let wrap_under_async e = + if cc.Value.sort = T.Sharable && cc.Value.control = T.Promises + then match e.it with + | Ir.AsyncE e' -> { e with it = Ir.AsyncE (wrap e') } + | _ -> assert false + else wrap e in + + args, wrap_under_async + and prog (p : Syntax.prog) : Ir.prog = begin match p.it with | [] -> ([], tupE []) diff --git a/src/freevars.ml b/src/freevars.ml index e70a34f4c58..cb50db88142 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -86,7 +86,7 @@ let rec exp e : f = match e.it with | OptE e -> exp e | DeclareE (i, t, e) -> exp e // i.it | DefineE (i, m, e) -> id i ++ exp e - | FuncE (x, cc, tp, p, t, e) -> under_lambda (exp e /// pat p) + | FuncE (x, cc, tp, as_, t, e) -> under_lambda (exp e /// args as_) | ActorE (i, ds, fs, _) -> close (decs ds +++ fields fs) // i.it | NewObjE (_, fs, _) -> fields fs @@ -94,6 +94,10 @@ and fields fs = unions (fun f -> id f.it.var) fs and exps es : f = unions exp es +and arg a : fd = (M.empty, S.singleton a.it) + +and args as_ : fd = union_binders arg as_ + and pat p : fd = match p.it with | WildP -> (M.empty, S.empty) | VarP i -> (M.empty, S.singleton i.it) @@ -116,7 +120,7 @@ and dec d = match d.it with | TypD c -> (M.empty, S.empty) (* The variables captured by a function. May include the function itself! *) -and captured p e = - List.map fst (M.bindings (exp e /// pat p)) +and captured e = + List.map fst (M.bindings (exp e)) and decs ps : fd = union_binders dec ps diff --git a/src/interpret_ir.ml b/src/interpret_ir.ml index 65863d12a6e..1c9a2a5a42a 100644 --- a/src/interpret_ir.ml +++ b/src/interpret_ir.ml @@ -393,9 +393,9 @@ and interpret_exp_mut env exp (k : V.value V.cont) = define_id env id v'; k V.unit ) - | FuncE (x, cc, _typbinds, pat, _typ, exp) -> - let f = interpret_func env x pat - (fun env' -> interpret_exp env' exp) in + | FuncE (x, cc, _typbinds, args, _typ, e) -> + let f = interpret_func env exp.at x args + (fun env' -> interpret_exp env' e) in let v = V.Func (cc, f) in let v = match cc.Value.sort with @@ -440,6 +440,21 @@ and interpret_cases env cases at v (k : V.value V.cont) = | Some ve -> interpret_exp (adjoin_vals env ve) exp k | None -> interpret_cases env cases' at v k +(* Argument lists *) + +and match_arg a v : val_env = V.Env.singleton a.it (Lib.Promise.make_fulfilled v) + +and match_args at args v : val_env = + match args with + | [a] -> match_arg a v + | _ -> + match V.as_tup v with + | vs when List.length vs = List.length args -> + List.fold_left V.Env.adjoin V.Env.empty (List.map2 match_arg args vs) + | _ -> + trap at "argument value %s does not match parameter list" + (V.string_of_val v) + (* Patterns *) @@ -503,10 +518,13 @@ and match_lit lit v : bool = | PreLit _, _ -> assert false | _ -> false +and match_id id v : val_env = + V.Env.singleton id.it (Lib.Promise.make_fulfilled v) + and match_pat pat v : val_env option = match pat.it with | WildP -> Some V.Env.empty - | VarP id -> Some (V.Env.singleton id.it (Lib.Promise.make_fulfilled v)) + | VarP id -> Some (match_id id v) | LitP lit -> if match_lit lit v then Some V.Env.empty @@ -576,26 +594,22 @@ and interpret_decs env decs (k : unit V.cont) = | [] -> k () | d::ds -> interpret_dec env d (fun () -> interpret_decs env ds k) -and interpret_func env x pat f v (k : V.value V.cont) = +and interpret_func env at x args f v (k : V.value V.cont) = if !Flags.trace then trace "%s%s" x (string_of_arg v); - match match_pat pat v with - | None -> - trap pat.at "argument value %s does not match parameter list" - (V.string_of_val v) - | Some ve -> - incr trace_depth; - let k' = fun v' -> - if !Flags.trace then trace "<= %s" (V.string_of_val v'); - decr trace_depth; - k v' - in - let env' = - { vals = V.Env.adjoin env.vals ve; - labs = V.Env.empty; - rets = Some k'; - async = false - } - in f env' k' + let ve = match_args at args v in + incr trace_depth; + let k' = fun v' -> + if !Flags.trace then trace "<= %s" (V.string_of_val v'); + decr trace_depth; + k v' + in + let env' = + { vals = V.Env.adjoin env.vals ve; + labs = V.Env.empty; + rets = Some k'; + async = false + } + in f env' k' (* Programs *) diff --git a/src/ir.ml b/src/ir.ml index a23bfb909ca..77898b52260 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -23,6 +23,9 @@ and pat' = | OptP of pat (* option *) | AltP of pat * pat (* disjunctive *) +(* Like id, but with a type attached *) +type arg = (string, Type.typ) Source.annotated_phrase + (* Expressions *) type exp = exp' phrase @@ -56,7 +59,7 @@ and exp' = | DeclareE of id * Type.typ * exp (* local promise *) | DefineE of id * mut * exp (* promise fulfillment *) | FuncE of (* function *) - string * Value.call_conv * typ_bind list * pat * Type.typ * exp + string * Value.call_conv * typ_bind list * arg list * Type.typ * exp | ActorE of id * dec list * field list * Type.typ (* actor *) | NewObjE of Type.obj_sort * field list * Type.typ (* make an object *) diff --git a/src/rename.ml b/src/rename.ml index a36275d3f2f..cbc1f6437e6 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -21,6 +21,10 @@ let id_bind rho i = let i' = fresh_id i in ({i with it = i'}, Renaming.add i.it i' rho) +let arg_bind rho i = + let i' = fresh_id i in + ({i with it = i'}, Renaming.add i.it i' rho) + let rec exp rho e = {e with it = exp' rho e.it} @@ -60,7 +64,7 @@ and exp' rho e = match e with DeclareE (i', t, exp rho' e) | DefineE (i, m, e) -> DefineE (id rho i, m, exp rho e) | FuncE (x, s, tp, p, t, e) -> - let p', rho' = pat rho p in + let p', rho' = args rho p in let e' = exp rho' e in FuncE (x, s, tp, p', t, e') | NewObjE (s, fs, t) -> NewObjE (s, fields rho fs, t) @@ -70,6 +74,14 @@ and exps rho es = List.map (exp rho) es and fields rho fs = List.map (fun f -> { f with it = { f.it with var = id rho f.it.var } }) fs +and args rho as_ = + match as_ with + | [] -> ([],rho) + | a::as_ -> + let (a', rho') = arg_bind rho a in + let (as_', rho'') = args rho' as_ in + (a'::as_', rho'') + and pat rho p = let p',rho = pat' rho p.it in {p with it = p'}, rho diff --git a/src/serialization.ml b/src/serialization.ml index 32403bfc3d4..bd47b714f80 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -121,32 +121,22 @@ module Transform() = struct let exp2' = map_tuple cc.Value.n_args serialize (t_exp exp2) in CallE (cc, t_exp exp1, [], exp2') end - | FuncE (x, cc, typbinds, pat, typT, exp) -> + | FuncE (x, cc, typbinds, args, typT, exp) -> begin match cc.Value.sort with | T.Local -> - FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Sharable -> assert (typbinds = []); assert (T.is_unit typT); - match cc.Value.n_args with - | 0 -> FuncE (x, cc, [], t_pat pat, T.unit, t_exp exp) - | 1 -> - let arg_ty = t_typ pat.note in - let arg_v = fresh_var arg_t in - let pat' = varP arg_v in - let body' = - blockE [letP (t_pat pat) (deserialize arg_v arg_ty) ] - (t_exp exp) in - FuncE (x, cc, [], pat', T.unit, body') - | _ -> - let arg_tys = List.map t_typ (T.as_tup pat.note) in - let arg_vs = Lib.List.table cc.Value.n_args (fun _ -> fresh_var arg_t) in - let pat' = seqP (List.map varP arg_vs) in - let body' = - (* TODO: Optimize if pat is a manifest tuple pattern *) - blockE [letP (t_pat pat) (tupE (List.map2 deserialize arg_vs arg_tys)) ] - (t_exp exp) in - FuncE (x, cc, [], pat', T.unit, body') + let args' = t_args args in + let arg_tys = List.map (fun a -> a.note) args' in + let raw_arg_vs = List.map (fun _ -> fresh_var arg_t) args' in + let body' = + blockE [letP (tupP (List.map varP (List.map exp_of_arg args'))) + (tupE (List.map2 deserialize raw_arg_vs arg_tys)) ] + (t_exp exp) in + let args' = List.map arg_of_exp raw_arg_vs in + FuncE (x, cc, [], args', T.unit, body') end | PrimE _ | LitE _ -> exp' @@ -220,6 +210,9 @@ module Transform() = struct and t_fields fs = List.map (fun f -> { f with note = t_typ f.note }) fs + and t_args as_ = + List.map (fun a -> { a with note = t_typ a.note }) as_ + and t_pat pat = { pat with it = t_pat' pat.it; diff --git a/src/tailcall.ml b/src/tailcall.ml index 57bf761897a..65732af9260 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -43,7 +43,7 @@ TODO: optimize for multiple arguments using multiple temps (not a tuple). type func_info = { func: S.id; typ_binds: typ_bind list; - temp: var; + temps: var list; label: S.id; tail_called: bool ref; } @@ -77,6 +77,16 @@ let rec tailexp env e = and exp env e : exp = {e with it = exp' {env with tail_pos = false} e} +and assignEs vars exp : dec list = + match vars, exp.it with + | [v], _ -> [ expD (assignE v exp) ] + | _, TupE es when List.length es = List.length vars -> + List.map expD (List.map2 assignE vars es) + | _, _ -> + let tup = fresh_var (typ exp) in + letD tup exp :: + List.mapi (fun i v -> expD (assignE v (projE v i))) vars + and exp' env e : exp' = match e.it with | VarE _ | LitE _ @@ -95,10 +105,10 @@ and exp' env e : exp' = match e.it with begin match e1.it, env with | VarE f1, { tail_pos = true; - info = Some { func; typ_binds; temp; label; tail_called } } + info = Some { func; typ_binds; temps; label; tail_called } } when f1.it = func.it && are_generic_insts typ_binds insts -> tail_called := true; - (blockE [expD (assignE temp (exp env e2))] + (blockE (assignEs temps (exp env e2)) (breakE label (tupE []))).it | _,_-> CallE(cc, exp env e1, insts, exp env e2) end @@ -118,15 +128,19 @@ and exp' env e : exp' = match e.it with | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) | DefineE (i, m, e) -> DefineE (i, m, exp env e) - | FuncE (x, cc, tbs, p, typT, exp0) -> - let env1 = pat {tail_pos = true; info = None} p in - let exp0' = tailexp env1 exp0 in - FuncE (x, cc, tbs, p, typT, exp0') - | ActorE (i, ds, fs, t) -> ActorE (i, ds, fs, t) (* TODO: decent into ds *) + | FuncE (x, cc, tbs, as_, typT, exp0) -> + let env1 = { tail_pos = true; info = None} in + let env2 = args env1 as_ in + let exp0' = tailexp env2 exp0 in + FuncE (x, cc, tbs, as_, typT, exp0') + | ActorE (i, ds, fs, t) -> ActorE (i, ds, fs, t) (* TODO: descent into ds *) | NewObjE (s,is,t) -> NewObjE (s, is, t) and exps env es = List.map (exp env) es +and args env as_ = + List.fold_left (fun env a -> bind env a None) env as_ + and pat env p = let env = pat' env p.it in env @@ -167,21 +181,22 @@ and dec env d = and dec' env d = match d.it with (* A local let bound function, this is what we are looking for *) + (* TODO: Do we need to detect more? A tuple of functions? *) | LetD (({it = VarP id;_} as id_pat), - ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, p, typT, exp0);_} as funexp)) -> + ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, as_, typT, exp0);_} as funexp)) -> let env = bind env id None in begin fun env1 -> - let temp = fresh_var (Mut p.note) in - let l = fresh_id () in + let temps = List.map (fun a -> fresh_var (Mut a.note)) as_ in + let label = fresh_id () in let tail_called = ref false in let env2 = { tail_pos = true; info = Some { func = id; typ_binds = tbs; - temp = temp; - label = l; - tail_called = tail_called } } + temps; + label; + tail_called } } in - let env3 = pat env2 p in (* shadow id if necessary *) + let env3 = args env2 as_ in (* shadow id if necessary *) let exp0' = tailexp env3 exp0 in let cs = List.map (fun (tb : typ_bind) -> Con (tb.it.con, [])) tbs in if !tail_called then @@ -189,18 +204,19 @@ and dec' env d = | Func( _, _, _, dom, _) -> List.map (fun t -> fresh_var (open_ cs t)) dom | _ -> assert false in - let args = seqP (List.map varP ids) in let l_typ = Type.unit in let body = - blockE [varD (id_of_exp temp) (seqE ids)] ( + blockE (List.map2 (fun t i -> varD (id_of_exp t) i) temps ids) ( loopE ( - labelE l l_typ (blockE [letP p (immuteE temp)] (retE exp0')) + labelE label l_typ (blockE + (List.map2 (fun a t -> letD (exp_of_arg a) (immuteE t)) as_ temps) + (retE exp0')) ) ) in - LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, args, typT, body)}) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, List.map arg_of_exp ids, typT, body)}) else - LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, p, typT, exp0')}) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, as_, typT, exp0')}) end, env | LetD (p, e) -> diff --git a/test/fail/ok/use-before-define5.wasm.stderr.ok b/test/fail/ok/use-before-define5.wasm.stderr.ok index 52137859dfb..3bdcd030757 100644 --- a/test/fail/ok/use-before-define5.wasm.stderr.ok +++ b/test/fail/ok/use-before-define5.wasm.stderr.ok @@ -5,7 +5,6 @@ non-closed actor: (ActorE (FuncE foo (shared 0 -> 0) - (TupP) () (AssertE (RelE Nat (VarE x) EqOp (LitE (NatLit 1)))) ) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 57deb5948b5..48ac936e377 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -6,7 +6,6 @@ non-closed actor: (ActorE (FuncE dec (shared 0 -> 0) - (TupP) () (BlockE (LetD WildP (CallE ( 1 -> 0) (VarE show) (VarE c))) @@ -19,31 +18,31 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (VarP $4) + (params $60) () (BlockE - (LetD (VarP $2) (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $4))) - (BlockE - (LetD (TupP) (TupE)) - (CallE + (LetD + (TupP (VarP $58)) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $60))) + ) + (CallE + ( 1 -> 0) + (FuncE + $lambda ( 1 -> 0) - (FuncE - $lambda - ( 1 -> 0) - (VarP $1) - () - (CallE ( 1 -> 0) (VarE $1) (VarE c)) - ) - (FuncE - $lambda - ( 1 -> 0) - (VarP $3) - () - (CallE - (shared 1 -> 0) - (VarE $2) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $3)) - ) + (params $57) + () + (CallE ( 1 -> 0) (VarE $57) (VarE c)) + ) + (FuncE + $lambda + ( 1 -> 0) + (params $59) + () + (CallE + (shared 1 -> 0) + (VarE $58) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $59)) ) ) ) From 20c6f125ebc0f4e52902ce07176d0ad844a61e0a Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 23:25:16 +0100 Subject: [PATCH 32/76] Backend: Avoid boxing and re-boxing of elembufs between the function definition and the actual deserialization, resp. the serialization and the actual function call. --- src/compile.ml | 90 +++++++++++++------ test/run-dfinity/no-boxed-references.as | 13 +++ .../ok/no-boxed-references.dvm-run.ok | 1 + 3 files changed, 79 insertions(+), 25 deletions(-) create mode 100644 test/run-dfinity/no-boxed-references.as create mode 100644 test/run-dfinity/ok/no-boxed-references.dvm-run.ok diff --git a/src/compile.ml b/src/compile.ml index 9e13d9f6474..ec0566a6ba5 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -57,6 +57,7 @@ module SR = struct type t = | Vanilla | UnboxedTuple of int + | UnboxedRefTuple of int | UnboxedInt64 | UnboxedWord32 | UnboxedReference @@ -2942,6 +2943,9 @@ module StackRep = struct let of_arity n = if n = 1 then Vanilla else UnboxedTuple n + let refs_of_arity n = + if n = 1 then UnboxedReference else UnboxedRefTuple n + (* The stack rel of a primitive type, i.e. what the binary operators expect *) let of_type : Type.typ -> t = function | Type.Prim Type.Bool -> bool @@ -2961,6 +2965,9 @@ module StackRep = struct | UnboxedTuple 0 -> ValBlockType None | UnboxedTuple 1 -> ValBlockType (Some I32Type) | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) + | UnboxedRefTuple 0 -> ValBlockType None + | UnboxedRefTuple 1 -> ValBlockType (Some I32Type) + | UnboxedRefTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) | StaticThing _ -> ValBlockType None | Unreachable -> ValBlockType None @@ -2970,6 +2977,7 @@ module StackRep = struct | UnboxedWord32 -> "UnboxedWord32" | UnboxedReference -> "UnboxedReference" | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n + | UnboxedRefTuple n -> Printf.sprintf "UnboxedRefTuple %d" n | Unreachable -> "Unreachable" | StaticThing _ -> "StaticThing" @@ -2992,6 +3000,7 @@ module StackRep = struct | UnboxedWord32 -> G.i Drop | UnboxedReference -> G.i Drop | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) + | UnboxedRefTuple n -> G.table n (fun _ -> G.i Drop) | StaticThing _ -> G.nop | Unreachable -> G.nop @@ -3004,7 +3013,33 @@ module StackRep = struct ; is_local = false } - let adjust env (sr_in : t) sr_out = + let unbox_reference_n env n = match n with + | 0 -> G.nop + | 1 -> Dfinity.unbox_reference env + | _ -> + let name = Printf.sprintf "unbox_reference_n %i" n 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 -> + G.i (LocalGet (nr (Int32.of_int i))) ^^ Dfinity.unbox_reference env + ) + ) + + let box_reference_n env n = match n with + | 0 -> G.nop + | 1 -> Dfinity.box_reference env + | _ -> + let name = Printf.sprintf "box_reference_n %i" n 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 -> + G.i (LocalGet (nr (Int32.of_int i))) ^^ Dfinity.box_reference env + ) + ) + + let rec adjust env (sr_in : t) sr_out = if sr_in = sr_out then G.nop else match sr_in, sr_out with @@ -3014,6 +3049,15 @@ module StackRep = struct | UnboxedTuple n, Vanilla -> Tuple.from_stack env n | Vanilla, UnboxedTuple n -> Tuple.to_stack env n + | UnboxedRefTuple n, UnboxedTuple m when n = m -> box_reference_n env n + | UnboxedTuple n, UnboxedRefTuple m when n = m -> unbox_reference_n env n + + | UnboxedRefTuple n, sr -> + box_reference_n env n ^^ adjust env (UnboxedTuple n) sr + | sr, UnboxedRefTuple n -> + adjust env sr (UnboxedTuple n) ^^ unbox_reference_n env n + + | UnboxedInt64, Vanilla -> BoxedInt.box env | Vanilla, UnboxedInt64 -> BoxedInt.unbox env @@ -3031,19 +3075,6 @@ module StackRep = struct (to_string sr_in) (to_string sr_out); G.nop - (* TODO: Replace this hack with nested stackreps *) - let unbox_reference_n env n = match n with - | 0 -> G.nop - | 1 -> adjust env SR.Vanilla SR.UnboxedReference - | _ -> - let name = Printf.sprintf "unbox_reference_n %i" n 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 -> - G.i (LocalGet (nr (Int32.of_int i))) ^^ adjust env SR.Vanilla SR.UnboxedReference - ) - ) end (* StackRep *) @@ -3138,19 +3169,17 @@ module FuncDec = struct let (env2, closure_code) = restore_env env1 get_closure in - (* Add arguments to the environment *) + (* Add arguments to the environment, as unboxed references *) let env3 = let rec go i env = function | [] -> env | a::as_ -> - let get env = G.i (LocalGet (nr Int32.(of_int i))) ^^ - (* TODO: Expose unboxed reference here *) - StackRep.adjust env SR.UnboxedReference SR.Vanilla - in + let get env = G.i (LocalGet (nr Int32.(of_int i))) in let env' = E.add_local_deferred env a.it - { materialize = (fun env -> SR.Vanilla, get env) - ; materialize_vanilla = (fun env -> get env) + { materialize = (fun env -> SR.UnboxedReference, get env) + ; materialize_vanilla = (fun env -> + get env ^^ StackRep.adjust env SR.UnboxedReference SR.Vanilla) ; is_local = true } in go (i+1) env' as_ in @@ -3909,8 +3938,7 @@ and compile_exp (env : E.t) exp = let (set_funcref, get_funcref) = new_local env "funcref" in code1 ^^ StackRep.adjust env fun_sr SR.UnboxedReference ^^ set_funcref ^^ - compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ - StackRep.unbox_reference_n env cc.Value.n_args ^^ + compile_exp_as env (StackRep.refs_of_arity cc.Value.n_args) e2 ^^ FuncDec.call_funcref env cc get_funcref end | SwitchE (e, cs) -> @@ -3966,8 +3994,20 @@ and compile_exp (env : E.t) exp = and compile_exp_as env sr_out e = G.with_region e.at ( - let sr_in, code = compile_exp env e in - code ^^ StackRep.adjust env sr_in sr_out + match sr_out, e.it with + (* Some optimizations for certain sr_out and expressions *) + | SR.UnboxedRefTuple n, TupE es when n = List.length es -> + G.concat_map (fun e -> + compile_exp_as env SR.UnboxedReference e + ) es + | _ , BlockE (decs, exp) -> + let (env', code1) = compile_decs env decs in + let code2 = compile_exp_as env' sr_out exp in + code1 ^^ code2 + (* Fallback to whatever stackrep compile_exp chooses *) + | _ -> + 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 = diff --git a/test/run-dfinity/no-boxed-references.as b/test/run-dfinity/no-boxed-references.as new file mode 100644 index 00000000000..26ccc6451f9 --- /dev/null +++ b/test/run-dfinity/no-boxed-references.as @@ -0,0 +1,13 @@ +// No unboxing between the start of foo and the call to serialize +// CHECK: (func $foo +// CHECK-NOT: box_reference +// CHECK: call $deserialize +shared func foo(a : Text, b: Int) {}; + +// No boxing between the call to serialize and the indirect call +// CHECK: (func $start +// CHECK: call $serialize +// CHECK-NOT: box_reference +// CHECK: call_indirect +foo("a", 42); + diff --git a/test/run-dfinity/ok/no-boxed-references.dvm-run.ok b/test/run-dfinity/ok/no-boxed-references.dvm-run.ok new file mode 100644 index 00000000000..3b7e66c4381 --- /dev/null +++ b/test/run-dfinity/ok/no-boxed-references.dvm-run.ok @@ -0,0 +1 @@ +Top-level code done. From 81795a1192b94c35065baa819ca841b42cc2bd66 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 13 Mar 2019 23:27:12 +0100 Subject: [PATCH 33/76] debug names: Use function parameter names this would make nicer `.wat` output, but it seems some earlier pass is not careful with these names. --- src/compile.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index ec0566a6ba5..60299417d3c 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3120,7 +3120,7 @@ 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 args mk_body at = - let arg_names = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let arg_names = List.map (fun a -> a.it, I32Type) args in let retty = Lib.List.make cc.Value.n_res I32Type in Func.of_body env (["clos", I32Type] @ arg_names) retty (fun env1 -> G.with_region at ( let get_closure = G.i (LocalGet (nr 0l)) in @@ -3155,7 +3155,7 @@ module FuncDec = struct - Fake orthogonal persistence *) let compile_message env cc restore_env args mk_body at = - let arg_names = Lib.List.table cc.Value.n_args (fun i -> Printf.sprintf "arg%i" i, I32Type) in + let arg_names = List.map (fun a -> a.it, I32Type) args in assert (cc.Value.n_res = 0); Func.of_body env (["clos", I32Type] @ arg_names) [] (fun env1 -> G.with_region at ( (* Restore memory *) From caceb0496cbbedc45327cab66ac32f9c1b88b3c8 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 09:05:22 +0100 Subject: [PATCH 34/76] Replace ElemBuf prim with a Serialized t type constructor so that we can use its (phantom?) type parameter to still do rigorous type checking. Also introduces a `serialized` flavor: Without that flavor, message arguments need to be subtypes of `Sharable`, afterwards they need to be `Serialized` values. Along the way I changed `Check_ir.check` to take format strings. --- src/arrange_type.ml | 2 +- src/async.ml | 1 + src/check_ir.ml | 56 +++++++++++-------- src/desugar.ml | 1 + src/ir.ml | 1 + src/serialization.ml | 22 ++++---- src/type.ml | 15 ++++- src/type.mli | 4 +- .../ok/counter-class.wasm.stderr.ok | 2 +- 9 files changed, 64 insertions(+), 40 deletions(-) diff --git a/src/arrange_type.ml b/src/arrange_type.ml index e6e0d54749e..c3ce43c35a0 100644 --- a/src/arrange_type.ml +++ b/src/arrange_type.ml @@ -30,7 +30,6 @@ let prim p = match p with | Float -> Atom "Float" | Char -> Atom "Char" | Text -> Atom "Text" - | ElemBuf -> Atom "ElemBuf" let con c = Atom (Con.to_string c) @@ -45,6 +44,7 @@ let rec typ (t:Type.typ) = match t with | Func (s, c, tbs, at, rt) -> "Func" $$ [Atom (sharing s); Atom (control c)] @ List.map typ_bind tbs @ [ "" $$ (List.map typ at); "" $$ (List.map typ rt)] | Async t -> "Async" $$ [typ t] | Mut t -> "Mut" $$ [typ t] + | Serialized t -> "Serialized" $$ [typ t] | Shared -> Atom "Shared" | Any -> Atom "Any" | Non -> Atom "Non" diff --git a/src/async.ml b/src/async.ml index 9d8f505c68d..a5ee644e791 100644 --- a/src/async.ml +++ b/src/async.ml @@ -166,6 +166,7 @@ module Transform() = struct | Obj (s, fs) -> Obj (s, List.map t_field fs) | Mut t -> Mut (t_typ t) | Shared -> Shared + | Serialized t -> Serialized (t_typ t) | Any -> Any | Non -> Non | Pre -> Pre diff --git a/src/check_ir.ml b/src/check_ir.ml index 266b7e51776..331651ed0a6 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -70,6 +70,12 @@ let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "IR t let error env at fmt = Printf.ksprintf (fun s -> raise (CheckFailed (Diag.string_of_message (type_error at s)))) fmt +let check env at p fmt = + if p + then Printf.ikfprintf (fun () -> ()) () fmt + else error env at fmt + + let add_lab c x t = {c with labs = T.Env.add x t c.labs} @@ -98,25 +104,25 @@ let disjoint_union env at fmt env1 env2 = (* Types *) -let check_ids env ids = ignore - (List.fold_left - (fun dom id -> - if List.mem id dom - then error env no_region "duplicate field name %s in object type" id - else id::dom +let check_ids env ids = ignore ( + List.fold_left (fun dom id -> + check env no_region (not (List.mem id dom)) + "duplicate field name %s in object type" id; + id::dom ) [] ids ) -let check env at p = - if p then ignore - else error env at - let check_sub env at t1 t2 = - if T.sub t1 t2 - then () - else error env at "subtype violation:\n %s\n %s\n" + check env at (T.sub t1 t2) "subtype violation:\n %s\n %s\n" (T.string_of_typ_expand t1) (T.string_of_typ_expand t2) +let check_shared env at t = + if env.flavor.Ir.serialized + then check env at (T.is_serialized t) + "message argument is not serialized:\n %s" (T.string_of_typ_expand t) + else check env at (T.sub t T.Shared) + "message argument is not sharable:\n %s" (T.string_of_typ_expand t) + let rec check_typ env typ : unit = match typ with | T.Pre -> @@ -124,8 +130,7 @@ let rec check_typ env typ : unit = | T.Var (s, i) -> error env no_region "free type variable %s, index %i" s i | T.Con (c, typs) -> - if not (T.ConSet.mem c env.cons) then - error env no_region "free type constructor %s" (Con.name c); + check env no_region (T.ConSet.mem c env.cons) "free type constructor %s" (Con.name c); (match Con.kind c with | T.Def (tbs, t) | T.Abs (tbs, t) -> check_typ_bounds env tbs typs no_region ) @@ -154,8 +159,7 @@ let rec check_typ env typ : unit = (T.string_of_typ_expand t2) end; if sort = T.Sharable then begin - let t1 = T.seq ts1 in - check_sub env' no_region t1 T.Shared; + List.iter (fun t -> check_shared env no_region t) ts1; match ts2 with | [] -> () | [T.Async t2] -> @@ -168,7 +172,7 @@ let rec check_typ env typ : unit = | T.Async typ -> check env no_region env.flavor.Ir.has_async_typ "async in non-async flavor"; let t' = T.promote typ in - check_sub env no_region t' T.Shared + check_shared env no_region t' | T.Obj (sort, fields) -> let rec sorted fields = match fields with @@ -182,6 +186,11 @@ let rec check_typ env typ : unit = check env no_region (sorted fields) "object type's fields are not sorted" | T.Mut typ -> check_typ env typ + | T.Serialized typ -> + check env no_region env.flavor.Ir.serialized + "Serialized in non-serialized flavor"; + check_typ env typ; + check_sub env no_region typ T.Shared and check_typ_field env s typ_field : unit = let T.{lab; typ} = typ_field in @@ -517,8 +526,7 @@ and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env pat in check_sub env pat.at pat.note t_pat; check_exp (adjoin_vals env ve) exp; - if not (T.sub (typ exp) t) then - error env exp.at "bad case" + check env pat.at (T.sub (typ exp) t) "bad case" (* Arguments *) @@ -526,8 +534,8 @@ and check_args env args = let rec go ve = function | [] -> ve | a::as_ -> - if T.Env.mem a.it ve - then error env a.at "duplicate binding for %s in argument list" a.it; + check env a.at (not (T.Env.mem a.it ve)) + "duplicate binding for %s in argument list" a.it; check_typ env a.note; go (T.Env.add a.it a.note ve) as_ in go T.Env.empty args @@ -541,8 +549,8 @@ and gather_pat env ve0 pat : val_env = | LitP _ -> ve | VarP id -> - if T.Env.mem id.it ve0 then - error env pat.at "duplicate binding for %s in block" id.it; + check env id.at (not (T.Env.mem id.it ve0)) + "duplicate binding for %s in block" id.it; T.Env.add id.it pat.note ve (*TBR*) | TupP pats -> List.fold_left go ve pats diff --git a/src/desugar.ml b/src/desugar.ml index b3161cf514b..075d0925ea7 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -285,6 +285,7 @@ and prog (p : Syntax.prog) : Ir.prog = end , { I.has_await = true ; I.has_async_typ = true + ; I.serialized = false } (* validation *) diff --git a/src/ir.ml b/src/ir.ml index 77898b52260..8d06eca98fa 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -95,6 +95,7 @@ should hold. type flavor = { has_async_typ : bool; (* AsyncT *) has_await : bool; (* AwaitE and AsyncE *) + serialized : bool; (* Shared function arguments are serialized *) } diff --git a/src/serialization.ml b/src/serialization.ml index bd47b714f80..ea93aa993da 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -28,13 +28,15 @@ module Transform() = struct let con_renaming = ref ConRenaming.empty (* The type of a serialized argument *) - let arg_t = T.Prim T.ElemBuf - - let deserialize e t = - primE "@deserialize" (T.Func (T.Local, T.Returns, [], [arg_t], [t])) + let deserialize e = + let t = T.as_serialized e.note.note_typ in + primE "@deserialize" (T.Func (T.Local, T.Returns, [], [T.Serialized t], [t])) -*- e + + let serialize e = - primE "@serialize" (T.Func (T.Local, T.Returns, [], [e.note.note_typ], [arg_t])) + let t = e.note.note_typ in + primE "@serialize" (T.Func (T.Local, T.Returns, [], [t], [T.Serialized t])) -*- e let map_tuple n f e = @@ -63,13 +65,14 @@ module Transform() = struct assert (c = T.Returns); assert (tbs = []); (* We do not support parametric messages *) assert (t2 = []); (* A returning sharable function has no return values *) - T.Func (T.Sharable, T.Returns, [], List.map (fun _ -> arg_t) t1, []) + T.Func (T.Sharable, T.Returns, [], List.map (fun t -> T.Serialized (t_typ t)) t1, []) | T.Func (T.Local, c, tbs, t1, t2) -> T.Func (T.Local, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2) | T.Opt t -> T.Opt (t_typ t) | T.Obj (s, fs) -> T.Obj (s, List.map t_field fs) | T.Mut t -> T.Mut (t_typ t) + | T.Serialized t -> assert false (* This transformation should only run once *) | T.Async t -> assert false (* Should happen after async-translation *) and t_bind {T.var; T.bound} = @@ -129,11 +132,10 @@ module Transform() = struct assert (typbinds = []); assert (T.is_unit typT); let args' = t_args args in - let arg_tys = List.map (fun a -> a.note) args' in - let raw_arg_vs = List.map (fun _ -> fresh_var arg_t) args' in + let raw_arg_vs = List.map (fun a -> fresh_var (T.Serialized a.note)) args' in let body' = blockE [letP (tupP (List.map varP (List.map exp_of_arg args'))) - (tupE (List.map2 deserialize raw_arg_vs arg_tys)) ] + (tupE (List.map deserialize raw_arg_vs)) ] (t_exp exp) in let args' = List.map arg_of_exp raw_arg_vs in FuncE (x, cc, [], args', T.unit, body') @@ -239,7 +241,7 @@ module Transform() = struct and t_typ_binds typbinds = List.map t_typ_bind typbinds - and t_prog (prog, flavor) = (t_block prog, flavor) + and t_prog (prog, flavor) = (t_block prog, { flavor with serialized = true }) end diff --git a/src/type.ml b/src/type.ml index 33fbcde6f98..ffed970b78c 100644 --- a/src/type.ml +++ b/src/type.ml @@ -20,7 +20,6 @@ type prim = | Float | Char | Text - | ElemBuf type t = typ and typ = @@ -35,6 +34,7 @@ and typ = | Async of typ (* future *) | Mut of typ (* mutable type *) | Shared (* sharable *) + | Serialized of typ (* a serialized value *) | Any (* top *) | Non (* bottom *) | Pre (* pre-type *) @@ -119,6 +119,7 @@ let rec shift i n t = | Obj (s, fs) -> Obj (s, List.map (shift_field n i) fs) | Mut t -> Mut (shift i n t) | Shared -> Shared + | Serialized t -> Serialized (shift i n t) | Any -> Any | Non -> Non | Pre -> Pre @@ -153,6 +154,7 @@ let rec subst sigma t = | Obj (s, fs) -> Obj (s, List.map (subst_field sigma) fs) | Mut t -> Mut (subst sigma t) | Shared -> Shared + | Serialized t -> Serialized (subst sigma t) | Any -> Any | Non -> Non | Pre -> Pre @@ -192,6 +194,7 @@ let rec open' i ts t = | Obj (s, fs) -> Obj (s, List.map (open_field i ts) fs) | Mut t -> Mut (open' i ts t) | Shared -> Shared + | Serialized t -> Serialized (open' i ts t) | Any -> Any | Non -> Non | Pre -> Pre @@ -249,6 +252,7 @@ let is_pair = function Tup [_; _] -> true | _ -> false let is_func = function Func _ -> true | _ -> false let is_async = function Async _ -> true | _ -> false let is_mut = function Mut _ -> true | _ -> false +let is_serialized = function Serialized _ -> true | _ -> false let invalid s = raise (Invalid_argument ("Type." ^ s)) @@ -263,6 +267,7 @@ let as_func = function Func (s, c, tbs, ts1, ts2) -> s, c, tbs, ts1, ts2 | _ -> let as_async = function Async t -> t | _ -> invalid "as_async" let as_mut = function Mut t -> t | _ -> invalid "as_mut" let as_immut = function Mut t -> t | t -> t +let as_serialized = function Serialized t -> t | _ -> invalid "as_serialized" let as_seq = function Tup ts -> ts | t -> [t] @@ -325,11 +330,11 @@ let rec span = function | Prim Word8 -> Some 0x100 | Prim Word16 -> Some 0x10000 | Prim (Word32 | Word64 | Char) -> None (* for all practical purpuses *) - | Prim ElemBuf -> None | Obj _ | Tup _ | Async _ -> Some 1 | Array _ | Func _ | Shared | Any -> None | Opt _ -> Some 2 | Mut t -> span t + | Serialized t -> None | Non -> Some 0 @@ -363,6 +368,7 @@ let rec avoid' cons = function | Async t -> Async (avoid' cons t) | Obj (s, fs) -> Obj (s, List.map (avoid_field cons) fs) | Mut t -> Mut (avoid' cons t) + | Serialized t -> Serialized (avoid' cons t) and avoid_bind cons {var; bound} = {var; bound = avoid' cons bound} @@ -466,6 +472,8 @@ let rec rel_typ rel eq t1 t2 = rel_typ rel eq t1' t2' | Mut t1', Mut t2' -> eq_typ rel eq t1' t2' + | Serialized t1', Serialized t2' -> + eq_typ rel eq t1' t2' (* TBR: eq or sub? Does it matter? *) | _, _ -> false end @@ -573,7 +581,6 @@ let string_of_prim = function | Word64 -> "Word64" | Char -> "Char" | Text -> "Text" - | ElemBuf -> "ElemBuf" let string_of_var (x, i) = if i = 0 then sprintf "%s" x else sprintf "%s.%d" x i @@ -649,6 +656,8 @@ and string_of_typ' vs t = sprintf "actor %s" (string_of_typ_nullary vs (Obj (Object Local, fs))) | Mut t -> sprintf "var %s" (string_of_typ' vs t) + | Serialized t -> + sprintf "serialized %s" (string_of_typ' vs t) | t -> string_of_typ_nullary vs t and string_of_field vs {lab; typ} = diff --git a/src/type.mli b/src/type.mli index 47a55f04311..9f41e972794 100644 --- a/src/type.mli +++ b/src/type.mli @@ -20,7 +20,6 @@ type prim = | Float | Char | Text - | ElemBuf type t = typ and typ = @@ -35,6 +34,7 @@ and typ = | Async of typ (* future *) | Mut of typ (* mutable type *) | Shared (* sharable *) + | Serialized of typ (* a serialized value *) | Any (* top *) | Non (* bottom *) | Pre (* pre-type *) @@ -70,6 +70,7 @@ val is_pair : typ -> bool val is_func : typ -> bool val is_async : typ -> bool val is_mut : typ -> bool +val is_serialized : typ -> bool val as_prim : prim -> typ -> unit val as_obj : typ -> obj_sort * field list @@ -82,6 +83,7 @@ val as_func : typ -> sharing * control * bind list * typ list * typ list val as_async : typ -> typ val as_mut : typ -> typ val as_immut : typ -> typ +val as_serialized : typ -> typ val as_prim_sub : prim -> typ -> unit val as_obj_sub : string -> typ -> obj_sort * field list diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 48ac936e377..18f6f46ecc8 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -51,5 +51,5 @@ non-closed actor: (ActorE ) (read read) (dec dec) - actor {dec : shared () -> (); read : shared ElemBuf -> ()} + actor {dec : shared () -> (); read : shared (serialized shared (serialized Int) -> ()) -> ()} ) From bf7ed36500657d1f798919d4c051d74df3d3c095 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 09:27:53 +0100 Subject: [PATCH 35/76] Push call to serialize into blocks and manifest tuples to produce cleaner code. Needed a small fix to how the compiler recognizes calls to prims. --- src/compile.ml | 43 ++++++++++++++++++++++--------------------- src/serialization.ml | 21 +++++++++++++-------- 2 files changed, 35 insertions(+), 29 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 60299417d3c..954c97e40b3 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3669,27 +3669,9 @@ and compile_exp (env : E.t) exp = compile_exp_as env SR.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]; _}) -> - begin - let compile_kernel_as sr inst = sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ inst - in match p with - | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) - | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) - | "shrs8" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word8 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ - sanitize_word_result Type.Word8) - | "shrs16" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word16 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ - sanitize_word_result Type.Word16) - | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) - | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) - - | _ -> SR.Vanilla, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) - end - (* Unary prims *) | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> begin + (* First check for all unary prims. *) match p with | "@serialize" -> SR.UnboxedReference, @@ -3829,8 +3811,27 @@ and compile_exp (env : E.t) exp = compile_exp_vanilla env e ^^ Dfinity.prim_print env | _ -> - SR.Unreachable, - todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + (* Now try the binary prims, expecting a manifest tuple argument *) + begin match e.it with + | TupE [e1;e2] -> + begin + let compile_kernel_as sr inst = sr, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ inst + in match p with + | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) + | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) + | "shrs8" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word8 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word8) + | "shrs16" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word16 ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result Type.Word16) + | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) + | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) + + | _ -> SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + end + | _ -> SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) + end end | VarE var -> Var.get_val env var.it diff --git a/src/serialization.ml b/src/serialization.ml index ea93aa993da..b0184317f2b 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -39,14 +39,19 @@ module Transform() = struct primE "@serialize" (T.Func (T.Local, T.Returns, [], [t], [T.Serialized t])) -*- e - let map_tuple n f e = - if n = 0 then e else - (* TODO: optimize if e is a manifest tuple *) - let ts = T.as_tup e.note.note_typ in - assert (List.length ts = n); - let vs = List.map fresh_var ts in - blockE [letP (seqP (List.map varP vs)) e] - (tupE (List.map serialize vs)) + let rec map_tuple n f e = match n, e.it with + | 0, _ -> e + | _, TupE es -> + assert (List.length es = n); + tupE (List.map f es) + | _, BlockE (ds, e) -> + blockE ds (map_tuple n f e) + | _, _ -> + let ts = T.as_tup e.note.note_typ in + assert (List.length ts = n); + let vs = List.map fresh_var ts in + blockE [letP (seqP (List.map varP vs)) e] + (tupE (List.map f vs)) let rec t_typ (t:T.typ) = match t with From 5279ab560eeb79c418c26c467d6e64a87eac678c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 23:54:41 +0100 Subject: [PATCH 36/76] Assert, not trap, if `match_arg` sees wrong number of parameters --- src/interpret_ir.ml | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/src/interpret_ir.ml b/src/interpret_ir.ml index 1c9a2a5a42a..bded36590fc 100644 --- a/src/interpret_ir.ml +++ b/src/interpret_ir.ml @@ -448,13 +448,9 @@ and match_args at args v : val_env = match args with | [a] -> match_arg a v | _ -> - match V.as_tup v with - | vs when List.length vs = List.length args -> - List.fold_left V.Env.adjoin V.Env.empty (List.map2 match_arg args vs) - | _ -> - trap at "argument value %s does not match parameter list" - (V.string_of_val v) - + let vs = V.as_tup v in + assert (List.length vs = List.length args); + List.fold_left V.Env.adjoin V.Env.empty (List.map2 match_arg args vs) (* Patterns *) From 68627378c0e029131a76b93bf840fb6cfb4ee37f Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Fri, 15 Mar 2019 23:06:07 +0100 Subject: [PATCH 37/76] Compile.FuncDec: Factor our bind_args --- src/compile.ml | 51 ++++++++++++++++++++++++-------------------------- 1 file changed, 24 insertions(+), 27 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 954c97e40b3..10ea46b8da6 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3116,6 +3116,15 @@ module FuncDec = struct Dfinity.compile_databuf_of_bytes env name ^^ export_self_message env + let bind_args env0 as_ bind_arg = + let rec go i env = function + | [] -> env + | a::as_ -> + let get = G.i (LocalGet (nr (Int32.of_int i))) in + let env' = bind_arg env a get in + go (i+1) env' as_ in + go 1 (* skip closure*) env0 as_ + (* Create a WebAssembly func from a pattern (for the argument) and the body. Parameter `captured` should contain the, well, captured local variables that the function will find in the closure. *) @@ -3128,19 +3137,13 @@ module FuncDec = struct let (env2, closure_code) = restore_env env1 get_closure in (* Add arguments to the environment *) - let env3 = - let rec go i env = function - | [] -> env - | a::as_ -> - let get env = G.i (LocalGet (nr (Int32.of_int i))) in - let env' = - E.add_local_deferred env a.it - { materialize = (fun env -> SR.Vanilla, get env) - ; materialize_vanilla = get - ; is_local = true - } in - go (i+1) env' as_ in - go 1 (* skip closure*) env2 args in + let env3 = bind_args env2 args (fun env a get -> + E.add_local_deferred env a.it + { materialize = (fun env -> SR.Vanilla, get) + ; materialize_vanilla = (fun _ -> get) + ; is_local = true + } + ) in closure_code ^^ mk_body env3 @@ -3170,20 +3173,14 @@ module FuncDec = struct let (env2, closure_code) = restore_env env1 get_closure in (* Add arguments to the environment, as unboxed references *) - let env3 = - let rec go i env = function - | [] -> env - | a::as_ -> - let get env = G.i (LocalGet (nr Int32.(of_int i))) in - let env' = - E.add_local_deferred env a.it - { materialize = (fun env -> SR.UnboxedReference, get env) - ; materialize_vanilla = (fun env -> - get env ^^ StackRep.adjust env SR.UnboxedReference SR.Vanilla) - ; is_local = true - } in - go (i+1) env' as_ in - go 1 (* skip closure*) env2 args in + let env3 = bind_args env2 args (fun env a get -> + E.add_local_deferred env a.it + { materialize = (fun env -> SR.UnboxedReference, get) + ; materialize_vanilla = (fun env -> + get ^^ StackRep.adjust env SR.UnboxedReference SR.Vanilla) + ; is_local = true + } + ) in closure_code ^^ mk_body env3 ^^ From 58f7bcee8a01686c8803795fadbadd172c03284c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Fri, 15 Mar 2019 17:23:38 +0100 Subject: [PATCH 38/76] Remove a comment from data-params.as --- test/run-dfinity/data-params.as | 10 ---------- test/run-dfinity/ok/data-params.run-ir.ok | 4 ++-- test/run-dfinity/ok/data-params.run-low.ok | 4 ++-- test/run-dfinity/ok/data-params.run.ok | 4 ++-- test/run-dfinity/ok/data-params.tc.ok | 4 ++-- test/run-dfinity/ok/data-params.wasm.stderr.ok | 4 ++-- 6 files changed, 10 insertions(+), 20 deletions(-) diff --git a/test/run-dfinity/data-params.as b/test/run-dfinity/data-params.as index cfa7fc937f6..b4f94319050 100644 --- a/test/run-dfinity/data-params.as +++ b/test/run-dfinity/data-params.as @@ -48,9 +48,6 @@ let a = actor { printInt(c); print("\n"); }; - readCounter(f : shared Nat -> ()) : () { - f(c); - }; }; @@ -70,7 +67,6 @@ a.increcord(shared {x = 17; y = 18; z = 19}); a.printCounter(); a.printLabeled("Foo1: "); a.printLabeledOpt(?"Foo2: "); -// a.readCounter(func (n : Nat) = { printInt n; print("\n") }); a.incn(10000000000000); @@ -124,9 +120,6 @@ let w32 = actor { printInt(word32ToInt(c)); print("\n"); }; - readCounter(f : shared Word32 -> ()) : () { - f(c); - }; }; @@ -199,9 +192,6 @@ let w16 = actor { printInt(word16ToInt(c)); print("\n"); }; - readCounter(f : shared Word16 -> ()) : () { - f(c); - }; }; diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index f879c2bfdac..a814fca710b 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -1,6 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:122.19-122.27: warning, this pattern does not cover all possible values -data-params.as:197.19-197.27: warning, this pattern does not cover all possible values +data-params.as:118.19-118.27: warning, this pattern does not cover all possible values +data-params.as:190.19-190.27: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index f879c2bfdac..a814fca710b 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -1,6 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:122.19-122.27: warning, this pattern does not cover all possible values -data-params.as:197.19-197.27: warning, this pattern does not cover all possible values +data-params.as:118.19-118.27: warning, this pattern does not cover all possible values +data-params.as:190.19-190.27: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index f879c2bfdac..a814fca710b 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -1,6 +1,6 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:122.19-122.27: warning, this pattern does not cover all possible values -data-params.as:197.19-197.27: warning, this pattern does not cover all possible values +data-params.as:118.19-118.27: warning, this pattern does not cover all possible values +data-params.as:190.19-190.27: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.tc.ok b/test/run-dfinity/ok/data-params.tc.ok index 1db161147e8..a83d17237ff 100644 --- a/test/run-dfinity/ok/data-params.tc.ok +++ b/test/run-dfinity/ok/data-params.tc.ok @@ -1,3 +1,3 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:122.19-122.27: warning, this pattern does not cover all possible values -data-params.as:197.19-197.27: warning, this pattern does not cover all possible values +data-params.as:118.19-118.27: warning, this pattern does not cover all possible values +data-params.as:190.19-190.27: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/data-params.wasm.stderr.ok b/test/run-dfinity/ok/data-params.wasm.stderr.ok index 1db161147e8..a83d17237ff 100644 --- a/test/run-dfinity/ok/data-params.wasm.stderr.ok +++ b/test/run-dfinity/ok/data-params.wasm.stderr.ok @@ -1,3 +1,3 @@ data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:122.19-122.27: warning, this pattern does not cover all possible values -data-params.as:197.19-197.27: warning, this pattern does not cover all possible values +data-params.as:118.19-118.27: warning, this pattern does not cover all possible values +data-params.as:190.19-190.27: warning, this pattern does not cover all possible values From 432a47ab03d3c21d8681dbb43fc4302efdfa4a66 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 16:00:46 +0100 Subject: [PATCH 39/76] Extract heap traversal functions into own module they were in `Serialization`, but were also used by `GC`, so move them out. --- src/compile.ml | 258 +++++++++++++++++++++++++------------------------ 1 file changed, 131 insertions(+), 127 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 10ea46b8da6..7244ac68d9a 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -665,6 +665,7 @@ module Heap = struct ) ) + end (* Heap *) module ElemHeap = struct @@ -2227,6 +2228,127 @@ module OrthogonalPersistence = struct end (* OrthogonalPersistence *) +module HeapTraversal = struct + (* Returns the object size (in words) *) + let object_size env = + Func.share_code1 env "object_size" ("x", I32Type) [I32Type] (fun env get_x -> + get_x ^^ + Tagged.branch env (ValBlockType (Some I32Type)) + [ Tagged.Int, + compile_unboxed_const 3l + ; Tagged.SmallWord, + compile_unboxed_const 2l + ; Tagged.Reference, + compile_unboxed_const 2l + ; Tagged.Some, + compile_unboxed_const 2l + ; Tagged.ObjInd, + compile_unboxed_const 2l + ; Tagged.MutBox, + compile_unboxed_const 2l + ; Tagged.Array, + get_x ^^ + Heap.load_field Array.len_field ^^ + compile_add_const Array.header_size + ; Tagged.Text, + get_x ^^ + Heap.load_field Text.len_field ^^ + compile_add_const 3l ^^ + compile_divU_const Heap.word_size ^^ + compile_add_const Text.header_size + ; Tagged.Object, + get_x ^^ + Heap.load_field Object.size_field ^^ + compile_mul_const 2l ^^ + compile_add_const Object.header_size + ; Tagged.Closure, + get_x ^^ + Heap.load_field Closure.len_field ^^ + compile_add_const Closure.header_size + ] + (* Indirections have unknown size. *) + ) + + let walk_heap_from_to env compile_from compile_to mk_code = + let (set_x, get_x) = new_local env "x" in + compile_from ^^ set_x ^^ + compile_while + (* While we have not reached the end of the area *) + ( get_x ^^ + compile_to ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) + ) + ( mk_code get_x ^^ + get_x ^^ + get_x ^^ object_size env ^^ compile_mul_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_x + ) + + (* Calls mk_code for each pointer in the object pointed to by get_x, + passing code get the address of the pointer. *) + 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 (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, + get_x ^^ + Heap.load_field Array.len_field ^^ + (* Adjust fields *) + from_0_to_n env (fun get_i -> + get_x ^^ + get_i ^^ + Array.idx env ^^ + set_ptr_loc ^^ + mk_code get_ptr_loc + ) + ; Tagged.Object, + get_x ^^ + Heap.load_field Object.size_field ^^ + + from_0_to_n env (fun get_i -> + get_i ^^ + compile_mul_const 2l ^^ + compile_add_const 1l ^^ + compile_add_const Object.header_size ^^ + compile_mul_const Heap.word_size ^^ + get_x ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_ptr_loc ^^ + mk_code get_ptr_loc + ) + ; Tagged.Closure, + get_x ^^ + Heap.load_field Closure.len_field ^^ + + from_0_to_n env (fun get_i -> + get_i ^^ + compile_add_const Closure.header_size ^^ + compile_mul_const Heap.word_size ^^ + get_x ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_ptr_loc ^^ + mk_code get_ptr_loc + ) + ] + +end (* HeapTraversal *) + module Serialization = struct (* The serialization strategy is as follows: @@ -2433,128 +2555,10 @@ module Serialization = struct ) ) - (* Returns the object size (in words) *) - let object_size env = - Func.share_code1 env "object_size" ("x", I32Type) [I32Type] (fun env get_x -> - get_x ^^ - Tagged.branch env (ValBlockType (Some I32Type)) - [ Tagged.Int, - compile_unboxed_const 3l - ; Tagged.SmallWord, - compile_unboxed_const 2l - ; Tagged.Reference, - compile_unboxed_const 2l - ; Tagged.Some, - compile_unboxed_const 2l - ; Tagged.ObjInd, - compile_unboxed_const 2l - ; Tagged.MutBox, - compile_unboxed_const 2l - ; Tagged.Array, - get_x ^^ - Heap.load_field Array.len_field ^^ - compile_add_const Array.header_size - ; Tagged.Text, - get_x ^^ - Heap.load_field Text.len_field ^^ - compile_add_const 3l ^^ - compile_divU_const Heap.word_size ^^ - compile_add_const Text.header_size - ; Tagged.Object, - get_x ^^ - Heap.load_field Object.size_field ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size - ; Tagged.Closure, - get_x ^^ - Heap.load_field Closure.len_field ^^ - compile_add_const Closure.header_size - ] - (* Indirections have unknown size. *) - ) - - let walk_heap_from_to env compile_from compile_to mk_code = - let (set_x, get_x) = new_local env "x" in - compile_from ^^ set_x ^^ - compile_while - (* While we have not reached the end of the area *) - ( get_x ^^ - compile_to ^^ - G.i (Compare (Wasm.Values.I32 I32Op.LtU)) - ) - ( mk_code get_x ^^ - get_x ^^ - get_x ^^ object_size env ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - set_x - ) - - (* Calls mk_code for each pointer in the object pointed to by get_x, - passing code get the address of the pointer. *) - 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 (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, - get_x ^^ - Heap.load_field Array.len_field ^^ - (* Adjust fields *) - from_0_to_n env (fun get_i -> - get_x ^^ - get_i ^^ - Array.idx env ^^ - set_ptr_loc ^^ - mk_code get_ptr_loc - ) - ; Tagged.Object, - get_x ^^ - Heap.load_field Object.size_field ^^ - - from_0_to_n env (fun get_i -> - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const 1l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_x ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - set_ptr_loc ^^ - mk_code get_ptr_loc - ) - ; Tagged.Closure, - get_x ^^ - Heap.load_field Closure.len_field ^^ - - from_0_to_n env (fun get_i -> - get_i ^^ - compile_add_const Closure.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_x ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - set_ptr_loc ^^ - mk_code get_ptr_loc - ) - ] - let shift_pointers env = Func.share_code3 env "shift_pointers" (("start", I32Type), ("to", I32Type), ("ptr_offset", I32Type)) [] (fun env get_start get_to get_ptr_offset -> - walk_heap_from_to env get_start get_to (fun get_x -> - for_each_pointer env get_x (fun get_ptr_loc -> + HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> + HeapTraversal.for_each_pointer env get_x (fun get_ptr_loc -> get_ptr_loc ^^ get_ptr_offset ^^ shift_pointer_at env @@ -2568,7 +2572,7 @@ module Serialization = struct compile_unboxed_zero ^^ set_i ^^ - walk_heap_from_to env get_start get_to (fun get_x -> + HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, @@ -2594,7 +2598,7 @@ module Serialization = struct let intract_references env = Func.share_code3 env "intract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [] (fun env get_start get_to get_tbl_area -> - walk_heap_from_to env get_start get_to (fun get_x -> + HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> get_x ^^ Tagged.branch_default env (ValBlockType None) G.nop [ Tagged.Reference, @@ -2836,7 +2840,7 @@ module GC = struct ] ^^ (* Copy the referenced object to to space *) - get_obj ^^ Serialization.object_size env ^^ set_len ^^ + get_obj ^^ HeapTraversal.object_size env ^^ set_len ^^ get_obj ^^ get_end_to_space ^^ get_len ^^ Heap.memcpy_words_skewed env ^^ @@ -2897,18 +2901,18 @@ module GC = struct compile_add_const ClosureTable.loc ^^ compile_add_const ptr_skew )) ^^ - Serialization.walk_heap_from_to env + HeapTraversal.walk_heap_from_to env (compile_unboxed_const Int32.(add ClosureTable.table_end ptr_skew)) (compile_unboxed_const Int32.(add end_of_static_space ptr_skew)) - (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ + (fun get_x -> HeapTraversal.for_each_pointer env get_x evac) ^^ (* Go through the to-space, and evacuate that. Note that get_end_to_space changes as we go, but walk_heap_from_to can handle that. *) - Serialization.walk_heap_from_to env + HeapTraversal.walk_heap_from_to env get_begin_to_space get_end_to_space - (fun get_x -> Serialization.for_each_pointer env get_x evac) ^^ + (fun get_x -> HeapTraversal.for_each_pointer env get_x evac) ^^ (* Copy the to-space to the beginning of memory. *) get_begin_to_space ^^ compile_add_const ptr_unskew ^^ From bb18a904755e66fa50995e69bd93fb50961863df Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 17:47:57 +0100 Subject: [PATCH 40/76] Factor out Array.alloc --- src/compile.ml | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 7244ac68d9a..0f4f5fec6d0 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1799,15 +1799,10 @@ module Array = struct | "vals" -> Some (fake_object_idx_option env "array_vals") | _ -> None - (* The primitive operations *) - (* No need to wrap them in RTS functions: They occur only once, in the prelude. *) - let init env = + (* Does not initialize the fields! *) + let alloc env = let (set_len, get_len) = new_local env "len" in - let (set_x, get_x) = new_local env "x" in 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 *) @@ -1823,6 +1818,24 @@ module Array = struct get_len ^^ Heap.store_field len_field ^^ + get_r + + (* The primitive operations *) + (* 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 + 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 *) + get_len ^^ + alloc env ^^ + set_r ^^ + (* Write fields *) get_len ^^ from_0_to_n env (fun get_i -> @@ -1845,17 +1858,9 @@ module Array = struct (* Allocate *) get_len ^^ - compile_add_const header_size ^^ - Heap.dyn_alloc_words env ^^ + alloc env ^^ set_r ^^ - (* Write header *) - get_r ^^ - Tagged.store Tagged.Array ^^ - get_r ^^ - get_len ^^ - Heap.store_field len_field ^^ - (* Write fields *) get_len ^^ from_0_to_n env (fun get_i -> From 6d0531b666fe796230b22703b19f5406819a8e3e Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Fri, 15 Mar 2019 17:21:49 +0100 Subject: [PATCH 41/76] Factor out Text.alloc --- src/compile.ml | 54 +++++++++++++++++++++----------------------------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 0f4f5fec6d0..24f8c153656 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1555,6 +1555,22 @@ module Text = struct let ptr = E.add_static_bytes env data in compile_unboxed_const ptr + let alloc env = Func.share_code1 env "text_alloc" ("len", I32Type) [I32Type] (fun env get_len -> + let (set_x, get_x) = new_local env "x" in + compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ + get_len ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + Heap.dyn_alloc_bytes env ^^ + set_x ^^ + + get_x ^^ Tagged.store Tagged.Text ^^ + get_x ^^ get_len ^^ Heap.store_field len_field ^^ + get_x + ) + + let payload_ptr_unskewed = + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) + (* String concatentation. Expects two strings on stack *) let concat env = Func.share_code2 env "concat" (("x", I32Type), ("y", I32Type)) [I32Type] (fun env get_x get_y -> let (set_z, get_z) = new_local env "z" in @@ -1565,46 +1581,22 @@ module Text = struct get_y ^^ Heap.load_field len_field ^^ set_len2 ^^ (* allocate memory *) - compile_unboxed_const (Int32.mul Heap.word_size header_size) ^^ get_len1 ^^ get_len2 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.dyn_alloc_bytes env ^^ + alloc env ^^ set_z ^^ - (* Set tag *) - get_z ^^ Tagged.store Tagged.Text ^^ - - (* Set length *) - get_z ^^ - get_len1 ^^ - get_len2 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.store_field len_field ^^ - (* Copy first string *) - get_x ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ - - get_z ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ - + get_x ^^ payload_ptr_unskewed ^^ + get_z ^^ payload_ptr_unskewed ^^ get_len1 ^^ - Heap.memcpy env ^^ (* Copy second string *) - get_y ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ - - get_z ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ - get_len1 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - + get_y ^^ payload_ptr_unskewed ^^ + get_z ^^ payload_ptr_unskewed ^^ get_len1 ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ get_len2 ^^ - Heap.memcpy env ^^ (* Done *) @@ -1630,13 +1622,13 @@ module Text = struct get_len1 ^^ from_0_to_n env (fun get_i -> get_x ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) ^^ + payload_ptr_unskewed ^^ get_i ^^ 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.(add ptr_unskew (mul Heap.word_size header_size)) ^^ + payload_ptr_unskewed ^^ get_i ^^ 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)}) ^^ From a41754afb616696d92ff48e8a731fd6994a5167f Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Sat, 16 Mar 2019 13:43:44 +0100 Subject: [PATCH 42/76] AST-33: bit-testing of words (#239) * AST-33: interpret and compile btstWord* --- src/compile.ml | 22 +++++++++++++++++++ src/prelude.ml | 16 ++++++++++++++ .../ok/counter-class.wasm.stderr.ok | 16 +++++++------- test/run/ok/words.run-ir.ok | 12 ++++++++++ test/run/ok/words.run-low.ok | 12 ++++++++++ test/run/ok/words.run.ok | 12 ++++++++++ test/run/words.as | 15 +++++++++++++ 7 files changed, 97 insertions(+), 8 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 24f8c153656..15c0d5d9399 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3825,6 +3825,28 @@ and compile_exp (env : E.t) exp = sanitize_word_result Type.Word16) | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) + | "btst8" -> compile_kernel_as SR.Vanilla ( + let ty = Type.Word8 in + let (set_b, get_b) = new_local env "b" + in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ + compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And))) + | "btst16" -> compile_kernel_as SR.Vanilla ( + let ty = Type.Word16 in + let (set_b, get_b) = new_local env "b" + in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ + compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And))) + | "btst" -> compile_kernel_as SR.UnboxedWord32 ( + let (set_b, get_b) = new_local env "b" + in set_b ^^ compile_unboxed_one ^^ get_b ^^ G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And))) + | "btst64" -> compile_kernel_as SR.UnboxedInt64 ( + let (set_b, get_b) = new_local64 env "b" + in set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.And))) | _ -> SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end diff --git a/src/prelude.ml b/src/prelude.ml index 41deded215d..2de8f86c42a 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -63,21 +63,25 @@ func shrsWord8(w : Word8, amount : Word8) : Word8 = (prim "shrs8" : (Word8, Word func popcntWord8(w : Word8) : Word8 = (prim "popcnt8" : Word8 -> Word8) w; func clzWord8(w : Word8) : Word8 = (prim "clz8" : Word8 -> Word8) w; func ctzWord8(w : Word8) : Word8 = (prim "ctz8" : Word8 -> Word8) w; +func btstWord8(w : Word8, amount : Word8) : Bool = (prim "btst8" : (Word8, Word8) -> Word8) (w, amount) != (0 : Word8); func shrsWord16(w : Word16, amount : Word16) : Word16 = (prim "shrs16" : (Word16, Word16) -> Word16) (w, amount); func popcntWord16(w : Word16) : Word16 = (prim "popcnt16" : Word16 -> Word16) w; func clzWord16(w : Word16) : Word16 = (prim "clz16" : Word16 -> Word16) w; func ctzWord16(w : Word16) : Word16 = (prim "ctz16" : Word16 -> Word16) w; +func btstWord16(w : Word16, amount : Word16) : Bool = (prim "btst16" : (Word16, Word16) -> Word16) (w, amount) != (0 : Word16); func shrsWord32(w : Word32, amount : Word32) : Word32 = (prim "shrs" : (Word32, Word32) -> Word32) (w, amount); func popcntWord32(w : Word32) : Word32 = (prim "popcnt" : Word32 -> Word32) w; func clzWord32(w : Word32) : Word32 = (prim "clz" : Word32 -> Word32) w; func ctzWord32(w : Word32) : Word32 = (prim "ctz" : Word32 -> Word32) w; +func btstWord32(w : Word32, amount : Word32) : Bool = (prim "btst" : (Word32, Word32) -> Word32) (w, amount) != (0 : Word32); func shrsWord64(w : Word64, amount : Word64) : Word64 = (prim "shrs64" : (Word64, Word64) -> Word64) (w, amount); func popcntWord64(w : Word64) : Word64 = (prim "popcnt64" : Word64 -> Word64) w; func clzWord64(w : Word64) : Word64 = (prim "clz64" : Word64 -> Word64) w; func ctzWord64(w : Word64) : Word64 = (prim "ctz64" : Word64 -> Word64) w; +func btstWord64(w : Word64, amount : Word64) : Bool = (prim "btst64" : (Word64, Word64) -> Word64) (w, amount) != (0 : Word64); // This would be nicer as a objects, but lets do them as functions @@ -230,6 +234,18 @@ let prim = function | Word64 w -> Word64 (Word64.ctz w) | _ -> failwith "ctz") + | "btst8" + | "btst16" + | "btst" + | "btst64" -> fun v k -> + let w, a = as_pair v + in k (match w with + | Word8 y -> Word8 Word8.(and_ y (shl (of_int_u 1) (as_word8 a))) + | Word16 y -> Word16 Word16.(and_ y (shl (of_int_u 1) (as_word16 a))) + | Word32 y -> Word32 (Word32.and_ y (Word32.shl 1l (as_word32 a))) + | Word64 y -> Word64 (Word64.and_ y (Word64.shl 1L (as_word64 a))) + | _ -> failwith "btst") + | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit | "@serialize" -> fun v k -> k (Serialized v) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 18f6f46ecc8..cb1f1836617 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -18,31 +18,31 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (params $60) + (params $68) () (BlockE (LetD - (TupP (VarP $58)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $60))) + (TupP (VarP $66)) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $68))) ) (CallE ( 1 -> 0) (FuncE $lambda ( 1 -> 0) - (params $57) + (params $65) () - (CallE ( 1 -> 0) (VarE $57) (VarE c)) + (CallE ( 1 -> 0) (VarE $65) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (params $59) + (params $67) () (CallE (shared 1 -> 0) - (VarE $58) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $59)) + (VarE $66) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $67)) ) ) ) diff --git a/test/run/ok/words.run-ir.ok b/test/run/ok/words.run-ir.ok index 15c4b3b8c29..a3f996d1a6f 100644 --- a/test/run/ok/words.run-ir.ok +++ b/test/run/ok/words.run-ir.ok @@ -19,6 +19,9 @@ 61 61 49 49 5 5 +set +clear +set 8912765 8912765 4286054531 -8912765 4286054530 -8912766 @@ -40,6 +43,9 @@ 29 29 17 17 5 5 +set +clear +set 55734 -9802 9802 9802 9801 9801 @@ -60,6 +66,9 @@ 13 13 1 1 5 5 +set +clear +set 34 34 222 -34 221 -35 @@ -80,3 +89,6 @@ 5 5 0 0 3 3 +set +clear +set diff --git a/test/run/ok/words.run-low.ok b/test/run/ok/words.run-low.ok index 15c4b3b8c29..a3f996d1a6f 100644 --- a/test/run/ok/words.run-low.ok +++ b/test/run/ok/words.run-low.ok @@ -19,6 +19,9 @@ 61 61 49 49 5 5 +set +clear +set 8912765 8912765 4286054531 -8912765 4286054530 -8912766 @@ -40,6 +43,9 @@ 29 29 17 17 5 5 +set +clear +set 55734 -9802 9802 9802 9801 9801 @@ -60,6 +66,9 @@ 13 13 1 1 5 5 +set +clear +set 34 34 222 -34 221 -35 @@ -80,3 +89,6 @@ 5 5 0 0 3 3 +set +clear +set diff --git a/test/run/ok/words.run.ok b/test/run/ok/words.run.ok index 15c4b3b8c29..a3f996d1a6f 100644 --- a/test/run/ok/words.run.ok +++ b/test/run/ok/words.run.ok @@ -19,6 +19,9 @@ 61 61 49 49 5 5 +set +clear +set 8912765 8912765 4286054531 -8912765 4286054530 -8912766 @@ -40,6 +43,9 @@ 29 29 17 17 5 5 +set +clear +set 55734 -9802 9802 9802 9801 9801 @@ -60,6 +66,9 @@ 13 13 1 1 5 5 +set +clear +set 34 34 222 -34 221 -35 @@ -80,3 +89,6 @@ 5 5 0 0 3 3 +set +clear +set diff --git a/test/run/words.as b/test/run/words.as index a6a2cd0128a..479df6a7f2a 100644 --- a/test/run/words.as +++ b/test/run/words.as @@ -1,5 +1,8 @@ // CHECK: func $start +func printBit(a : Bool) { print(if a "set" else "clear"); print "\n" }; + + func checkpointAlpha() {}; func checkpointBravo() {}; func checkpointCharlie() {}; @@ -53,6 +56,9 @@ func checkpointJuliett() {}; printW64ln(popcntWord64 d); // -15 = 0xfffffffffffffff1 = 0b1111_..._1111_1111_0001 (population = 61) printW64ln(clzWord64 e); // 20000 = 0x0000000000004e20 (leading zeros = 49) printW64ln(ctzWord64 e); // 20000 = 0x0000000000004e20 (trailing zeros = 5) + printBit(btstWord64(e, 5 : Word64)); // 20000 = 0x0000000000004e20 (result = true) + printBit(btstWord64(e, 63 : Word64)); // 20000 = 0x0000000000004e20 (result = false) + printBit(btstWord64(e, 69 : Word64)); // 20000 = 0x0000000000004e20 (mod 64, result = true) assert (3 : Word64 ** (4 : Word64) == (81 : Word64)); assert (3 : Word64 ** (7 : Word64) == (2187 : Word64)); @@ -105,6 +111,9 @@ func checkpointJuliett() {}; printW32ln(popcntWord32 d); // -15 = 0xfffffff1 = 0b1111_1111_1111_1111_1111_1111_1111_0001 (population = 29) printW32ln(clzWord32 e); // 20000 = 0x00004e20 (leading zeros = 17) printW32ln(ctzWord32 e); // 20000 = 0x00004e20 (trailing zeros = 5) + printBit(btstWord32(e, 5 : Word32)); // 20000 = 0x00004e20 (result = true) + printBit(btstWord32(e, 31 : Word32)); // 20000 = 0x00004e20 (result = false) + printBit(btstWord32(e, 37 : Word32)); // 20000 = 0x00004e20 (mod 32, result = true) assert (3 : Word32 ** (4 : Word32) == (81 : Word32)); assert (3 : Word32 ** (7 : Word32) == (2187 : Word32)); @@ -180,6 +189,9 @@ func checkpointJuliett() {}; printW16ln(popcntWord16 d); // -15 = 0xfff1 = 0b1111_1111_1111_0001 (population = 13) printW16ln(clzWord16 e); // 20000 = 0x4e20 (leading zeros = 1) printW16ln(ctzWord16 e); // 20000 = 0x4e20 (trailing zeros = 5) + printBit(btstWord16(e, 5 : Word16)); // 20000 = 0x4e20 (result = true) + printBit(btstWord16(e, 15 : Word16)); // 20000 = 0x4e20 (result = false) + printBit(btstWord16(e, 21 : Word16)); // 20000 = 0x4e20 (mod 16, result = true) assert (3 : Word16 ** (0 : Word16) == (1 : Word16)); @@ -251,6 +263,9 @@ func checkpointJuliett() {}; printW8ln(popcntWord8 d); // -15 = 0xf1 = 0b1111_0001 (population = 5) printW8ln(clzWord8 e); // 200 = 0xC8 (leading zeros = 0) printW8ln(ctzWord8 e); // 200 = 0xC8 (trailing zeros = 3) + printBit(btstWord8(e, 3 : Word8)); // 200 = 0xC8 (result = true) + printBit(btstWord8(e, 5 : Word8)); // 200 = 0xC8 (result = false) + printBit(btstWord8(e, 11 : Word8)); // 200 = 0xC8 (mod 8, result = true) assert (3 : Word8 ** (0 : Word8) == (1 : Word8)); assert (3 : Word8 ** (3 : Word8) == (27 : Word8)); From e207b2de04d61f30724c3c040a8dca967a54e33f Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 16 Mar 2019 16:58:23 +0100 Subject: [PATCH 43/76] Move more useful functions into module UnboxedSmallWord (#245) * Move more useful functions into module UnboxedSmallWord as they will be needed in `module Serialize` * factor out clz/ctz,shrs and btst kernels into module UnboxedSmallWord --- src/compile.ml | 200 +++++++++++++++++++++++-------------------------- 1 file changed, 93 insertions(+), 107 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 15c0d5d9399..3febadc7e38 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1328,6 +1328,70 @@ module UnboxedSmallWord = struct | Wasm.Sexpr.Atom s -> seed ^ "<" ^ s ^ ">" | wtf -> todo "name_of_type" wtf seed + (* Makes sure that we only shift/rotate the maximum number of bits available in the word. *) + let clamp_shift_amount = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (bitwidth_mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + + let shiftWordNtoI32 b = + compile_unboxed_const b ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) + + let shift_leftWordNtoI32 b = + compile_unboxed_const b ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + + (* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *) + let lsb_adjust = function + | Type.Word32 -> G.nop + | ty -> shiftWordNtoI32 (shift_of_type ty) + + (* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) + let msb_adjust = function + | Type.Word32 -> G.nop + | ty -> shift_leftWordNtoI32 (shift_of_type ty) + + (* Makes sure that the word representation invariant is restored. *) + let sanitize_word_result = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (mask_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + + (* Sets the number (according to the type's word invariant) of LSBs. *) + let compile_word_padding = function + | Type.Word32 -> G.nop + | ty -> compile_unboxed_const (padding_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) + + (* Kernel for counting leading zeros, according to the word invariant. *) + let clz_kernel ty = + compile_word_padding ty ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^ + msb_adjust ty + + (* Kernel for counting trailing zeros, according to the word invariant. *) + let ctz_kernel ty = + compile_word_padding ty ^^ + compile_unboxed_const (shift_of_type ty) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^ + G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^ + msb_adjust ty + + (* Kernel for arithmetic (signed) shift, according to the word invariant. *) + let shrs_kernel ty = + lsb_adjust ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ + sanitize_word_result ty + + (* Kernel for testing a bit position, according to the word invariant. *) + let btst_kernel env ty = + let (set_b, get_b) = new_local env "b" + in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ + compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.And)) + end (* UnboxedSmallWord *) (* Primitive functions *) @@ -1362,11 +1426,8 @@ module Prim = struct *) let prim_word32toNat = G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) - let prim_shiftWordNtoI32 b = - compile_unboxed_const b ^^ - G.i (Binary (I32 I32Op.ShrU)) let prim_shiftWordNtoUnsigned b = - prim_shiftWordNtoI32 b ^^ + UnboxedSmallWord.shiftWordNtoI32 b ^^ prim_word32toNat let prim_word32toInt = G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) @@ -1376,12 +1437,9 @@ module Prim = struct prim_word32toInt let prim_intToWord32 = G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) - let prim_shift_leftWordNtoI32 b = - compile_unboxed_const b ^^ - G.i (Binary (I32 I32Op.Shl)) let prim_shiftToWordN b = prim_intToWord32 ^^ - prim_shift_leftWordNtoI32 b + UnboxedSmallWord.shift_leftWordNtoI32 b end (* Prim *) module Object = struct @@ -3439,33 +3497,6 @@ let compile_unop env t op = Syntax.(match op, t with | _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable) ) -(* Makes sure that we only shift/rotate the maximum number of bits available in the word. *) -let clamp_shift_amount = function - | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (UnboxedSmallWord.bitwidth_mask_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) - -(* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *) -let lsb_adjust = function - | Type.Word32 -> G.nop - | ty -> Prim.prim_shiftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) - -(* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) -let msb_adjust = function - | Type.Word32 -> G.nop - | ty -> Prim.prim_shift_leftWordNtoI32 (UnboxedSmallWord.shift_of_type ty) - -(* Makes sure that the word representation invariant is restored. *) -let sanitize_word_result = function - | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (UnboxedSmallWord.mask_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) - -(* Makes sure that the word representation invariant is restored. *) -let compile_word_padding = function - | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (UnboxedSmallWord.padding_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) (* This returns a single StackRep, to be used for both arguments and the result. One could imagine operators that require or produce different StackReps, @@ -3491,7 +3522,7 @@ let rec compile_binop env t op = | Type.Prim Type.(Word8 | Word16 | Word32), AddOp -> G.i (Binary (Wasm.Values.I32 I32Op.Add)) | Type.Prim Type.(Word8 | Word16 | Word32), SubOp -> G.i (Binary (Wasm.Values.I32 I32Op.Sub)) - | Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> lsb_adjust ty ^^ + | Type.(Prim (Word8|Word16|Word32 as ty)), MulOp -> UnboxedSmallWord.lsb_adjust ty ^^ G.i (Binary (Wasm.Values.I32 I32Op.Mul)) | Type.Prim Type.(Word8 | Word16 | Word32), DivOp -> G.i (Binary (Wasm.Values.I32 I32Op.DivU)) | Type.Prim Type.(Word8 | Word16 | Word32), ModOp -> G.i (Binary (Wasm.Values.I32 I32Op.RemU)) @@ -3513,7 +3544,7 @@ let rec compile_binop env t op = G.if_ (StackRep.to_block_type env SR.UnboxedWord32) (square_recurse_with_shifted G.nop) (get_n ^^ - square_recurse_with_shifted (sanitize_word_result ty) ^^ + square_recurse_with_shifted (UnboxedSmallWord.sanitize_word_result ty) ^^ mul))) in pow () | Type.(Prim Int), PowOp -> @@ -3552,31 +3583,31 @@ let rec compile_binop env t op = | Type.(Prim Word64), XorOp -> G.i (Binary (Wasm.Values.I64 I64Op.Xor)) | Type.Prim Type.(Word8 | Word16 | Word32), XorOp -> G.i (Binary (Wasm.Values.I32 I32Op.Xor)) | Type.(Prim Word64), ShLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Shl)) - | Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> + | Type.(Prim (Word8|Word16|Word32 as ty)), ShLOp -> UnboxedSmallWord.( lsb_adjust ty ^^ clamp_shift_amount ty ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + G.i (Binary (Wasm.Values.I32 I32Op.Shl))) | Type.(Prim Word64), ShROp -> G.i (Binary (Wasm.Values.I64 I64Op.ShrU)) - | Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> + | Type.(Prim (Word8|Word16|Word32 as ty)), ShROp -> UnboxedSmallWord.( lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ - sanitize_word_result ty + sanitize_word_result ty) | Type.(Prim Word64), RotLOp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotl)) | Type.Prim Type. Word32, RotLOp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotl)) - | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> - Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] + | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> UnboxedSmallWord.( + Func.share_code2 env (name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] Wasm.Values.(fun env get_n get_by -> - let beside_adjust = compile_unboxed_const (Int32.sub 32l (UnboxedSmallWord.shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in + let beside_adjust = compile_unboxed_const (Int32.sub 32l (shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^ get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^ - sanitize_word_result ty) + sanitize_word_result ty)) | Type.(Prim Word64), RotROp -> G.i (Binary (Wasm.Values.I64 I64Op.Rotr)) | Type.Prim Type. Word32, RotROp -> G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) - | Type.Prim Type.(Word8 | Word16 as ty), RotROp -> - Func.share_code2 env (UnboxedSmallWord.name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type] + | Type.Prim Type.(Word8 | Word16 as ty), RotROp -> UnboxedSmallWord.( + Func.share_code2 env (name_of_type ty "rotr") (("n", I32Type), ("by", I32Type)) [I32Type] Wasm.Values.(fun env get_n get_by -> get_n ^^ get_n ^^ lsb_adjust ty ^^ G.i (Binary (I32 I32Op.Or)) ^^ get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotr)) ^^ - sanitize_word_result ty) + sanitize_word_result ty)) | Type.Prim Type.Text, CatOp -> Text.concat env | _ -> todo "compile_binop" (Arrange.binop op) (G.i Unreachable) @@ -3760,45 +3791,19 @@ and compile_exp (env : E.t) exp = SR.Vanilla, compile_exp_vanilla env e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Popcnt)) ^^ - msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) + UnboxedSmallWord.msb_adjust (match p with | "popcnt8" -> Type.Word8 | _ -> Type.Word16) | "popcnt64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Popcnt)) - | "clz" -> - SR.UnboxedWord32, - compile_exp_as env SR.UnboxedWord32 e ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Clz)) - | "clz8" - | "clz16" -> - SR.Vanilla, - let ty = match p with | "clz8" -> Type.Word8 | _ -> Type.Word16 - in compile_exp_vanilla env e ^^ - compile_word_padding ty ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Clz)) ^^ - msb_adjust ty - | "clz64" -> - SR.UnboxedInt64, - compile_exp_as env SR.UnboxedInt64 e ^^ - G.i (Unary (Wasm.Values.I64 I64Op.Clz)) - | "ctz" -> - SR.UnboxedWord32, - compile_exp_as env SR.UnboxedWord32 e ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) - | "ctz8" - | "ctz16" -> - SR.Vanilla, - let ty = match p with | "ctz8" -> Type.Word8 | _ -> Type.Word16 - in compile_exp_vanilla env e ^^ - compile_word_padding ty ^^ - compile_unboxed_const (UnboxedSmallWord.shift_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Rotr)) ^^ - G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) ^^ - msb_adjust ty - | "ctz64" -> - SR.UnboxedInt64, - compile_exp_as env SR.UnboxedInt64 e ^^ - G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) + | "clz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Clz)) + | "clz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word8 + | "clz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.clz_kernel Type.Word16 + | "clz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Clz)) + | "ctz" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ G.i (Unary (Wasm.Values.I32 I32Op.Ctz)) + | "ctz8" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word8 + | "ctz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word16 + | "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) | "printInt" -> SR.unit, @@ -3817,32 +3822,13 @@ and compile_exp (env : E.t) exp = in match p with | "Array.init" -> compile_kernel_as SR.Vanilla (Array.init env) | "Array.tabulate" -> compile_kernel_as SR.Vanilla (Array.tabulate env) - | "shrs8" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word8 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ - sanitize_word_result Type.Word8) - | "shrs16" -> compile_kernel_as SR.Vanilla (lsb_adjust Type.Word16 ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrS)) ^^ - sanitize_word_result Type.Word16) + | "shrs8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel Type.Word8) + | "shrs16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.shrs_kernel Type.Word16) | "shrs" -> compile_kernel_as SR.UnboxedWord32 (G.i (Binary (Wasm.Values.I32 I32Op.ShrS))) | "shrs64" -> compile_kernel_as SR.UnboxedInt64 (G.i (Binary (Wasm.Values.I64 I64Op.ShrS))) - | "btst8" -> compile_kernel_as SR.Vanilla ( - let ty = Type.Word8 in - let (set_b, get_b) = new_local env "b" - in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ - compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And))) - | "btst16" -> compile_kernel_as SR.Vanilla ( - let ty = Type.Word16 in - let (set_b, get_b) = new_local env "b" - in lsb_adjust ty ^^ set_b ^^ lsb_adjust ty ^^ - compile_unboxed_one ^^ get_b ^^ clamp_shift_amount ty ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And))) - | "btst" -> compile_kernel_as SR.UnboxedWord32 ( - let (set_b, get_b) = new_local env "b" - in set_b ^^ compile_unboxed_one ^^ get_b ^^ G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And))) + | "btst8" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word8) + | "btst16" -> compile_kernel_as SR.Vanilla (UnboxedSmallWord.btst_kernel env Type.Word16) + | "btst" -> compile_kernel_as SR.UnboxedWord32 (UnboxedSmallWord.btst_kernel env Type.Word32) | "btst64" -> compile_kernel_as SR.UnboxedInt64 ( let (set_b, get_b) = new_local64 env "b" in set_b ^^ compile_const_64 1L ^^ get_b ^^ G.i (Binary (Wasm.Values.I64 I64Op.Shl)) ^^ From db2c3a7ecdd55a682c876af0ff50e113353ec6b3 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 16:33:53 +0100 Subject: [PATCH 44/76] Let Construct.callE infer the return type --- src/async.ml | 8 ++------ src/construct.ml | 13 ++++++------- src/construct.mli | 2 +- 3 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/async.ml b/src/async.ml index a5ee644e791..370982644a0 100644 --- a/src/async.ml +++ b/src/async.ml @@ -63,11 +63,7 @@ module Transform() = struct idE ("@new_async"@@no_region) new_asyncT let new_async t1 = - let call_new_async = - callE new_asyncE - [t1] - (tupE []) - (T.seq (new_async_ret unary t1)) in + let call_new_async = callE new_asyncE [t1] (tupE []) in let async = fresh_var (typ (projE call_new_async 0)) in let fullfill = fresh_var (typ (projE call_new_async 1)) in (async,fullfill),call_new_async @@ -276,7 +272,7 @@ module Transform() = struct (blockE ( letP (tupP [varP nary_async; varP nary_reply]) def :: letEta exp1' (fun v1 -> letSeq ts1 exp2' (fun vs -> - [ expD (callE v1 typs (seqE (vs@[nary_reply])) T.unit) ] + [ expD (callE v1 typs (seqE (vs@[nary_reply]))) ] ) ) ) diff --git a/src/construct.ml b/src/construct.ml index 500a4f724f4..5c9017ec4e1 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -147,10 +147,13 @@ let boolE b = S.note_eff = T.Triv} } -let callE exp1 ts exp2 t = +let callE exp1 ts exp2 = + let ret_ty = match T.promote (typ exp1) with + | T.Func (_, _, tbs, _, ts2) -> T.open_ ts (T.seq ts2) + | _ -> assert false in { it = CallE (Value.call_conv_of_typ (typ exp1), exp1, ts, exp2); at = no_region; - note = { S.note_typ = t; + note = { S.note_typ = ret_ty; S.note_eff = max_eff (eff exp1) (eff exp2) } } @@ -475,15 +478,11 @@ let forE pat exp1 exp2 = let ty1 = exp1.note.S.note_typ in let _, tfs = Type.as_obj_sub "next" ty1 in let tnxt = T.lookup_field "next" tfs in - let ty1_ret = match (T.as_func tnxt) with - | _,_,_,_,[x] -> x - | _ -> failwith "invalid return type" - in let nxt = fresh_var tnxt in letE nxt (dotE exp1 (nameN "next") tnxt) ( labelE lab Type.unit ( loopE ( - switch_optE (callE nxt [] (tupE []) ty1_ret) + switch_optE (callE nxt [] (tupE [])) (breakE lab (tupE [])) pat exp2 Type.unit ) diff --git a/src/construct.mli b/src/construct.mli index ea5bf6b5832..cd4844615b7 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -51,7 +51,7 @@ val ignoreE : exp -> exp val unitE : exp val boolE : bool -> exp -val callE : exp -> typ list -> exp -> typ -> exp +val callE : exp -> typ list -> exp -> exp val ifE : exp -> exp -> exp -> typ -> exp val dotE : exp -> name -> typ -> exp From e9d474d03863c9f6c92eff678fc1ec5b361fc2f5 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 18 Mar 2019 18:14:16 +0100 Subject: [PATCH 45/76] Limit `make parallel` jobs to number of processors otherwise my system would come to a crawl while dozends of `dvm` commands are trying to run in parallel. Also fixes the dependency on `ASC`: When invoked manually, `ASC` is not actually set (`run.sh` knows where to look). --- test/Makefile | 8 +++++--- test/quick.mk | 3 +-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/test/Makefile b/test/Makefile index 3163c044c2f..693499a6eba 100644 --- a/test/Makefile +++ b/test/Makefile @@ -3,12 +3,14 @@ all: $(MAKE) -C run $(MAKE) -C run-dfinity +MAKE_PAR := $(MAKE) --no-print-directory --load-average -j $(shell getconf _NPROCESSORS_ONLN) + quick: - $(MAKE) --no-print-directory --load-average -j -C fail quick - $(MAKE) --no-print-directory --load-average -j -C run quick + $(MAKE_PAR) -C fail quick + $(MAKE_PAR) -C run quick parallel: quick - $(MAKE) --no-print-directory --load-average -j -C run-dfinity quick + $(MAKE_PAR) -C run-dfinity quick coverage: rm -rf _coverage diff --git a/test/quick.mk b/test/quick.mk index 73fc6def5a0..130b8a1ed84 100644 --- a/test/quick.mk +++ b/test/quick.mk @@ -10,6 +10,5 @@ _out: @ mkdir -p $@ # run single test, e.g. make _out/AST-56.done -.SECONDEXPANSION: -_out/%.done: %.as $$(wildcard $(ASC)) ../run.sh | _out +_out/%.done: %.as $(wildcard ../../src/asc) ../run.sh | _out @ (../run.sh $(RUNFLAGS) $< > $@.tmp && mv $@.tmp $@) || (cat $@.tmp; rm -f $@.tmp; false) From 1e9f7138a793d08cd4825078ca2cf75607ba468b Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Tue, 19 Mar 2019 17:54:21 +0100 Subject: [PATCH 46/76] AST-32: Hashing of Nat/Int (#249) * AST-32: hashing of `Int` by defining and using `prim_hashInt` --- src/compile.ml | 11 +++++++++++ src/prelude.ml | 8 ++++++++ test/run-dfinity/ok/counter-class.wasm.stderr.ok | 16 ++++++++-------- test/run/hashes.as | 8 ++++++++ 4 files changed, 35 insertions(+), 8 deletions(-) create mode 100644 test/run/hashes.as diff --git a/src/compile.ml b/src/compile.ml index 3febadc7e38..f5f688c5f81 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -1440,6 +1440,12 @@ module Prim = struct let prim_shiftToWordN b = prim_intToWord32 ^^ UnboxedSmallWord.shift_leftWordNtoI32 b + let prim_hashInt env = + let (set_n, get_n) = new_local64 env "n" in + set_n ^^ + get_n ^^ get_n ^^ compile_const_64 32L ^^ G.i (Binary (Wasm.Values.I64 I64Op.ShrU)) ^^ + G.i (Binary (Wasm.Values.I64 I64Op.Xor)) ^^ + prim_intToWord32 end (* Prim *) module Object = struct @@ -3782,6 +3788,11 @@ and compile_exp (env : E.t) exp = compile_unboxed_const 8l ^^ G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + | "Int~hash" -> + SR.UnboxedWord32, + compile_exp_as env SR.UnboxedInt64 e ^^ + Prim.prim_hashInt env + | "popcnt" -> SR.UnboxedWord32, compile_exp_as env SR.UnboxedWord32 e ^^ diff --git a/src/prelude.ml b/src/prelude.ml index 2de8f86c42a..e343f5545f2 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -34,6 +34,10 @@ class revrange(x : Nat, y : Nat) { func printInt(x : Int) { (prim "printInt" : Int -> ()) x }; func print(x : Text) { (prim "print" : Text -> ()) x }; +// Hashing +func hashInt(n : Int) : Word32 = (prim "Int~hash" : Int -> Word32) n; + + // Conversions func natToWord8(n : Nat) : Word8 = (prim "Nat->Word8" : Nat -> Word8) n; func word8ToNat(n : Word8) : Nat = (prim "Word8->Nat" : Word8 -> Nat) n; @@ -138,6 +142,10 @@ end (* Conv *) let prim = function | "abs" -> fun v k -> k (Int (Nat.abs (as_int v))) + | "Int~hash" -> fun v k -> + let i = Word64.of_int_s (Big_int.int_of_big_int (as_int v)) in + let j = Word64.(and_ 0xFFFFFFFFL (xor (shr_u i 32L) i)) + in k (Word32 (Word32.of_int_u (Int64.to_int j))) | "Nat->Word8" -> fun v k -> let i = Big_int.int_of_big_int (as_int v) in k (Word8 (Word8.of_int_u i)) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index cb1f1836617..306445d241a 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -18,31 +18,31 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (params $68) + (params $69) () (BlockE (LetD - (TupP (VarP $66)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $68))) + (TupP (VarP $67)) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $69))) ) (CallE ( 1 -> 0) (FuncE $lambda ( 1 -> 0) - (params $65) + (params $66) () - (CallE ( 1 -> 0) (VarE $65) (VarE c)) + (CallE ( 1 -> 0) (VarE $66) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (params $67) + (params $68) () (CallE (shared 1 -> 0) - (VarE $66) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $67)) + (VarE $67) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $68)) ) ) ) diff --git a/test/run/hashes.as b/test/run/hashes.as new file mode 100644 index 00000000000..eed93e35d45 --- /dev/null +++ b/test/run/hashes.as @@ -0,0 +1,8 @@ + +assert (hashInt (10**7) == (10000000 : Word32)); +assert (hashInt 0 == (0 : Word32)); +assert (hashInt (10**18) == (2_860_824_243 : Word32)); + +assert (hashInt (-1) == (0 : Word32)); +assert (hashInt (-387) == (386 : Word32)); +assert (hashInt (-3876548352991) == (2_487_851_096 : Word32)); From 4e19dd2d4a432cc3366afb8eb21e1178b5957217 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 10:47:35 +0100 Subject: [PATCH 47/76] Pipeline: Wrap `Desugar` in `transform` so that it gets uniform treatment in terms of running `Check_ir` and dumping with `-dl`. (This works despite the different input types to `Desugar` compared to the other passes.) --- src/pipeline.ml | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/pipeline.ml b/src/pipeline.ml index 675f1064d89..74115303541 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -115,28 +115,31 @@ let check_prog infer senv name prog (* IR transforms *) -let transform_ir transform_name transform flag env prog name = - if flag then - begin - phase transform_name name; - let prog' : Ir.prog = transform env prog in - dump_ir Flags.dump_lowering prog'; - Check_ir.check_prog env transform_name prog'; - prog' - end +let transform transform_name trans env prog name = + phase transform_name name; + let prog' : Ir.prog = trans env prog in + dump_ir Flags.dump_lowering prog'; + Check_ir.check_prog env transform_name prog'; + prog' + +let transform_if transform_name trans flag env prog name = + if flag then transform transform_name trans env prog name else prog +let desugar = + transform "Desugaring" Desugar.transform + let await_lowering = - transform_ir "Await Lowering" (fun _ -> Await.transform) + transform_if "Await Lowering" (fun _ -> Await.transform) let async_lowering = - transform_ir "Async Lowering" Async.transform + transform_if "Async Lowering" Async.transform let serialization = - transform_ir "Synthesizing serialization code" Serialization.transform + transform_if "Synthesizing serialization code" Serialization.transform let tailcall_optimization = - transform_ir "Tailcall optimization" (fun _ -> Tailcall.transform) + transform_if "Tailcall optimization" (fun _ -> Tailcall.transform) let check_with parse infer senv name : check_result = match parse name with @@ -167,8 +170,7 @@ let interpret_prog (senv,denv) name prog : (Value.value * Interpret.scope) optio let vo, scope = if !Flags.interpret_ir then - let prog_ir = Desugar.transform senv prog in - Check_ir.check_prog senv "desugaring" prog_ir; + let prog_ir = desugar senv prog name in let prog_ir = await_lowering (!Flags.await_lowering) senv prog_ir name in let prog_ir = async_lowering (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in let prog_ir = serialization (!Flags.await_lowering && !Flags.async_lowering) senv prog_ir name in @@ -294,8 +296,7 @@ let compile_with check mode name : compile_result = | Ok ((prog, _t, scope), msgs) -> Diag.print_messages msgs; let prelude = Desugar.transform Typing.empty_scope prelude in - let prog = Desugar.transform initial_stat_env prog in - Check_ir.check_prog initial_stat_env "desugaring" prog; + let prog = desugar initial_stat_env prog name in let prog = await_lowering true initial_stat_env prog name in let prog = async_lowering true initial_stat_env prog name in let prog = serialization true initial_stat_env prog name in From e95843418c5fd747d9cf1d46a4fdac2f7a067a46 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 14:40:42 +0100 Subject: [PATCH 48/76] Pipeline: Use `prog_ir` IR programs --- src/pipeline.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/pipeline.ml b/src/pipeline.ml index 74115303541..acc7aa1f637 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -52,9 +52,9 @@ let dump_prog flag prog = Wasm.Sexpr.print 80 (Arrange.prog prog) else () -let dump_ir flag prog = +let dump_ir flag prog_ir = if !flag then - Wasm.Sexpr.print 80 (Arrange_ir.prog prog) + Wasm.Sexpr.print 80 (Arrange_ir.prog prog_ir) else () let parse_with mode lexer parser name : parse_result = @@ -117,10 +117,10 @@ let check_prog infer senv name prog let transform transform_name trans env prog name = phase transform_name name; - let prog' : Ir.prog = trans env prog in - dump_ir Flags.dump_lowering prog'; - Check_ir.check_prog env transform_name prog'; - prog' + let prog_ir' : Ir.prog = trans env prog in + dump_ir Flags.dump_lowering prog_ir'; + Check_ir.check_prog env transform_name prog_ir'; + prog_ir' let transform_if transform_name trans flag env prog name = if flag then transform transform_name trans env prog name @@ -295,14 +295,14 @@ let compile_with check mode name : compile_result = | Error msgs -> Error msgs | Ok ((prog, _t, scope), msgs) -> Diag.print_messages msgs; - let prelude = Desugar.transform Typing.empty_scope prelude in - let prog = desugar initial_stat_env prog name in - let prog = await_lowering true initial_stat_env prog name in - let prog = async_lowering true initial_stat_env prog name in - let prog = serialization true initial_stat_env prog name in - let prog = tailcall_optimization true initial_stat_env prog name in + let prelude_ir = Desugar.transform Typing.empty_scope prelude in + let prog_ir = desugar initial_stat_env prog name in + let prog_ir = await_lowering true initial_stat_env prog_ir name in + let prog_ir = async_lowering true initial_stat_env prog_ir name in + let prog_ir = serialization true initial_stat_env prog_ir name in + let prog_ir = tailcall_optimization true initial_stat_env prog_ir name in phase "Compiling" name; - let module_ = Compile.compile mode name prelude [prog] in + let module_ = Compile.compile mode name prelude_ir [prog_ir] in Ok module_ let compile_string mode s name = From 911912d8852dd0b4f3ab0cd67c820e915a7b5b0d Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 10:37:41 +0100 Subject: [PATCH 49/76] Rename: Count stamps per name this way, the IR dumps will hopefully vary less. (It didn't fix what I hoped it would fix, but it is still useful, I think.) --- src/con.ml | 6 +----- src/rename.ml | 9 +++++---- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/src/con.ml b/src/con.ml index cf51891d324..376cb46a92a 100644 --- a/src/con.ml +++ b/src/con.ml @@ -18,11 +18,7 @@ module Stamps = Env.Make(String) let stamps : int Stamps.t ref = ref Stamps.empty let fresh_stamp name = - let n = - match Stamps.find_opt name !stamps with - | Some n -> n - | None -> 0 - in + let n = Lib.Option.get (Stamps.find_opt name !stamps) 0 in stamps := Stamps.add name (n + 1) !stamps; n diff --git a/src/rename.ml b/src/rename.ml index cbc1f6437e6..a23a7f6eb84 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -6,12 +6,13 @@ module Renaming = Map.Make(String) (* One traversal for each syntactic category, named by that category *) -let stamp = ref 0 +module Stamps = Map.Make(String) +let stamps = ref Stamps.empty let fresh_id id = - let i' = Printf.sprintf "%s@%i" id.it (!stamp) in - stamp := !stamp+1; - i' + let n = Lib.Option.get (Stamps.find_opt id.it !stamps) 0 in + stamps := Stamps.add id.it (n + 1) !stamps; + Printf.sprintf "%s/%i" id.it n let id rho i = try {i with it = Renaming.find i.it rho} From 26e5a364e3dc7e77446791c3c7f224d8f4f287cc Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 10:55:02 +0100 Subject: [PATCH 50/76] Desugar.to_arg: Look through `AnnotP` otherwise we moving far too many simple variable patterns into separate let-bound patterns. --- src/desugar.ml | 1 + test/run-dfinity/ok/counter-class.wasm.stderr.ok | 16 ++++++++-------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index 075d0925ea7..4a2913089cf 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -224,6 +224,7 @@ and pat' = function and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) = match p.it with + | S.AnnotP (p, _) -> to_arg p | S.VarP i -> { i with note = p.note }, (fun e -> e) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 306445d241a..3a8778e1c19 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -18,31 +18,31 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (params $69) + (params $5) () (BlockE (LetD - (TupP (VarP $67)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $69))) + (TupP (VarP $3)) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $5))) ) (CallE ( 1 -> 0) (FuncE $lambda ( 1 -> 0) - (params $66) + (params $2) () - (CallE ( 1 -> 0) (VarE $66) (VarE c)) + (CallE ( 1 -> 0) (VarE $2) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (params $68) + (params $4) () (CallE (shared 1 -> 0) - (VarE $67) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $68)) + (VarE $3) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $4)) ) ) ) From 9de6812c980178fc5db87876907402687c9fff51 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 11:07:26 +0100 Subject: [PATCH 51/76] Less calls to `fresh_var` in `serialize` which produces unhelpful argument names. Instead, just append `.raw` to the variable name, this should also not shadow any existing names. --- src/serialization.ml | 11 ++++++----- test/run-dfinity/ok/counter-class.wasm.stderr.ok | 4 ++-- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/serialization.ml b/src/serialization.ml index b0184317f2b..5b32dea3738 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -33,12 +33,14 @@ module Transform() = struct primE "@deserialize" (T.Func (T.Local, T.Returns, [], [T.Serialized t], [t])) -*- e - let serialize e = let t = e.note.note_typ in primE "@serialize" (T.Func (T.Local, T.Returns, [], [t], [T.Serialized t])) -*- e + let serialized_arg a = + { it = a.it ^ "/raw"; note = T.Serialized a.note; at = a.at } + let rec map_tuple n f e = match n, e.it with | 0, _ -> e | _, TupE es -> @@ -137,13 +139,12 @@ module Transform() = struct assert (typbinds = []); assert (T.is_unit typT); let args' = t_args args in - let raw_arg_vs = List.map (fun a -> fresh_var (T.Serialized a.note)) args' in + let raw_args = List.map serialized_arg args' in let body' = blockE [letP (tupP (List.map varP (List.map exp_of_arg args'))) - (tupE (List.map deserialize raw_arg_vs)) ] + (tupE (List.map deserialize (List.map exp_of_arg raw_args))) ] (t_exp exp) in - let args' = List.map arg_of_exp raw_arg_vs in - FuncE (x, cc, [], args', T.unit, body') + FuncE (x, cc, [], raw_args, T.unit, body') end | PrimE _ | LitE _ -> exp' diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 3a8778e1c19..a3b90b4132f 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -18,12 +18,12 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (params $5) + (params $3/raw) () (BlockE (LetD (TupP (VarP $3)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $5))) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $3/raw))) ) (CallE ( 1 -> 0) From 363eced01e71045e84d2b10ee750ffc12dd09488 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 11:21:44 +0100 Subject: [PATCH 52/76] Construct.fresh_var requires a name base this way, the code is easier to read, because instead of just `$0`, we have something like `$k.0`, which gives some indication where it came from, and what it is. It also counts the stamps separately per name, so it gives less churn in diffs. --- src/async.ml | 46 +++++++++---------- src/await.ml | 17 ++++--- src/construct.ml | 34 ++++++++------ src/construct.mli | 5 +- src/desugar.ml | 10 ++-- src/serialization.ml | 6 +-- src/tailcall.ml | 9 ++-- .../ok/counter-class.wasm.stderr.ok | 16 +++---- 8 files changed, 74 insertions(+), 69 deletions(-) diff --git a/src/async.ml b/src/async.ml index 370982644a0..b98c72d6632 100644 --- a/src/async.ml +++ b/src/async.ml @@ -43,12 +43,12 @@ module Transform() = struct let replyT as_seq typ = T.Func(T.Sharable, T.Returns, [], as_seq typ, []) - let fullfillT as_seq typ = T.Func(T.Local, T.Returns, [], as_seq typ, []) + let fulfillT as_seq typ = T.Func(T.Local, T.Returns, [], as_seq typ, []) let t_async as_seq t = T.Func (T.Local, T.Returns, [], [T.Func(T.Local, T.Returns, [],as_seq t,[])], []) - let new_async_ret as_seq t = [t_async as_seq t;fullfillT as_seq t] + let new_async_ret as_seq t = [t_async as_seq t;fulfillT as_seq t] let new_asyncT = T.Func ( @@ -64,17 +64,17 @@ module Transform() = struct let new_async t1 = let call_new_async = callE new_asyncE [t1] (tupE []) in - let async = fresh_var (typ (projE call_new_async 0)) in - let fullfill = fresh_var (typ (projE call_new_async 1)) in - (async,fullfill),call_new_async + let async = fresh_var "async" (typ (projE call_new_async 0)) in + let fulfill = fresh_var "fulfill" (typ (projE call_new_async 1)) in + (async,fulfill),call_new_async let new_nary_async_reply t1 = - let (unary_async,unary_fullfill),call_new_async = new_async t1 in - let v' = fresh_var t1 in + let (unary_async,unary_fulfill),call_new_async = new_async t1 in + let v' = fresh_var "v" t1 in let ts1 = T.as_seq t1 in (* construct the n-ary async value, coercing the continuation, if necessary *) let nary_async = - let k' = fresh_var (contT t1) in + let k' = fresh_var "k" (contT t1) in match ts1 with | [t] -> unary_async @@ -82,28 +82,28 @@ module Transform() = struct let seq_of_v' = tupE (List.mapi (fun i _ -> projE v' i) ts) in k' --> (unary_async -*- ([v'] -->* (k' -*- seq_of_v'))) in - (* construct the n-ary reply message that sends a sequence of value to fullfill the async *) + (* construct the n-ary reply message that sends a sequence of value to fulfill the async *) let nary_reply = let vs,seq_of_vs = match ts1 with | [t] -> - let v = fresh_var t in + let v = fresh_var "rep" t in [v],v | ts -> - let vs = List.map fresh_var ts in + let vs = fresh_vars "rep" ts in vs, tupE vs in - vs -@>* (unary_fullfill -*- seq_of_vs) + vs -@>* (unary_fulfill -*- seq_of_vs) in - let async,reply = fresh_var (typ nary_async), fresh_var (typ nary_reply) in - (async,reply),blockE [letP (tupP [varP unary_async; varP unary_fullfill]) call_new_async] + let async,reply = fresh_var "async" (typ nary_async), fresh_var "fulfill" (typ nary_reply) in + (async,reply),blockE [letP (tupP [varP unary_async; varP unary_fulfill]) call_new_async] (tupE [nary_async; nary_reply]) let letEta e scope = match e.it with | VarE _ -> scope e (* pure, so reduce *) - | _ -> let f = fresh_var (typ e) in + | _ -> let f = fresh_var "x" (typ e) in letD f e :: (scope f) (* maybe impure; sequence *) let isAwaitableFunc exp = @@ -123,11 +123,11 @@ module Transform() = struct | [] -> (expD e)::d_of_vs [] | [t] -> - let x = fresh_var t in + let x = fresh_var "x" t in let p = varP x in (letP p e)::d_of_vs [x] | ts -> - let xs = List.map fresh_var ts in + let xs = fresh_vars "x" ts in let p = tupP (List.map varP xs) in (letP p e)::d_of_vs (xs) @@ -246,10 +246,10 @@ module Transform() = struct []) -> (* TBR, why isn't this []? *) (t_typ (T.seq ts1),t_typ contT) | t -> assert false in - let k = fresh_var contT in - let v1 = fresh_var t1 in - let post = fresh_var (T.Func(T.Sharable,T.Returns,[],[],[])) in - let u = fresh_var T.unit in + let k = fresh_var "k" contT in + let v1 = fresh_var "v" t1 in + let post = fresh_var "post" (T.Func(T.Sharable,T.Returns,[],[],[])) in + let u = fresh_var "u" T.unit in let ((nary_async,nary_reply),def) = new_nary_async_reply t1 in (blockE [letP (tupP [varP nary_async; varP nary_reply]) def; funcD k v1 (nary_reply -*- v1); @@ -323,10 +323,10 @@ module Transform() = struct let res_typ = t_typ res_typ in let reply_typ = replyT nary res_typ in let typ' = T.Tup [] in - let k = fresh_var reply_typ in + let k = fresh_var "k" reply_typ in let args' = t_args args @ [ arg_of_exp k ] in let typbinds' = t_typ_binds typbinds in - let y = fresh_var res_typ in + let y = fresh_var "y" res_typ in let exp' = match exp.it with | CallE(_, async,_,cps) -> diff --git a/src/await.ml b/src/await.ml index c6403777e73..b7aa896ab58 100644 --- a/src/await.ml +++ b/src/await.ml @@ -24,7 +24,7 @@ let letcont k scope = | ContVar k' -> scope k' (* letcont eta-contraction *) | MetaCont (typ, cont) -> let k' = fresh_cont typ in - let v = fresh_var typ in + let v = fresh_var "v" typ in blockE [funcD k' v (cont v)] (* at this point, I'm really worried about variable capture *) (scope k') @@ -39,9 +39,8 @@ let ( -@- ) k exp2 = match exp2.it with | VarE _ -> k exp2 | _ -> - let u = fresh_var typ in - letE u exp2 - (k u) + let u = fresh_var "u" typ in + letE u exp2 (k u) (* Label environments *) @@ -161,7 +160,7 @@ and unary context k unE e1 = and binary context k binE e1 e2 = match eff e1, eff e2 with | T.Triv, T.Await -> - let v1 = fresh_var (typ e1) in (* TBR *) + let v1 = fresh_var "v" (typ e1) in (* TBR *) letE v1 (t_exp context e1) (c_exp context e2 (meta (typ e2) (fun v2 -> k -@- binE v1 v2))) | T.Await, T.Await -> @@ -185,7 +184,7 @@ and nary context k naryE es = | e1 :: es -> match eff e1 with | T.Triv -> - let v1 = fresh_var (typ e1) in + let v1 = fresh_var "v" (typ e1) in letE v1 (t_exp context e1) (nary_aux (v1 :: vs) es) | T.Await -> @@ -211,12 +210,12 @@ and c_if context k e1 e2 e3 = ) and c_loop context k e1 = - let loop = fresh_var (contT T.unit) in + let loop = fresh_var "loop" (contT T.unit) in match eff e1 with | T.Triv -> assert false | T.Await -> - let v1 = fresh_var T.unit in + let v1 = fresh_var "v" T.unit in blockE [funcD loop v1 (c_exp context e1 (ContVar loop))] (loop -*- unitE) @@ -420,7 +419,7 @@ and rename_pat' pat = | WildP | LitP _ -> (PatEnv.empty, pat.it) | VarP id -> - let v = fresh_var pat.note in + let v = fresh_var "v" pat.note in (PatEnv.singleton id.it v, VarP (id_of_exp v)) | TupP pats -> diff --git a/src/construct.ml b/src/construct.ml index 5c9017ec4e1..f43ca47c724 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -42,21 +42,25 @@ let exp_of_arg a = idE {a with note = () } a.note (* Fresh id generation *) -let id_stamp = ref 0 +module Stamps = Map.Make(String) +let id_stamps = ref Stamps.empty -let fresh () = - let name = Printf.sprintf "$%i" (!id_stamp) in - id_stamp := !id_stamp + 1; - name +let fresh name_base () = + let n = Lib.Option.get (Stamps.find_opt name_base !id_stamps) 0 in + id_stamps := Stamps.add name_base (n + 1) !id_stamps; + Printf.sprintf "$%s/%i" name_base n -let fresh_id () = - let name = fresh () in +let fresh_id name_base () = + let name = fresh name_base () in name @@ no_region -let fresh_var typ = - let name = fresh () in +let fresh_var name_base typ = + let name = fresh name_base () in idE (name @@ no_region) typ +let fresh_vars name_base ts = + List.mapi (fun i t -> fresh_var (Printf.sprintf "%s%i" name_base i) t) ts + (* Patterns *) @@ -307,7 +311,7 @@ let funcE name t x exp = then [ arg_of_exp x ], exp else - let vs = List.map fresh_var arg_tys in + let vs = fresh_vars "param" arg_tys in List.map arg_of_exp vs, blockE [letD x (tupE vs)] exp in @@ -364,7 +368,7 @@ let answerT = T.unit let contT typ = T.Func (T.Local, T.Returns, [], T.as_seq typ, []) let cpsT typ = T.Func (T.Local, T.Returns, [], [contT typ], []) -let fresh_cont typ = fresh_var (contT typ) +let fresh_cont typ = fresh_var "cont" (contT typ) (* Sequence expressions *) @@ -435,7 +439,7 @@ let whileE exp1 exp2 = if e1 then { e2 } else { break l } } *) - let lab = fresh_id () in + let lab = fresh_id "done" () in labelE lab T.unit ( loopE ( ifE exp1 @@ -452,7 +456,7 @@ let loopWhileE exp1 exp2 = if e2 { } else { break l } } *) - let lab = fresh_id () in + let lab = fresh_id "done" () in labelE lab T.unit ( loopE ( thenE exp1 @@ -474,11 +478,11 @@ let forE pat exp1 exp2 = case p { e2 }; } } *) - let lab = fresh_id () in + let lab = fresh_id "done" () in let ty1 = exp1.note.S.note_typ in let _, tfs = Type.as_obj_sub "next" ty1 in let tnxt = T.lookup_field "next" tfs in - let nxt = fresh_var tnxt in + let nxt = fresh_var "nxt" tnxt in letE nxt (dotE exp1 (nameN "next") tnxt) ( labelE lab Type.unit ( loopE ( diff --git a/src/construct.mli b/src/construct.mli index cd4844615b7..9c81a16d622 100644 --- a/src/construct.mli +++ b/src/construct.mli @@ -23,8 +23,9 @@ val nextN : name (* Identifiers *) -val fresh_id : unit -> id -val fresh_var : typ -> var +val fresh_id : string -> unit -> id +val fresh_var : string -> typ -> var +val fresh_vars : string -> typ list -> var list val idE : id -> typ -> exp val id_of_exp : var -> id diff --git a/src/desugar.ml b/src/desugar.ml index 4a2913089cf..2f320ba5af1 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -137,7 +137,7 @@ and block force_unit ds = | false, S.LetD ({it = S.VarP x; _}, e) -> (extra @ List.map dec ds, idE x e.note.S.note_typ) | false, S.LetD (p', e') -> - let x = fresh_var (e'.note.S.note_typ) in + let x = fresh_var "x" (e'.note.S.note_typ) in (extra @ List.map dec prefix @ [letD x (exp e'); letP (pat p') x], x) | _, _ -> (extra @ List.map dec ds, tupE []) @@ -229,11 +229,11 @@ and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) = { i with note = p.note }, (fun e -> e) | S.WildP -> - let v = fresh_var p.note in + let v = fresh_var "param" p.note in arg_of_exp v, (fun e -> e) | _ -> - let v = fresh_var p.note in + let v = fresh_var "param" p.note in arg_of_exp v, (fun e -> blockE [letP (pat p) v] e) @@ -250,7 +250,7 @@ and to_args cc p0 : (Ir.arg list * (Ir.exp -> Ir.exp)) = let args, wrap = match n, p.it with | _, S.WildP -> - let vs = List.map fresh_var tys in + let vs = fresh_vars "param" tys in List.map arg_of_exp vs, (fun e -> e) | 1, _ -> @@ -265,7 +265,7 @@ and to_args cc p0 : (Ir.arg list * (Ir.exp -> Ir.exp)) = (a::args, fun e -> wrap1 (wrap e)) ) ps ([], (fun e -> e)) | _, _ -> - let vs = List.map fresh_var tys in + let vs = fresh_vars "param" tys in List.map arg_of_exp vs, (fun e -> blockE [letP (pat p) (tupE vs)] e) in diff --git a/src/serialization.ml b/src/serialization.ml index 5b32dea3738..8013bec6c98 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -51,9 +51,9 @@ module Transform() = struct | _, _ -> let ts = T.as_tup e.note.note_typ in assert (List.length ts = n); - let vs = List.map fresh_var ts in - blockE [letP (seqP (List.map varP vs)) e] - (tupE (List.map f vs)) + let vs = fresh_vars "tup" ts in + blockE [letP (seqP (List.map varP vs)) e] + (tupE (List.map f vs)) let rec t_typ (t:T.typ) = match t with diff --git a/src/tailcall.ml b/src/tailcall.ml index 65732af9260..b042360111a 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -83,7 +83,7 @@ and assignEs vars exp : dec list = | _, TupE es when List.length es = List.length vars -> List.map expD (List.map2 assignE vars es) | _, _ -> - let tup = fresh_var (typ exp) in + let tup = fresh_var "tup" (typ exp) in letD tup exp :: List.mapi (fun i v -> expD (assignE v (projE v i))) vars @@ -186,8 +186,8 @@ and dec' env d = ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, as_, typT, exp0);_} as funexp)) -> let env = bind env id None in begin fun env1 -> - let temps = List.map (fun a -> fresh_var (Mut a.note)) as_ in - let label = fresh_id () in + let temps = fresh_vars "temp" (List.map (fun a -> Mut a.note) as_) in + let label = fresh_id "tailcall" () in let tail_called = ref false in let env2 = { tail_pos = true; info = Some { func = id; @@ -201,7 +201,8 @@ and dec' env d = let cs = List.map (fun (tb : typ_bind) -> Con (tb.it.con, [])) tbs in if !tail_called then let ids = match typ funexp with - | Func( _, _, _, dom, _) -> List.map (fun t -> fresh_var (open_ cs t)) dom + | Func( _, _, _, dom, _) -> + fresh_vars "id" (List.map (fun t -> open_ cs t) dom) | _ -> assert false in let l_typ = Type.unit in diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index a3b90b4132f..4fe5c5240ea 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -18,31 +18,31 @@ non-closed actor: (ActorE (FuncE read (shared 1 -> 0) - (params $3/raw) + (params $k/0/raw) () (BlockE (LetD - (TupP (VarP $3)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $3/raw))) + (TupP (VarP $k/0)) + (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $k/0/raw))) ) (CallE ( 1 -> 0) (FuncE $lambda ( 1 -> 0) - (params $2) + (params $cont/0) () - (CallE ( 1 -> 0) (VarE $2) (VarE c)) + (CallE ( 1 -> 0) (VarE $cont/0) (VarE c)) ) (FuncE $lambda ( 1 -> 0) - (params $4) + (params $y/0) () (CallE (shared 1 -> 0) - (VarE $3) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $4)) + (VarE $k/0) + (CallE ( 1 -> 1) (PrimE @serialize) (VarE $y/0)) ) ) ) From 8b8d482918f8e8a8c0a26e63d04f4945f32c9808 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 12:02:11 +0100 Subject: [PATCH 53/76] Export the exports of the last actor of a program, if present MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This finally gives us a way to compile to a WebAssembly module that exports more than just a `start` function. This patch also add the ability to invoke methods from the test suite, simply by adding lines like //CALL hello as seen in `hello-world-message.as`. This can take additional arguments; they are just dumped into the shell calling `dvm`. Two regressions: * Previously we required programs to have type `()`, i.e. end with a unit expression. This is no longer true, and I simply removed the check (in `Pipeline`). One could check for “unit or actor” at some point. * Previously, the test suite would add a ``` print("Top-level code done.\n") ``` to all test cases, to better recognize when the top-level did not go through. This doesn't work any more, so I just removed it. * If we allow actor expressions in the final expression of a module, we Tests: Conclude type-equivalence and type-inclusion with () have to compile this in type inference mode, which triggers what looks like looping `avoid` (#170). We can work around this with an explicit `()` in the end. --- src/compile.ml | 26 +++++++++++++++++++ src/pipeline.ml | 4 +-- test/dvm.sh | 12 ++++++++- test/run-dfinity/hello-world-message.as | 7 +++++ test/run-dfinity/ok/AST-64.dvm-run.ok | 1 - test/run-dfinity/ok/AST-66.dvm-run.ok | 1 - .../ok/array-out-of-bounds.dvm-run.ok | 1 - .../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/chat.dvm-run.ok | 1 - test/run-dfinity/ok/chatpp.dvm-run.ok | 1 - test/run-dfinity/ok/closure-params.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 - .../ok/hello-world-message.dvm-run.ok | 2 ++ 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/large-mem.dvm-run.ok | 1 - test/run-dfinity/ok/nary-async.dvm-run.ok | 1 - .../ok/no-boxed-references.dvm-run.ok | 1 - test/run-dfinity/ok/overflow.dvm-run.ok | 1 - .../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.sh | 9 ++----- test/run/type-equivalence.as | 2 ++ test/run/type-inclusion.as | 2 ++ 40 files changed, 56 insertions(+), 42 deletions(-) create mode 100644 test/run-dfinity/hello-world-message.as delete mode 100644 test/run-dfinity/ok/AST-64.dvm-run.ok delete mode 100644 test/run-dfinity/ok/AST-66.dvm-run.ok delete mode 100644 test/run-dfinity/ok/empty-actor.dvm-run.ok create mode 100644 test/run-dfinity/ok/hello-world-message.dvm-run.ok delete mode 100644 test/run-dfinity/ok/large-mem.dvm-run.ok delete mode 100644 test/run-dfinity/ok/no-boxed-references.dvm-run.ok diff --git a/src/compile.ml b/src/compile.ml index f5f688c5f81..e5a8ee3f373 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -4276,6 +4276,11 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = Func.of_body env [] [] (fun env1 -> let rec go env = function | [] -> G.nop + (* If the last program ends with an actor, then consider this the current actor *) + | [((decls, {it = ActorE (i, ds, fs, _); _}), _flavor)] -> + let (env', code1) = compile_decs env ds in + let code2 = main_actor env' i ds fs in + code1 ^^ code2 | ((prog, _flavor) :: progs) -> let (env1, code1) = compile_prog env prog in let code2 = go env1 progs in @@ -4315,6 +4320,7 @@ and export_actor_field env ((f : Ir.field), ptr) = }); fill (FuncDec.compile_static_message env cc ptr); +(* Local actor *) and actor_lit outer_env this ds fs at = if E.mode outer_env <> DfinityMode then G.i Unreachable else @@ -4356,6 +4362,26 @@ and actor_lit outer_env this ds fs at = G.i (Call (nr (Dfinity.module_new_i outer_env))) ^^ G.i (Call (nr (Dfinity.actor_new_i outer_env))) +(* Main actor: Just return the initialization code, and export functions as needed *) +and main_actor env this ds fs = + if E.mode env <> DfinityMode then G.i Unreachable else + + (* Allocate static positions for exported functions *) + let located_ids = allocate_actor_fields env fs in + + List.iter (export_actor_field env) located_ids; + + (* Add this pointer *) + let env2 = E.add_local_deferred_vanilla env this.it Dfinity.get_self_reference in + + (* Compile the declarations *) + let (env3, decls_code) = compile_decs env2 ds in + + (* fill the static export references *) + let fill_code = fill_actor_fields env3 located_ids in + + decls_code ^^ fill_code + and actor_fake_object_idx env name = Dfinity.compile_databuf_of_bytes env (name.it) ^^ G.i (Call (nr (Dfinity.actor_export_i env))) diff --git a/src/pipeline.ml b/src/pipeline.ml index acc7aa1f637..cd920c83e51 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -153,10 +153,10 @@ let infer_prog_unit senv prog = (Typing.check_prog senv prog) let check_string senv s = check_with (parse_string s) Typing.infer_prog senv -let check_file senv n = check_with parse_file infer_prog_unit senv n +let check_file senv n = check_with parse_file Typing.infer_prog senv n let check_files senv = function | [n] -> check_file senv n - | ns -> check_with (fun _n -> parse_files ns) infer_prog_unit senv "all" + | ns -> check_with (fun _n -> parse_files ns) Typing.infer_prog senv "all" (* Interpretation *) diff --git a/test/dvm.sh b/test/dvm.sh index 3af0e0e5468..16037510060 100755 --- a/test/dvm.sh +++ b/test/dvm.sh @@ -2,7 +2,7 @@ if [ -z "$1" ] then - echo "Usage: $0 .wasm" + echo "Usage: $0 .wasm [call-script]" exit 1 fi @@ -25,3 +25,13 @@ function dvm_ () { dvm_ -q --db $DVM_TMP reset dvm_ -q --db $DVM_TMP new $1 dvm_ -q --db $DVM_TMP run $name start + +if [ -n "$2" ] +then + grep '^//CALL ' $2 | cut -c7- | + while read call + do + echo "DVM: Calling method $call" + dvm_ -q --db $DVM_TMP run $name $call + done +fi diff --git a/test/run-dfinity/hello-world-message.as b/test/run-dfinity/hello-world-message.as new file mode 100644 index 00000000000..5ea1e82608e --- /dev/null +++ b/test/run-dfinity/hello-world-message.as @@ -0,0 +1,7 @@ +actor { + hello () { + print("Hello World!\n"); + } +} + +//CALL hello diff --git a/test/run-dfinity/ok/AST-64.dvm-run.ok b/test/run-dfinity/ok/AST-64.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/AST-64.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/AST-66.dvm-run.ok b/test/run-dfinity/ok/AST-66.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/AST-66.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. 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 index e6d1727cfb6..e5307f7818f 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1,3 +1,2 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -Top-level code done. 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 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-loop-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop-while.dvm-run.ok @@ -1,2 +1 @@ -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 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-loop.dvm-run.ok +++ b/test/run-dfinity/ok/async-loop.dvm-run.ok @@ -1,2 +1 @@ -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 7e362ebf28b..9dfdfbb5120 100644 --- a/test/run-dfinity/ok/async-new-obj.dvm-run.ok +++ b/test/run-dfinity/ok/async-new-obj.dvm-run.ok @@ -1,4 +1,3 @@ -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 4adf0505adb..98f29c526f9 100644 --- a/test/run-dfinity/ok/async-obj-mut.dvm-run.ok +++ b/test/run-dfinity/ok/async-obj-mut.dvm-run.ok @@ -1,4 +1,3 @@ -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 48962aa5514..ac6ac408923 100644 --- a/test/run-dfinity/ok/async-while.dvm-run.ok +++ b/test/run-dfinity/ok/async-while.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 012345678910012345678910012345678910012345678910 diff --git a/test/run-dfinity/ok/chat.dvm-run.ok b/test/run-dfinity/ok/chat.dvm-run.ok index 14b104cf323..40f6822b967 100644 --- a/test/run-dfinity/ok/chat.dvm-run.ok +++ b/test/run-dfinity/ok/chat.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. bob received hello from bob bob received goodbye from bob alice received hello from alice diff --git a/test/run-dfinity/ok/chatpp.dvm-run.ok b/test/run-dfinity/ok/chatpp.dvm-run.ok index 308b1aac58e..42e2059e8d8 100644 --- a/test/run-dfinity/ok/chatpp.dvm-run.ok +++ b/test/run-dfinity/ok/chatpp.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. (unsubscribe 0) (unsubscribe 1) (unsubscribe 2) diff --git a/test/run-dfinity/ok/closure-params.dvm-run.ok b/test/run-dfinity/ok/closure-params.dvm-run.ok index ebca8e760cd..17b4c77d5c9 100644 --- a/test/run-dfinity/ok/closure-params.dvm-run.ok +++ b/test/run-dfinity/ok/closure-params.dvm-run.ok @@ -1,4 +1,3 @@ -Top-level code done. 1 1 3 diff --git a/test/run-dfinity/ok/counter.dvm-run.ok b/test/run-dfinity/ok/counter.dvm-run.ok index a3480e087a1..dc01807c8fe 100644 --- a/test/run-dfinity/ok/counter.dvm-run.ok +++ b/test/run-dfinity/ok/counter.dvm-run.ok @@ -1,2 +1 @@ -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 9884ed33c7f..9a40c228b71 100644 --- a/test/run-dfinity/ok/data-params.dvm-run.ok +++ b/test/run-dfinity/ok/data-params.dvm-run.ok @@ -1,4 +1,3 @@ -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 deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/empty-actor.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -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 6332b8b5e87..52bd8e43afb 100644 --- a/test/run-dfinity/ok/fac.dvm-run.ok +++ b/test/run-dfinity/ok/fac.dvm-run.ok @@ -1 +1 @@ -120Top-level code done. +120 diff --git a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok index c8ab234ed8e..4c1b1bd6651 100644 --- a/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok +++ b/test/run-dfinity/ok/flatten-awaitables.dvm-run.ok @@ -1,4 +1,3 @@ -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 1cfb8645d12..6d96c93ceef 100644 --- a/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok +++ b/test/run-dfinity/ok/generic-tail-rec.dvm-run.ok @@ -2,4 +2,3 @@ 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 8d9d4c9eb23..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-concat-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-concat-world.dvm-run.ok @@ -1,2 +1 @@ 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 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world-async.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-async.dvm-run.ok @@ -1,2 +1 @@ -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 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world-await.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world-await.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. Hello World! diff --git a/test/run-dfinity/ok/hello-world-message.dvm-run.ok b/test/run-dfinity/ok/hello-world-message.dvm-run.ok new file mode 100644 index 00000000000..f01f4492e8f --- /dev/null +++ b/test/run-dfinity/ok/hello-world-message.dvm-run.ok @@ -0,0 +1,2 @@ +DVM: Calling method hello +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 8d9d4c9eb23..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world.dvm-run.ok @@ -1,2 +1 @@ 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 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world2.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world2.dvm-run.ok @@ -1,2 +1 @@ -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 9c393e21691..980a0d5f19a 100644 --- a/test/run-dfinity/ok/hello-world3.dvm-run.ok +++ b/test/run-dfinity/ok/hello-world3.dvm-run.ok @@ -1,2 +1 @@ -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 a3480e087a1..dc01807c8fe 100644 --- a/test/run-dfinity/ok/indirect-counter.dvm-run.ok +++ b/test/run-dfinity/ok/indirect-counter.dvm-run.ok @@ -1,2 +1 @@ -Top-level code done. 2344 diff --git a/test/run-dfinity/ok/large-mem.dvm-run.ok b/test/run-dfinity/ok/large-mem.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/large-mem.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index b4dbdd9a6ee..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,3 @@ -Top-level code done. 0_0 1_0 2_0 diff --git a/test/run-dfinity/ok/no-boxed-references.dvm-run.ok b/test/run-dfinity/ok/no-boxed-references.dvm-run.ok deleted file mode 100644 index 3b7e66c4381..00000000000 --- a/test/run-dfinity/ok/no-boxed-references.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -Top-level code done. diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok index 5db4566da42..8ca337c71a9 100644 --- a/test/run-dfinity/ok/overflow.dvm-run.ok +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -1,6 +1,5 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -Top-level code done. This is reachable. 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 9a57656f7a1..8650e0ef3bf 100644 --- a/test/run-dfinity/ok/reference-params.dvm-run.ok +++ b/test/run-dfinity/ok/reference-params.dvm-run.ok @@ -1,4 +1,3 @@ -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 d58ee786174..acb397e19f2 100644 --- a/test/run-dfinity/ok/selftail.dvm-run.ok +++ b/test/run-dfinity/ok/selftail.dvm-run.ok @@ -1,3 +1,2 @@ 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 a0ef19cc3e9..025c12b0e9a 100644 --- a/test/run-dfinity/ok/tailpositions.dvm-run.ok +++ b/test/run-dfinity/ok/tailpositions.dvm-run.ok @@ -5,4 +5,3 @@ 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 911d4f5b36f..d81cc0710eb 100644 --- a/test/run-dfinity/ok/the-answer.dvm-run.ok +++ b/test/run-dfinity/ok/the-answer.dvm-run.ok @@ -1 +1 @@ -42Top-level code done. +42 diff --git a/test/run.sh b/test/run.sh index cebe0283ca6..e922b3bc660 100755 --- a/test/run.sh +++ b/test/run.sh @@ -125,12 +125,7 @@ do # Compile $ECHO -n " [wasm]" - 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 + $ASC $ASC_FLAGS $EXTRA_ASC_FLAGS --map -c $base.as -o $out/$base.wasm 2> $out/$base.wasm.stderr normalize $out/$base.wasm.stderr diff_files="$diff_files $base.wasm.stderr" @@ -154,7 +149,7 @@ do if [ $DFINITY = 'yes' ] then $ECHO -n " [dvm]" - $DVM_WRAPPER $out/$base.wasm > $out/$base.dvm-run 2>&1 + $DVM_WRAPPER $out/$base.wasm $base.as > $out/$base.dvm-run 2>&1 normalize $out/$base.dvm-run diff_files="$diff_files $base.dvm-run" else diff --git a/test/run/type-equivalence.as b/test/run/type-equivalence.as index b3256842fe9..0610b069f84 100644 --- a/test/run/type-equivalence.as +++ b/test/run/type-equivalence.as @@ -224,3 +224,5 @@ func f2(x : A2) : A2 = x : B2; func g1(x : A1) : A1 = x : C1; func g2(x : A2) : A2 = x : C2; }; + +() diff --git a/test/run/type-inclusion.as b/test/run/type-inclusion.as index 44b8e818c8f..14217da15eb 100644 --- a/test/run/type-inclusion.as +++ b/test/run/type-inclusion.as @@ -237,3 +237,5 @@ func f2(x : A2) : B2 = x; func g1(x : A1) : C1 = x; func g2(x : A2) : C2 = x; }; + +() From 356be2af89bde09c1b160543ec160a8076414cda Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 16:34:23 +0100 Subject: [PATCH 54/76] Give the `(de)serialize` prim a polymorphic type this is more a syntactic trick to have a spot in the AST where the concrete type `t` is stored. --- src/compile.ml | 12 +++++++----- src/serialization.ml | 19 ++++++++++++++----- .../ok/counter-class.wasm.stderr.ok | 11 +++++++++-- 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index e5a8ee3f373..241d74a73b3 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2677,7 +2677,7 @@ module Serialization = struct ) ) - let serialize env = + let serialize env t = if E.mode env <> DfinityMode then Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) else Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env get_x -> @@ -2764,7 +2764,7 @@ module Serialization = struct G.i (Call (nr (Dfinity.elem_externalize_i env))) ) - let deserialize env = + let deserialize env t = Func.share_code1 env "deserialize" ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> let (set_databuf, get_databuf) = new_local env "databuf" in let (set_start, get_start) = new_local env "start" in @@ -3704,19 +3704,21 @@ and compile_exp (env : E.t) exp = compile_exp_as env SR.UnboxedReference e ^^ actor_fake_object_idx env {name with it = n} (* We only allow prims of certain shapes, as they occur in the prelude *) - | CallE (_, ({ it = PrimE p; _} as pe), _, e) -> + | CallE (_, ({ it = PrimE p; _} as pe), typ_args, e) -> begin (* First check for all unary prims. *) match p with | "@serialize" -> SR.UnboxedReference, + let t = match typ_args with [t] -> t | _ -> assert false in compile_exp_vanilla env e ^^ - Serialization.serialize env + Serialization.serialize env t | "@deserialize" -> SR.Vanilla, + let t = match typ_args with [t] -> t | _ -> assert false in compile_exp_as env SR.UnboxedReference e ^^ - Serialization.deserialize env + Serialization.deserialize env t | "abs" -> SR.Vanilla, diff --git a/src/serialization.ml b/src/serialization.ml index 8013bec6c98..93bdca1fdbb 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -27,16 +27,25 @@ module Transform() = struct let con_renaming = ref ConRenaming.empty - (* The type of a serialized argument *) + (* The primitive serialization functions *) + let deserialize_prim = + let open Type in + let var : var = "A" in + primE "@deserialize" + (Func (Local, Returns, [{var; bound = Shared}], [Serialized (Var (var, 0))], [(Var (var, 0))])) + let serialize_prim = + let open Type in + let var : var = "A" in + primE "@serialize" + (Func (Local, Returns, [{var; bound = Shared}], [Var (var, 0)], [Serialized (Var (var, 0))])) + let deserialize e = let t = T.as_serialized e.note.note_typ in - primE "@deserialize" (T.Func (T.Local, T.Returns, [], [T.Serialized t], [t])) - -*- e + callE deserialize_prim [t] e let serialize e = let t = e.note.note_typ in - primE "@serialize" (T.Func (T.Local, T.Returns, [], [t], [T.Serialized t])) - -*- e + callE serialize_prim [t] e let serialized_arg a = { it = a.it ^ "/raw"; note = T.Serialized a.note; at = a.at } diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 4fe5c5240ea..024d434dd75 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -23,7 +23,14 @@ non-closed actor: (ActorE (BlockE (LetD (TupP (VarP $k/0)) - (TupE (CallE ( 1 -> 1) (PrimE @deserialize) (VarE $k/0/raw))) + (TupE + (CallE + ( 1 -> 1) + (PrimE @deserialize) + shared (serialized Int) -> () + (VarE $k/0/raw) + ) + ) ) (CallE ( 1 -> 0) @@ -42,7 +49,7 @@ non-closed actor: (ActorE (CallE (shared 1 -> 0) (VarE $k/0) - (CallE ( 1 -> 1) (PrimE @serialize) (VarE $y/0)) + (CallE ( 1 -> 1) (PrimE @serialize) Int (VarE $y/0)) ) ) ) From 165899d97f4ad02bbf6a650e8e579564fda2ab75 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 14 Mar 2019 18:03:41 +0100 Subject: [PATCH 55/76] First stab at type driven serialization so far with a very naive format that does not even support subtyping (but hey, all our tests pass!) The changed test is fixed by #250. --- src/compile.ml | 806 +++++++++--------- src/serialization.ml | 5 +- test/run-dfinity/no-boxed-references.as | 4 +- test/run-dfinity/ok/nary-async.dvm-run.ok | 7 +- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 3 + 5 files changed, 432 insertions(+), 393 deletions(-) create mode 100644 test/run-dfinity/ok/nary-async.wasm.stderr.ok diff --git a/src/compile.ml b/src/compile.ml index 241d74a73b3..04365bdf847 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -407,7 +407,7 @@ let compile_op_const op i = compile_unboxed_const i ^^ G.i (Binary (Wasm.Values.I32 op)) let compile_add_const = compile_op_const I32Op.Add -let compile_sub_const = compile_op_const I32Op.Sub +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 @@ -495,7 +495,7 @@ module Func = struct G.i (Call (nr (E.built_in env name))) (* Shorthands for various arities *) - let share_code0 env name retty mk_body = + let _share_code0 env name retty mk_body = share_code env name [] retty (fun env -> mk_body env) let share_code1 env name p1 retty mk_body = share_code env name [p1] retty (fun env -> mk_body env @@ -535,11 +535,11 @@ module Heap = struct let set_heap_ptr = G.i (GlobalSet (nr heap_global)) let get_skewed_heap_ptr = get_heap_ptr ^^ compile_add_const ptr_skew - (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) + (* Page allocation. Ensures that the memory up to the given unskewed pointer is allocated. *) let grow_memory env = - Func.share_code0 env "grow_memory" [] (fun env -> + Func.share_code1 env "grow_memory" ("ptr", I32Type) [] (fun env get_ptr -> let (set_pages_needed, get_pages_needed) = new_local env "pages_needed" in - get_heap_ptr ^^ compile_divU_const page_size ^^ + get_ptr ^^ compile_divU_const page_size ^^ compile_add_const 1l ^^ G.i MemorySize ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ @@ -572,7 +572,7 @@ module Heap = struct get_n ^^ compile_mul_const word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_heap_ptr ^^ - grow_memory env + get_heap_ptr ^^ grow_memory env ) let dyn_alloc_bytes env = @@ -2246,7 +2246,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_add_const ElemHeap.table_end ^^ Heap.set_heap_ptr ^^ - Heap.grow_memory env ^^ + Heap.get_heap_ptr ^^ Heap.grow_memory env ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ @@ -2413,438 +2413,476 @@ end (* HeapTraversal *) module Serialization = struct (* The serialization strategy is as follows: - * We remember the current heap pointer and reference table pointer - * We deeply and compactly copy the arguments into the space beyond the heap - pointer. - * Special handling for closures: These are turned into funcrefs. - * We traverse this space and make all pointers relative to the beginning of - the space. Same for indices into the reference table. - * We externalize all that new data space into a databuf, and add it to the - reference table - * We externalize all that new table space into a elembuf + * We traverse the data to calculate the size needed for the data buffer and the + reference buffer. + * We remember the current heap pointer, and use the space after as scratch space. + * The scratch space is separated into two region: + One for references, and one for raw data. + * We traverse the data, in a type-driven way, and copy it to the scratch space. + We thread through pointers to the current free space of the two scratch spaces. + This is type driven, and we use the `share_code` machinery and names that + properly encode the type to resolve loops in a convenient way. + * We externalize all that new data space into a databuf, and add this reference + to the reference space. + * We externalize the reference space into a elembuf * We reset the heap pointer and table pointer, to garbage collect the scratch space. - TODO: Cycles are not detected yet. - - We separate code for copying and the code for pointer adjustment because - the latter can be used again in the deserialization code. + TODO: Cycles are not detected. The deserialization is analogous: - * We internalize the elembuf into the table, bumping the table reference - pointer. - * The last entry of the table is the dataref from above. Since we don't - need it after this, we decrement the table reference pointer by one. - * We internalize this databuf into the heap space, bumping the heap - pointer. - * We traverse this space and adjust all pointers. - Same for indices into the reference table. + * We allocate some scratch space, and internalize the elembuf into it. + * We allocate some more scratch space, and internalize the databuf into it. + * We parse the data, in a type-driven way, using normal construction and + allocation. + * At the end, the scratch space is a hole in the heap, and will be reclaimed + by the next GC. *) - let rec serialize_go env = - Func.share_code1 env "serialize_go" ("x", I32Type) [I32Type] (fun env get_x -> - let (set_copy, get_copy) = new_local env "x'" in + (* A type identifier *) - let purely_data n = - Heap.alloc env n ^^ - set_copy ^^ + (* + This needs to map types to some identifier with the following properties: + - Its domain are normalized types that do not mention any type parameters + - It needs to be injective wrt. type equality + - It needs to terminate, even for recursive types + - It may fail upon type parameters (i.e. no polymorphism) + We can use string_of_typ here for now, it seems. + *) + let typ_id : Type.typ -> string = Type.string_of_typ - get_x ^^ - get_copy ^^ - compile_unboxed_const n ^^ - Heap.memcpy_words_skewed env ^^ - get_copy in + (* Returns data (in bytes) and reference buffer size (in entries) needed *) + let rec buffer_size env t = + let open Type in + let t = normalize t in + let name = "@buffer_size<" ^ typ_id t ^ ">" in + Func.share_code1 env name ("x", I32Type) [I32Type; I32Type] + (fun env get_x -> - get_x ^^ - BitTagged.if_unboxed env (ValBlockType (Some I32Type)) - ( get_x ) - ( get_x ^^ - Tagged.branch env (ValBlockType (Some I32Type)) - [ Tagged.Int, purely_data 3l - ; Tagged.SmallWord, purely_data 2l - ; Tagged.Reference, purely_data 2l - ; Tagged.Some, - Opt.inject env ( - get_x ^^ Opt.project ^^ - serialize_go env - ) - ; Tagged.ObjInd, - Tagged.obj env Tagged.ObjInd [ - get_x ^^ Heap.load_field 1l ^^ - serialize_go env - ] - ; Tagged.Array, - begin - let (set_len, get_len) = new_local env "len" in - get_x ^^ - Heap.load_field Array.len_field ^^ - set_len ^^ - - get_len ^^ - compile_add_const Array.header_size ^^ - Heap.dyn_alloc_words env ^^ - set_copy ^^ - - (* Copy header *) - get_x ^^ - get_copy ^^ - compile_unboxed_const Array.header_size ^^ - Heap.memcpy_words_skewed env ^^ - - (* Copy fields *) - get_len ^^ - from_0_to_n env (fun get_i -> - get_copy ^^ - get_i ^^ - Array.idx env ^^ + (* Some combinators for writing values *) + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_ref_size, get_ref_size) = new_local env "ref_size" in + compile_unboxed_const 0l ^^ set_data_size ^^ + compile_unboxed_const 0l ^^ set_ref_size ^^ - get_x ^^ - get_i ^^ - Array.idx env ^^ - load_ptr ^^ - serialize_go env ^^ - store_ptr - ) ^^ - get_copy - end - ; 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 ^^ - compile_divU_const Heap.word_size ^^ - compile_add_const Text.header_size ^^ - set_len ^^ - - get_len ^^ - Heap.dyn_alloc_words env ^^ - set_copy ^^ - - (* Copy header and data *) - get_x ^^ - get_copy ^^ - get_len ^^ - Heap.memcpy_words_skewed env ^^ - - get_copy - end - ; Tagged.Object, - begin - let (set_len, get_len) = new_local env "len" in - get_x ^^ - Heap.load_field Object.size_field ^^ - set_len ^^ - - get_len ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - Heap.dyn_alloc_words env ^^ - set_copy ^^ - - (* Copy header *) - get_x ^^ - get_copy ^^ - compile_unboxed_const Object.header_size ^^ - Heap.memcpy_words_skewed env ^^ - - (* Copy fields *) - get_len ^^ - from_0_to_n env (fun get_i -> - (* Copy hash *) - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_copy ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + let inc_data_size code = + get_data_size ^^ code ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_data_size + in + let inc_ref_size i = + get_ref_size ^^ compile_add_const i ^^ set_ref_size + in - 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 I32Op.Add)) ^^ + let size env t = + buffer_size env t ^^ + get_ref_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ref_size ^^ + get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_data_size + in - load_ptr ^^ - store_ptr ^^ + (* Now the actual type-dependent code *) + begin match t with + | Prim (Nat|Int|Word64) -> inc_data_size (compile_unboxed_const 8l) (* 64 bit *) + | Prim Word8 -> inc_data_size (compile_unboxed_const 1l) + | Prim Word16 -> inc_data_size (compile_unboxed_const 2l) + | Prim Word32 -> inc_data_size (compile_unboxed_const 4l) + | Prim Bool -> inc_data_size (compile_unboxed_const 1l) + | Tup ts -> + G.concat_mapi (fun i t -> + get_x ^^ Tuple.load_n (Int32.of_int i) ^^ + size env t + ) ts + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + G.concat_mapi (fun i f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + get_x ^^ Object.load_idx env t n ^^ + size env f.typ + ) fs + | Array t -> + inc_data_size (compile_unboxed_const Heap.word_size) ^^ (* 32 bit length field *) + get_x ^^ + Heap.load_field Array.len_field ^^ + from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ load_ptr ^^ + size env t + ) + | Prim Text -> + inc_data_size ( + compile_unboxed_const Heap.word_size ^^ (* 32 bit length field *) + get_x ^^ Heap.load_field Text.len_field ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) + ) + | (Prim Null | Shared) -> G.nop + | Opt t -> + inc_data_size (compile_unboxed_const 1l) ^^ (* one byte tag *) + get_x ^^ + Opt.null ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop + ( get_x ^^ Opt.project ^^ size env t) + | (Func _ | Obj (Actor, _)) -> + inc_data_size (compile_unboxed_const Heap.word_size) ^^ + inc_ref_size 1l + | _ -> todo "buffer_size" (Arrange_ir.typ t) G.nop + end ^^ + get_data_size ^^ + get_ref_size + ) - (* Copy data *) + (* Copies x to the data_buffer, storing references after ref_count entries in ref_base *) + let rec serialize_go env t = + let open Type in + let t = normalize t in + let name = "@serialize_go<" ^ typ_id t ^ ">" in + Func.share_code4 env name (("x", I32Type), ("data_buffer", I32Type), ("ref_base", I32Type), ("ref_count" , I32Type)) [I32Type; I32Type] + (fun env get_x get_data_buf get_ref_base get_ref_count -> + let set_data_buf = G.i (LocalSet (nr 1l)) in + let set_ref_count = G.i (LocalSet (nr 3l)) in + + (* Some combinators for writing values *) + + let advance_data_buf = + get_data_buf ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_data_buf in + let allocate_ref = + get_ref_count ^^ + get_ref_count ^^ compile_add_const 1l ^^ set_ref_count in + + let write_word code = + get_data_buf ^^ code ^^ store_unskewed_ptr ^^ + compile_unboxed_const Heap.word_size ^^ advance_data_buf + in - get_i ^^ - compile_mul_const 2l ^^ - compile_add_const Object.header_size ^^ - compile_mul_const Heap.word_size ^^ - get_copy ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const Heap.word_size ^^ + let write_byte code = + get_data_buf ^^ code ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + in - 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 I32Op.Add)) ^^ - compile_add_const Heap.word_size ^^ - - load_ptr ^^ - serialize_go env ^^ - store_ptr - ) ^^ - get_copy - end - ] - ) - ) + let write env t = + get_data_buf ^^ + get_ref_base ^^ + get_ref_count ^^ + serialize_go env t ^^ + set_ref_count ^^ + set_data_buf + in - let shift_pointer_at env = - Func.share_code2 env "shift_pointer_at" (("loc", I32Type), ("ptr_offset", I32Type)) [] (fun env get_loc get_ptr_offset -> - let (set_ptr, get_ptr) = new_local env "ptr" in - get_loc ^^ - load_ptr ^^ - set_ptr ^^ - get_ptr ^^ - BitTagged.if_unboxed env (ValBlockType None) - (* nothing to do *) - ( G.nop ) - ( get_loc ^^ - get_ptr ^^ - get_ptr_offset ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - store_ptr + (* Now the actual serialization *) + + begin match t with + | Prim (Nat | Int | Word64) -> + get_data_buf ^^ + get_x ^^ BoxedInt.unbox env ^^ + G.i (Store {ty = I64Type; align = 0; offset = 0l; sz = None}) ^^ + compile_unboxed_const 8l ^^ advance_data_buf + | Prim Word32 -> + get_data_buf ^^ + get_x ^^ BoxedSmallWord.unbox env ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = None}) ^^ + compile_unboxed_const 4l ^^ advance_data_buf + | Prim Word16 -> + get_data_buf ^^ + get_x ^^ UnboxedSmallWord.lsb_adjust Word16 ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack16}) ^^ + compile_unboxed_const 2l ^^ advance_data_buf + | Prim Word8 -> + get_data_buf ^^ + get_x ^^ UnboxedSmallWord.lsb_adjust Word16 ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Prim Bool -> + get_data_buf ^^ + get_x ^^ + G.i (Store {ty = I32Type; align = 0; offset = 0l; sz = Some Wasm.Memory.Pack8}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Tup ts -> + G.concat_mapi (fun i t -> + get_x ^^ Tuple.load_n (Int32.of_int i) ^^ + write env t + ) ts + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + G.concat_mapi (fun i f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + get_x ^^ Object.load_idx env t n ^^ + write env f.typ + ) fs + | Array t -> + write_word (get_x ^^ Heap.load_field Array.len_field) ^^ + get_x ^^ Heap.load_field Array.len_field ^^ + from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ load_ptr ^^ + write env t ) + | (Prim Null | Shared) -> G.nop + | Opt t -> + get_x ^^ + Opt.null ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) + ( write_byte (compile_unboxed_const 0l) ) + ( write_byte (compile_unboxed_const 1l) ^^ get_x ^^ Opt.project ^^ write env t ) + | Prim Text -> + let (set_len, get_len) = new_local env "len" in + get_x ^^ Heap.load_field Text.len_field ^^ + compile_add_const Heap.word_size ^^ + set_len ^^ + get_x ^^ compile_add_const (Int32.mul Tagged.header_size Heap.word_size) ^^ + compile_add_const ptr_unskew ^^ + get_data_buf ^^ + get_len ^^ + Heap.memcpy env ^^ + get_len ^^ advance_data_buf + | (Func _ | Obj (Actor, _)) -> + get_ref_base ^^ + get_ref_count ^^ compile_mul_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + get_x ^^ Dfinity.unbox_reference env ^^ + store_unskewed_ptr ^^ + write_word allocate_ref + | _ -> todo "serialize" (Arrange_ir.typ t) G.nop + end ^^ + get_data_buf ^^ + get_ref_count ) - let shift_pointers env = - Func.share_code3 env "shift_pointers" (("start", I32Type), ("to", I32Type), ("ptr_offset", I32Type)) [] (fun env get_start get_to get_ptr_offset -> - HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> - HeapTraversal.for_each_pointer env get_x (fun get_ptr_loc -> - get_ptr_loc ^^ - get_ptr_offset ^^ - shift_pointer_at env - ) - ) - ) + let rec deserialize_go env t = + let open Type in + let t = normalize t in + let name = "@deserialize_go<" ^ typ_id t ^ ">" in + Func.share_code2 env name (("data_buffer", I32Type), ("ref_base", I32Type)) [I32Type; I32Type] + (fun env get_data_buf get_ref_base -> + let set_data_buf = G.i (LocalSet (nr 0l)) in + + (* Some combinators for reading values *) + let advance_data_buf = + get_data_buf ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_data_buf + in - let extract_references env = - Func.share_code3 env "extract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [I32Type] (fun env get_start get_to get_tbl_area -> - let (set_i, get_i) = new_local env "i" in + let read_byte = + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + in + + let read_word = + get_data_buf ^^ load_unskewed_ptr ^^ + compile_unboxed_const Heap.word_size ^^ advance_data_buf + in - compile_unboxed_zero ^^ set_i ^^ + let read env t = + get_data_buf ^^ + get_ref_base ^^ + deserialize_go env t ^^ + set_data_buf + in - HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> + (* Now the actual deserialization *) + begin match t with + | Prim (Nat | Int | Word64) -> + get_data_buf ^^ + G.i (Load {ty = I64Type; align = 2; offset = 0l; sz = None}) ^^ + BoxedInt.box env ^^ + compile_unboxed_const 8l ^^ advance_data_buf (* 64 bit *) + | Prim Word32 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = None}) ^^ + BoxedSmallWord.box env ^^ + compile_unboxed_const 4l ^^ advance_data_buf + | Prim Word16 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack16, Wasm.Memory.ZX)}) ^^ + UnboxedSmallWord.msb_adjust Word16 ^^ + compile_unboxed_const 2l ^^ advance_data_buf + | Prim Word8 -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + UnboxedSmallWord.msb_adjust Word8 ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Prim Bool -> + get_data_buf ^^ + G.i (Load {ty = I32Type; align = 0; offset = 0l; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) ^^ + compile_unboxed_const 1l ^^ advance_data_buf + | Tup ts -> + G.concat_map (fun t -> read env t) ts ^^ + Tuple.from_stack env (List.length ts) + | Obj (Object Sharable, fs) -> + (* Disregarding all subtyping, and assuming sorted fields, we can just + treat this like a tuple *) + Object.lit_raw env (List.map (fun f -> + let n = { it = Name f.Type.lab; at = no_region; note = () } in + n, fun env -> read env f.typ + ) fs) + | Array t -> + let (set_len, get_len) = new_local env "len" in + let (set_x, get_x) = new_local env "x" in + + read_word ^^ set_len ^^ + get_len ^^ Array.alloc env ^^ set_x ^^ + get_len ^^ from_0_to_n env (fun get_i -> + get_x ^^ get_i ^^ Array.idx env ^^ + read env t ^^ store_ptr + ) ^^ + get_x + | (Prim Null | Shared) -> Opt.null + | Opt t -> + read_byte ^^ + compile_unboxed_const 0l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType (Some I32Type)) + ( Opt.null ) + ( Opt.inject env (read env t) ) + | Prim Text -> + let (set_len, get_len) = new_local env "len" in + let (set_x, get_x) = new_local env "x" in + read_word ^^ set_len ^^ + + (* Refactor into Text.alloc *) + get_len ^^ Text.alloc env ^^ set_x ^^ + + get_data_buf ^^ get_x ^^ - Tagged.branch_default env (ValBlockType None) G.nop - [ Tagged.Reference, - (* Adjust reference *) - get_tbl_area ^^ - get_i ^^ compile_mul_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - get_x ^^ - Dfinity.unbox_reference env ^^ - store_ptr ^^ - - get_x ^^ - get_i ^^ - Heap.store_field 1l ^^ + compile_add_const Int32.(add ptr_unskew (mul Heap.word_size Text.header_size)) ^^ + get_len ^^ + Heap.memcpy env ^^ - get_i ^^ - compile_add_const 1l ^^ - set_i - ] - ) ^^ - get_i - ) + get_len ^^ advance_data_buf ^^ - let intract_references env = - Func.share_code3 env "intract_references" (("start", I32Type), ("to", I32Type), ("tbl_area", I32Type)) [] (fun env get_start get_to get_tbl_area -> - HeapTraversal.walk_heap_from_to env get_start get_to (fun get_x -> - get_x ^^ - Tagged.branch_default env (ValBlockType None) G.nop - [ Tagged.Reference, - get_x ^^ - (* Adjust reference *) - get_x ^^ - Heap.load_field 1l ^^ - compile_mul_const Heap.word_size ^^ - get_tbl_area ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - load_ptr ^^ - ElemHeap.remember_reference env ^^ - Heap.store_field 1l - ] - ) + get_x + | (Func _ | Obj (Actor, _)) -> + get_ref_base ^^ + read_word ^^ compile_mul_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + load_unskewed_ptr ^^ + Dfinity.box_reference env + | _ -> todo "deserialize" (Arrange_ir.typ t) (G.i Unreachable) + end ^^ + get_data_buf ) let serialize env t = + let name = "@serialize<" ^ typ_id t ^ ">" in if E.mode env <> DfinityMode - then Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) - else Func.share_code1 env "serialize" ("x", I32Type) [I32Type] (fun env get_x -> - let (set_start, get_start) = new_local env "old_heap" in - let (set_start_skewed, get_start_skewed) = new_local env "old_heap_skewed" in - let (set_end, get_end) = new_local env "end" in - let (set_end_skewed, get_end_skewed) = new_local env "end_skewed" in - let (set_tbl_size, get_tbl_size) = new_local env "tbl_size" in - let (set_databuf, get_databuf) = new_local env "databuf" in + then Func.share_code1 env name ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) + else Func.share_code1 env name ("x", I32Type) [I32Type] (fun env get_x -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in - (* Remember where we start to copy to *) - Heap.get_skewed_heap_ptr ^^ - set_start_skewed ^^ - Heap.get_heap_ptr ^^ - set_start ^^ - - (* Copy data *) + (* Get object sizes *) get_x ^^ - 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. - *) - ( Heap.alloc env 1l ^^ - get_x ^^ - store_ptr ^^ + buffer_size env t ^^ + set_refs_size ^^ + set_data_size ^^ - (* Remember the end *) - Heap.get_skewed_heap_ptr ^^ - set_end_skewed ^^ - Heap.get_heap_ptr ^^ - set_end ^^ + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" in - (* Empty table of references *) - compile_unboxed_zero ^^ set_tbl_size - ) - (* We have real data on the heap. Copy. *) - ( get_x ^^ - serialize_go env ^^ - G.i Drop ^^ - - (* Remember the end *) - Heap.get_skewed_heap_ptr ^^ - set_end_skewed ^^ - Heap.get_heap_ptr ^^ - set_end ^^ - - (* Adjust pointers *) - get_start_skewed ^^ - get_end_skewed ^^ - compile_unboxed_zero ^^ get_start ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - shift_pointers env ^^ - - (* Extract references, and remember how many there were *) - get_start_skewed ^^ - get_end_skewed ^^ - get_end_skewed ^^ - extract_references env ^^ - set_tbl_size - ) ^^ - - (* Create databuf *) - get_start ^^ - get_end_skewed ^^ get_start_skewed ^^ G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ - G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ - set_databuf ^^ + Heap.get_heap_ptr ^^ + set_data_start ^^ - (* Append this reference at the end of the extracted references *) - get_end_skewed ^^ - get_tbl_size ^^ compile_mul_const Heap.word_size ^^ + Heap.get_heap_ptr ^^ + get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - get_databuf ^^ - store_ptr ^^ - (* And bump table end *) - get_tbl_size ^^ compile_add_const 1l ^^ set_tbl_size ^^ + set_refs_start ^^ - (* Reset the heap counter, to free some space *) - get_start ^^ - Heap.set_heap_ptr ^^ + (* Allocate space, if needed *) + get_refs_start ^^ + get_refs_size ^^ + compile_divU_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.grow_memory env ^^ + (* Serialize x into the buffer *) + get_x ^^ + get_data_start ^^ + get_refs_start ^^ + compile_unboxed_const 1l ^^ (* Leave space for databuf *) + serialize_go env t ^^ + + (* Sanity check: Did we fill exactly the buffer *) + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + + get_data_start ^^ get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + + (* Create databuf, and store at beginning of ref area *) + get_refs_start ^^ + get_data_start ^^ + get_data_size ^^ + G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ + store_unskewed_ptr ^^ + (* Finally, create elembuf *) - get_end ^^ - get_tbl_size ^^ + get_refs_start ^^ + get_refs_size ^^ compile_add_const 1l ^^ G.i (Call (nr (Dfinity.elem_externalize_i env))) ) let deserialize env t = - Func.share_code1 env "deserialize" ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> + let name = "@deserialize<" ^ typ_id t ^ ">" in + Func.share_code1 env name ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" 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 *) - Heap.get_skewed_heap_ptr ^^ - set_start ^^ - get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ - set_tbl_size ^^ - - (* Get scratch space (one word) *) - Heap.alloc env 1l ^^ G.i Drop ^^ - get_start ^^ compile_add_const ptr_unskew ^^ Heap.set_heap_ptr ^^ - - (* First load databuf reference (last entry) at the heap position somehow *) - (* now load the databuf *) - get_start ^^ compile_add_const ptr_unskew ^^ - compile_unboxed_one ^^ + (* Allocate space for the elem buffer *) + get_elembuf ^^ + G.i (Call (nr (Dfinity.elem_length_i env))) ^^ + set_refs_size ^^ + + get_refs_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_refs_start ^^ + + (* Copy elembuf *) + get_refs_start ^^ + get_refs_size ^^ get_elembuf ^^ - get_tbl_size ^^ compile_sub_const 1l ^^ + compile_unboxed_const 0l ^^ G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - get_start ^^ load_ptr ^^ + + (* Get databuf *) + get_refs_start ^^ + load_unskewed_ptr ^^ set_databuf ^^ - get_databuf ^^ G.i (Call (nr (Dfinity.data_length_i env))) ^^ - set_data_len ^^ + (* Allocate space for the data buffer *) + get_databuf ^^ + G.i (Call (nr (Dfinity.data_length_i env))) ^^ + set_data_size ^^ - (* Get some scratch space *) - get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ - get_start ^^ compile_add_const ptr_unskew ^^ Heap.set_heap_ptr ^^ + get_data_size ^^ + compile_add_const 3l ^^ + compile_divU_const Heap.word_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_data_start ^^ - (* Load data from databuf *) - get_start ^^ compile_add_const ptr_unskew ^^ - get_data_len ^^ + (* Copy data *) + get_data_start ^^ + get_data_size ^^ get_databuf ^^ - compile_unboxed_zero ^^ + compile_unboxed_const 0l ^^ 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 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 ) - (* No, it is actual heap-data *) - ( (* update heap pointer *) - get_start ^^ - get_data_len ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - compile_add_const ptr_unskew ^^ - Heap.set_heap_ptr ^^ - Heap.grow_memory env ^^ - - (* Fix pointers *) - get_start ^^ - Heap.get_skewed_heap_ptr ^^ - get_start ^^ compile_add_const ptr_unskew ^^ - shift_pointers env ^^ - - (* Load references *) - Heap.get_heap_ptr ^^ - get_tbl_size ^^ compile_sub_const 1l ^^ - get_elembuf ^^ - compile_unboxed_zero ^^ - G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - - (* Fix references *) - (* Extract references *) - get_start ^^ - Heap.get_skewed_heap_ptr ^^ - Heap.get_skewed_heap_ptr ^^ - intract_references env ^^ - - (* return allocated thing *) - get_start - ) + (* Go! *) + get_data_start ^^ + get_refs_start ^^ + deserialize_go env t ^^ + G.i Drop ) diff --git a/src/serialization.ml b/src/serialization.ml index 93bdca1fdbb..e2f0ae02df6 100644 --- a/src/serialization.ml +++ b/src/serialization.ml @@ -79,9 +79,8 @@ module Transform() = struct | T.Tup ts -> T.Tup (List.map t_typ ts) | T.Func (T.Sharable, c, tbs, t1, t2) -> assert (c = T.Returns); - assert (tbs = []); (* We do not support parametric messages *) assert (t2 = []); (* A returning sharable function has no return values *) - T.Func (T.Sharable, T.Returns, [], List.map (fun t -> T.Serialized (t_typ t)) t1, []) + T.Func (T.Sharable, T.Returns, tbs, List.map (fun t -> T.Serialized (t_typ t)) t1, []) | T.Func (T.Local, c, tbs, t1, t2) -> T.Func (T.Local, c, List.map t_bind tbs, List.map t_typ t1, List.map t_typ t2) | T.Opt t -> T.Opt (t_typ t) @@ -130,7 +129,6 @@ module Transform() = struct | T.Local -> CallE(cc, t_exp exp1, List.map t_typ typs, t_exp exp2) | T.Sharable -> - assert (typs = []); assert (T.is_unit exp.note.note_typ); if cc.Value.n_args = 1 then @@ -145,7 +143,6 @@ module Transform() = struct | T.Local -> FuncE (x, cc, t_typ_binds typbinds, t_args args, t_typ typT, t_exp exp) | T.Sharable -> - assert (typbinds = []); assert (T.is_unit typT); let args' = t_args args in let raw_args = List.map serialized_arg args' in diff --git a/test/run-dfinity/no-boxed-references.as b/test/run-dfinity/no-boxed-references.as index 26ccc6451f9..95003e5e9e9 100644 --- a/test/run-dfinity/no-boxed-references.as +++ b/test/run-dfinity/no-boxed-references.as @@ -1,12 +1,12 @@ // No unboxing between the start of foo and the call to serialize // CHECK: (func $foo // CHECK-NOT: box_reference -// CHECK: call $deserialize +// CHECK: call $@deserialize shared func foo(a : Text, b: Int) {}; // No boxing between the call to serialize and the indirect call // CHECK: (func $start -// CHECK: call $serialize +// CHECK: call $@serialize // CHECK-NOT: box_reference // CHECK: call_indirect foo("a", 42); diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index 5b2baf03eb2..9fae09f51ed 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,3 +1,6 @@ +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable 0_0 1_0 2_0 @@ -6,6 +9,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok new file mode 100644 index 00000000000..ecbe21eb798 --- /dev/null +++ b/test/run-dfinity/ok/nary-async.wasm.stderr.ok @@ -0,0 +1,3 @@ +deserialize: T/77 +serialize: T/77 +buffer_size: T/77 From b7f3f8faa219d8bb1c42fea3fbb6c7c247445ca2 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 18:21:29 +0100 Subject: [PATCH 56/76] Special-case serialiation for Text, Word32 and references. to be a simple `databuf`, `I32` or `actorref`, for easier inter-op with the JS library. --- src/compile.ml | 260 +++++++++++++++++++++++++----------------- src/customSections.ml | 10 +- 2 files changed, 159 insertions(+), 111 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 04365bdf847..672143b897b 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2412,7 +2412,11 @@ end (* HeapTraversal *) module Serialization = struct (* - The serialization strategy is as follows: + We have a specific serialization strategy for `Text`, `Word32` and + references for easier interop with the console and the nonce. This is a + stop-gap measure until we have nailed down IDL and Bidirectional Messaging. + + The general serialization strategy is as follows: * We traverse the data to calculate the size needed for the data buffer and the reference buffer. * We remember the current heap pointer, and use the space after as scratch space. @@ -2742,12 +2746,10 @@ module Serialization = struct let (set_x, get_x) = new_local env "x" in read_word ^^ set_len ^^ - (* Refactor into Text.alloc *) get_len ^^ Text.alloc env ^^ set_x ^^ get_data_buf ^^ - get_x ^^ - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size Text.header_size)) ^^ + get_x ^^ Text.payload_ptr_unskewed ^^ get_len ^^ Heap.memcpy env ^^ @@ -2770,121 +2772,157 @@ module Serialization = struct if E.mode env <> DfinityMode then Func.share_code1 env name ("x", I32Type) [I32Type] (fun env _ -> G.i Unreachable) else Func.share_code1 env name ("x", I32Type) [I32Type] (fun env get_x -> - let (set_data_size, get_data_size) = new_local env "data_size" in - let (set_refs_size, get_refs_size) = new_local env "refs_size" in + match Type.normalize t with + | Type.Prim Type.Text -> get_x ^^ Dfinity.compile_databuf_of_text env + | Type.Prim Type.Word32 -> get_x ^^ BoxedSmallWord.unbox env + | Type.Obj (Type.Actor, _) -> get_x ^^ Dfinity.unbox_reference env + | _ -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in - (* Get object sizes *) - get_x ^^ - buffer_size env t ^^ - set_refs_size ^^ - set_data_size ^^ + (* Get object sizes *) + get_x ^^ + buffer_size env t ^^ + set_refs_size ^^ + set_data_size ^^ - let (set_data_start, get_data_start) = new_local env "data_start" in - let (set_refs_start, get_refs_start) = new_local env "refs_start" in + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" in - Heap.get_heap_ptr ^^ - set_data_start ^^ + Heap.get_heap_ptr ^^ + set_data_start ^^ - Heap.get_heap_ptr ^^ - get_data_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - set_refs_start ^^ + Heap.get_heap_ptr ^^ + get_data_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + set_refs_start ^^ - (* Allocate space, if needed *) - get_refs_start ^^ - get_refs_size ^^ - compile_divU_const Heap.word_size ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - Heap.grow_memory env ^^ + (* Allocate space, if needed *) + get_refs_start ^^ + get_refs_size ^^ + compile_divU_const Heap.word_size ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + Heap.grow_memory env ^^ - (* Serialize x into the buffer *) - get_x ^^ - get_data_start ^^ - get_refs_start ^^ - compile_unboxed_const 1l ^^ (* Leave space for databuf *) - serialize_go env t ^^ + (* Serialize x into the buffer *) + get_x ^^ + get_data_start ^^ + get_refs_start ^^ + compile_unboxed_const 1l ^^ (* Leave space for databuf *) + serialize_go env t ^^ - (* Sanity check: Did we fill exactly the buffer *) - get_refs_size ^^ compile_add_const 1l ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + (* Sanity check: Did we fill exactly the buffer *) + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ - get_data_start ^^ get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ - G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + get_data_start ^^ get_data_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + + (* Create databuf, and store at beginning of ref area *) + get_refs_start ^^ + get_data_start ^^ + get_data_size ^^ + G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ + store_unskewed_ptr ^^ + + (* Finally, create elembuf *) + get_refs_start ^^ + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Call (nr (Dfinity.elem_externalize_i env))) + ) - (* Create databuf, and store at beginning of ref area *) - get_refs_start ^^ - get_data_start ^^ - get_data_size ^^ - G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ - store_unskewed_ptr ^^ + let deserialize_text env get_databuf = + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_x, get_x) = new_local env "x" in + + get_databuf ^^ + G.i (Call (nr (Dfinity.data_length_i env))) ^^ + set_data_size ^^ + + get_data_size ^^ + Text.alloc env ^^ + set_x ^^ + + get_x ^^ Text.payload_ptr_unskewed ^^ + get_data_size ^^ + get_databuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ + + get_x - (* Finally, create elembuf *) - get_refs_start ^^ - get_refs_size ^^ compile_add_const 1l ^^ - G.i (Call (nr (Dfinity.elem_externalize_i env))) - ) let deserialize env t = let name = "@deserialize<" ^ typ_id t ^ ">" in Func.share_code1 env name ("elembuf", I32Type) [I32Type] (fun env get_elembuf -> - let (set_data_size, get_data_size) = new_local env "data_size" in - let (set_refs_size, get_refs_size) = new_local env "refs_size" in - let (set_data_start, get_data_start) = new_local env "data_start" in - let (set_refs_start, get_refs_start) = new_local env "refs_start" in - let (set_databuf, get_databuf) = new_local env "databuf" in - - (* Allocate space for the elem buffer *) - get_elembuf ^^ - G.i (Call (nr (Dfinity.elem_length_i env))) ^^ - set_refs_size ^^ - - get_refs_size ^^ - Array.alloc env ^^ - compile_add_const Array.header_size ^^ - compile_add_const ptr_unskew ^^ - set_refs_start ^^ - - (* Copy elembuf *) - get_refs_start ^^ - get_refs_size ^^ - get_elembuf ^^ - compile_unboxed_const 0l ^^ - G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - - (* Get databuf *) - get_refs_start ^^ - load_unskewed_ptr ^^ - set_databuf ^^ - - (* Allocate space for the data buffer *) - get_databuf ^^ - G.i (Call (nr (Dfinity.data_length_i env))) ^^ - set_data_size ^^ + match Type.normalize t with + | Type.Prim Type.Text -> deserialize_text env get_elembuf + | Type.Prim Type.Word32 -> get_elembuf ^^ BoxedSmallWord.box env + | Type.Obj (Type.Actor, _) -> get_elembuf ^^ Dfinity.box_reference env + | _ -> + let (set_data_size, get_data_size) = new_local env "data_size" in + let (set_refs_size, get_refs_size) = new_local env "refs_size" in + let (set_data_start, get_data_start) = new_local env "data_start" in + let (set_refs_start, get_refs_start) = new_local env "refs_start" in + let (set_databuf, get_databuf) = new_local env "databuf" in + + (* Allocate space for the elem buffer *) + get_elembuf ^^ + G.i (Call (nr (Dfinity.elem_length_i env))) ^^ + set_refs_size ^^ + + get_refs_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_refs_start ^^ - get_data_size ^^ - compile_add_const 3l ^^ - compile_divU_const Heap.word_size ^^ - Array.alloc env ^^ - compile_add_const Array.header_size ^^ - compile_add_const ptr_unskew ^^ - set_data_start ^^ - - (* Copy data *) - get_data_start ^^ - get_data_size ^^ - get_databuf ^^ - compile_unboxed_const 0l ^^ - G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ - - (* Go! *) - get_data_start ^^ - get_refs_start ^^ - deserialize_go env t ^^ - G.i Drop + (* Copy elembuf *) + get_refs_start ^^ + get_refs_size ^^ + get_elembuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ + + (* Get databuf *) + get_refs_start ^^ + load_unskewed_ptr ^^ + set_databuf ^^ + + (* Allocate space for the data buffer *) + get_databuf ^^ + G.i (Call (nr (Dfinity.data_length_i env))) ^^ + set_data_size ^^ + + get_data_size ^^ + compile_add_const 3l ^^ + compile_divU_const Heap.word_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_data_start ^^ + + (* Copy data *) + get_data_start ^^ + get_data_size ^^ + get_databuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.data_internalize_i env))) ^^ + + (* Go! *) + get_data_start ^^ + get_refs_start ^^ + deserialize_go env t ^^ + G.i Drop ) + let dfinity_type t = match Type.normalize t with + | Type.Prim Type.Text -> CustomSections.DataBuf + | Type.Prim Type.Word32 -> CustomSections.I32 + | Type.Obj (Type.Actor, _) -> CustomSections.ActorRef + | _ -> CustomSections.ElemBuf end (* Serialization *) @@ -3367,9 +3405,12 @@ module FuncDec = struct let fi = E.add_fun env f name in if not is_local then - E.add_dfinity_type env (fi, - CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) - ); + E.add_dfinity_type env (fi, + CustomSections.I32 :: + List.map ( + fun a -> Serialization.dfinity_type (Type.as_serialized a.note) + ) args + ); let code = (* Allocate a heap object for the closure *) @@ -4352,12 +4393,17 @@ and fill_actor_fields env fs = and export_actor_field env ((f : Ir.field), ptr) = let Name name = f.it.name.it in let (fi, fill) = E.reserve_fun env name in - let cc = Value.call_conv_of_typ f.note in - E.add_dfinity_type env (fi, Lib.List.make cc.Value.n_args CustomSections.ElemBuf); + let _, _, _, ts, _ = Type.as_func f.note in + E.add_dfinity_type env (fi, + List.map ( + fun t -> Serialization.dfinity_type (Type.as_serialized t) + ) ts + ); E.add_export env (nr { name = Dfinity.explode name; edesc = nr (FuncExport (nr fi)) }); + let cc = Value.call_conv_of_typ f.note in fill (FuncDec.compile_static_message env cc ptr); (* Local actor *) diff --git a/src/customSections.ml b/src/customSections.ml index b21f86bee6d..93094f0038a 100644 --- a/src/customSections.ml +++ b/src/customSections.ml @@ -1,6 +1,6 @@ (* Some data type to represent custom sectoins *) -type type_ = I32 | DataBuf | ElemBuf +type type_ = I32 | DataBuf | ElemBuf | ActorRef (* Some Code copied from encodeMap.ml *) type stream = @@ -77,9 +77,11 @@ let encode (fun _ (li, x) -> vu32 li; f x) in let ty = function - | I32 -> vu32 0x7fl - | DataBuf -> vu32 0x6cl - | ElemBuf -> vu32 0x6bl in + | I32 -> vu32 0x7fl + | DataBuf -> vu32 0x6cl + | ElemBuf -> vu32 0x6bl + | ActorRef -> vu32 0x6fl + in section 0 (fun _ -> string "types"; From cdeb0f57f7e06e1dc39c955fba673fddfbe40cdc Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 18:33:48 +0100 Subject: [PATCH 57/76] Stupid bug in the compiler related to module-ends-with-actor --- src/compile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/compile.ml b/src/compile.ml index 672143b897b..e4506cb4f97 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -4359,7 +4359,7 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names = | [] -> G.nop (* If the last program ends with an actor, then consider this the current actor *) | [((decls, {it = ActorE (i, ds, fs, _); _}), _flavor)] -> - let (env', code1) = compile_decs env ds in + let (env', code1) = compile_decs env decls in let code2 = main_actor env' i ds fs in code1 ^^ code2 | ((prog, _flavor) :: progs) -> From 6686339165daa9a49555ccf6b9049f83d9988e9f Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 21 Mar 2019 09:48:39 +0100 Subject: [PATCH 58/76] Document the current serialization format as a help for Matthew and Norton and anyone dealing with that format. --- design/TmpWireFormat.md | 71 +++++++++++++++++++++++++++++++++++++++++ src/compile.ml | 3 ++ 2 files changed, 74 insertions(+) create mode 100644 design/TmpWireFormat.md diff --git a/design/TmpWireFormat.md b/design/TmpWireFormat.md new file mode 100644 index 00000000000..56695f7c294 --- /dev/null +++ b/design/TmpWireFormat.md @@ -0,0 +1,71 @@ +Temporary Wire Format +===================== + +This document describes the serializaion format currently used by the +ActorScript runtime, i.e. a mapping from ActorScript types to DFINITY types (= +WebAssembly types + `databuf`, `elmembuf`, `funcref` and `actorref`), and a +mapping between the corresponding values. + +This is a scaffolding tool to prototype applications until we have decided upon +the actual IDL of the system, which will change all that is described here. + +It also does not support all features that we want to support eventually. In +particular, it does not support subtyping. + +Some types have a *specialized argument format* when used directly as a +function arguments, rather than nested inside a data structure. All others use +the *general argument format*. + +Each argument of a function is serialized separately. If the function is +defined with a list of arguments, these all become arguments of the WebAssembly +function. See the [ActorScript guide](https://hydra.oregon.dfinity.build//job/dfinity-ci-build/actorscript.pr-252/users-guide/latest/download/1/guide/#function-types) for the precise rules for function arities. + + +Specialized argument format: `Word32` +------------------------------------- + +A message entry point with an argument of type `Word32` is directly represented +as a `I32`. + +Specialized argument format: `Text` +------------------------------------- + +A message entry point with an argument of type `Text` is represented as a `databuf` that contains the UTF8-encoded string. + +Note that there is no terminating `\0`, and the length is implicit as the +length of the `databuf`. + + +General argument format +----------------------- + +All other arguments are represented as a non-empty `elembuf` where + + * the first entry is a `databuf` containing the actual data (see below) + * all further entries are the references contained in the data. + +The `databuf` is generated by an in-order traversal of the data type. +All numbers are fixed-width and in little endian format. + + * A `Nat`, `Int` or `Word64` is represented by 8 bytes. + * A `Word32` is represented by 4 bytes. + * A `Word16` is represented by 2 bytes. + * A `Word8` is represented by 1 byte. + * A `Bool` is represented by 1 byte that is `0` for `false` and `1` for `true`. + * A `Text` is represented by 4 bytes indicating the length of the following + payload, followed by the payload as a utf8-encoded string (no trailing `\0`). + * An `Array` is represented by 4 bytes indicating the number of entries, + followed by the concatenation of the representation of these entries. + * An `Tuple` is represented the concatenation of the representation of its + entries. (No need for a length field, as it is statically determined.) + * An `Object` is represented the concatenation of the representation of its + fields, sorted by field name. (The field names are not serialized, as they + are statically known.) + * An `Option` is represented by a single byte `0` if it is `null`, or + otherwise by a single byte `1` followed by the representation of the value + * A reference (`actor`, `shared func`) is represented as a 32 bit number (4 + bytes) that is an index into the surrounding `elembuf`. This is never `0`, as + the first entry in the `elembuf` is the `databuf` with the actual data. + * An empty tuple, the type `Null` and the type `Shared` are represented by + zero bytes. + diff --git a/src/compile.ml b/src/compile.ml index e4506cb4f97..739f541f298 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2412,6 +2412,9 @@ end (* HeapTraversal *) module Serialization = struct (* + Also see (and update) `design/TmpWireFormat.md`, which documents the format + in a “user-facing” way. + We have a specific serialization strategy for `Text`, `Word32` and references for easier interop with the console and the nonce. This is a stop-gap measure until we have nailed down IDL and Bidirectional Messaging. From 29bfa46e982ec4c65dc199c3f9460b9bef291741 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Wed, 20 Mar 2019 15:32:19 +0100 Subject: [PATCH 59/76] Bumping `dev` for no good reason The variation in test output is annoying, or maybe even worrying. --- default.nix | 2 +- test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/default.nix b/default.nix index 6a910edcfcd..3c381abd7f3 100644 --- a/default.nix +++ b/default.nix @@ -32,7 +32,7 @@ let real-dvm = then let dev = builtins.fetchGit { url = "ssh://git@github.com/dfinity-lab/dev"; - rev = "1ab8900eafb3a588372a9d71294df75b504539eb"; + rev = "0ce1f507cb3bb4fa8bba9223082a382fc9191f67"; ref = "master"; }; in # Pass devel = true until the dev test suite runs on MacOS again 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 index e5307f7818f..3292a97eddf 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1,2 +1 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable From becb3911e7b654e08710fef2431a09041be19fb9 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Thu, 21 Mar 2019 17:20:58 +0100 Subject: [PATCH 60/76] AST-72: correctly lex verbatim unicode (#260) * AST-72: consider all bytes necessary to identify a code point in the parsed input --- src/lexer.mll | 31 ++++++++++++++++++++++++------- test/run/conversions.as | 1 + test/run/literals.as | 3 +++ 3 files changed, 28 insertions(+), 7 deletions(-) diff --git a/src/lexer.mll b/src/lexer.mll index b64030fe1a6..2f5836c36a5 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -22,9 +22,23 @@ let error_nest start lexbuf msg = lexbuf.Lexing.lex_start_p <- start; error lexbuf msg -let unicode lexbuf s i = +let classify_utf8_leader lexbuf = Int32.(function + | ch when logand ch (lognot 0b01111111l) = 0b00000000l -> 0 + | ch when logand ch (lognot 0b00011111l) = 0b11000000l -> 1 + | ch when logand ch (lognot 0b00001111l) = 0b11100000l -> 2 + | ch when logand ch (lognot 0b00000111l) = 0b11110000l -> 3 + | ch -> error lexbuf (Printf.sprintf "invalid utf-8 character: 0x%x" (Int32.to_int ch))) + +let utf8_decoder l lexbuf s i = + let leading = classify_utf8_leader lexbuf (Int32.of_int (Char.code s.[!i])) + in if leading = 0 then Char.code s.[!i] + else match Utf8.decode (String.sub s !i (1 + leading)) with + | [code] -> i := !i + leading; code + | _ -> error lexbuf "can not interpret unicode character" + +let unicode lexbuf s i decoder = let u = - if s.[!i] <> '\\' then Char.code s.[!i] else + if s.[!i] <> '\\' then decoder lexbuf s i else match (incr i; s.[!i]) with | 'n' -> Char.code '\n' | 'r' -> Char.code '\r' @@ -44,14 +58,17 @@ let unicode lexbuf s i = int_of_string ("0x" ^ String.make 1 h ^ String.make 1 s.[!i]) in incr i; u -let char lexbuf s = - unicode lexbuf s (ref 1) +let char lexbuf s = unicode lexbuf s (ref 1) (fun _ _ _ -> + match Utf8.decode s with + | [39; code; 39] -> code (* surrounded by apostrophes *) + | _ -> error lexbuf "can not interpret unicode character") let text lexbuf s = - let b = Buffer.create (String.length s) in + let l = String.length s in + let b = Buffer.create l in let i = ref 1 in - while !i < String.length s - 1 do - let bs = Utf8.encode [unicode lexbuf s i] in + while !i < l - 1 do + let bs = Utf8.encode [unicode lexbuf s i (utf8_decoder l)] in Buffer.add_substring b bs 0 (String.length bs) done; Buffer.contents b diff --git a/test/run/conversions.as b/test/run/conversions.as index cd1cf3c2021..60afd31f484 100644 --- a/test/run/conversions.as +++ b/test/run/conversions.as @@ -143,6 +143,7 @@ println(word32ToInt 4294967295); // == (-1) // 2**32 - 1 assert(charToWord32 '\u{00}' == (0 : Word32)); assert(charToWord32 '*' == (42 : Word32)); +assert(charToWord32 'П' == (1055 : Word32)); assert(charToWord32 '\u{ffff}' == (65535 : Word32)); // 2**16 - 1 assert(charToWord32 '\u{10ffff}' == (0x10FFFF : Word32)); diff --git a/test/run/literals.as b/test/run/literals.as index 42060c4348f..b87c333bc96 100644 --- a/test/run/literals.as +++ b/test/run/literals.as @@ -6,4 +6,7 @@ let byte : Word8 = 0xFF : Word8; let short : Word16 = 0xFFFF : Word16; let word : Word32 = 0xFFFF_FFFF : Word32; let u = '\u{a34}'; +let gu = '🎸'; +let ru = "Приветствую, мир!\n"; let s = "a \t\22\00bb\'bc\\de \74xx\\x\"\u{000_234_42}\n"; +let emojis = "🙈🎸😋"; From da1110e39f0ffe71b88cb882811007ba326e1158 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 22 Mar 2019 07:11:26 +0100 Subject: [PATCH 61/76] Simplify UTF8 lexing fix --- src/lexer.mll | 41 +++++++++++++++++------------------------ 1 file changed, 17 insertions(+), 24 deletions(-) diff --git a/src/lexer.mll b/src/lexer.mll index 2f5836c36a5..b8aa9bbb8f5 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -22,23 +22,19 @@ let error_nest start lexbuf msg = lexbuf.Lexing.lex_start_p <- start; error lexbuf msg -let classify_utf8_leader lexbuf = Int32.(function - | ch when logand ch (lognot 0b01111111l) = 0b00000000l -> 0 - | ch when logand ch (lognot 0b00011111l) = 0b11000000l -> 1 - | ch when logand ch (lognot 0b00001111l) = 0b11100000l -> 2 - | ch when logand ch (lognot 0b00000111l) = 0b11110000l -> 3 - | ch -> error lexbuf (Printf.sprintf "invalid utf-8 character: 0x%x" (Int32.to_int ch))) - -let utf8_decoder l lexbuf s i = - let leading = classify_utf8_leader lexbuf (Int32.of_int (Char.code s.[!i])) - in if leading = 0 then Char.code s.[!i] - else match Utf8.decode (String.sub s !i (1 + leading)) with - | [code] -> i := !i + leading; code - | _ -> error lexbuf "can not interpret unicode character" - -let unicode lexbuf s i decoder = + +let utf8 lexbuf s i = + let len = + if s.[!i] < '\x80' then 0 else + if s.[!i] < '\xe0' then 1 else + if s.[!i] < '\xf0' then 2 else 3 + in + i := !i + len; + List.hd (Utf8.decode (String.sub s (!i - len) (1 + len))) + +let unicode lexbuf s i = let u = - if s.[!i] <> '\\' then decoder lexbuf s i else + if s.[!i] <> '\\' then utf8 lexbuf s i else match (incr i; s.[!i]) with | 'n' -> Char.code '\n' | 'r' -> Char.code '\r' @@ -58,17 +54,14 @@ let unicode lexbuf s i decoder = int_of_string ("0x" ^ String.make 1 h ^ String.make 1 s.[!i]) in incr i; u -let char lexbuf s = unicode lexbuf s (ref 1) (fun _ _ _ -> - match Utf8.decode s with - | [39; code; 39] -> code (* surrounded by apostrophes *) - | _ -> error lexbuf "can not interpret unicode character") +let char lexbuf s = + unicode lexbuf s (ref 1) let text lexbuf s = - let l = String.length s in - let b = Buffer.create l in + let b = Buffer.create (String.length s) in let i = ref 1 in - while !i < l - 1 do - let bs = Utf8.encode [unicode lexbuf s i (utf8_decoder l)] in + while !i < String.length s - 1 do + let bs = Utf8.encode [unicode lexbuf s i] in Buffer.add_substring b bs 0 (String.length bs) done; Buffer.contents b From 927d68770d84e1ec7ba45f497bb0d5867e1b70e0 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 22 Mar 2019 07:35:25 +0100 Subject: [PATCH 62/76] Minor cleanup --- src/parser.mly | 5 +---- src/typing.ml | 8 ++++---- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/src/parser.mly b/src/parser.mly index 7d494ce5a62..ff4c4503ab9 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -483,10 +483,7 @@ pat_nullary : | l=lit { LitP(ref l) @! at $sloc } | LPAR p=pat RPAR - { match p.it with - | TupP _ -> ParP(p) @! at $sloc - | _ -> ParP(p) @! p.at - } + { ParP(p) @! p.at } | LPAR ps=seplist1(pat_bin, COMMA) RPAR { TupP(ps) @! at $sloc } diff --git a/src/typing.ml b/src/typing.ml index e7d8d95e606..42b86f4d825 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -773,7 +773,7 @@ and infer_pat' env pat : T.typ * val_env = let t = check_typ env typ in t, check_pat env t pat1 | ParP pat1 -> - infer_pat env pat1 + infer_pat env pat1 and infer_pats at env pats ts ve : T.typ list * val_env = match pats with @@ -841,7 +841,7 @@ and check_pat' env t pat : val_env = error env pat.at "variables are not allowed in pattern alternatives"; T.Env.empty | ParP pat1 -> - check_pat env t pat1 + check_pat env t pat1 | _ -> let t', ve = infer_pat env pat in if not (T.sub t t') then @@ -892,8 +892,8 @@ and pub_pat pat xs : region T.Env.t * region T.Env.t = | AltP (pat1, _) | OptP pat1 | AnnotP (pat1, _) - | ParP pat1 - -> pub_pat pat1 xs + | ParP pat1 -> + pub_pat pat1 xs and pub_typ_id id (xs, ys) : region T.Env.t * region T.Env.t = (T.Env.add id.it id.at xs, ys) From 126eecc28f9f100e286977e4ec65a045d2841640 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 22 Mar 2019 12:31:57 +0100 Subject: [PATCH 63/76] Fast path for byte --- src/lexer.mll | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/lexer.mll b/src/lexer.mll index b8aa9bbb8f5..7f202103d7c 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -23,18 +23,15 @@ let error_nest start lexbuf msg = error lexbuf msg -let utf8 lexbuf s i = - let len = - if s.[!i] < '\x80' then 0 else - if s.[!i] < '\xe0' then 1 else - if s.[!i] < '\xf0' then 2 else 3 - in +let utf8 s i = + let len = if s.[!i] < '\xe0' then 1 else if s.[!i] < '\xf0' then 2 else 3 in i := !i + len; List.hd (Utf8.decode (String.sub s (!i - len) (1 + len))) -let unicode lexbuf s i = +let codepoint lexbuf s i = let u = - if s.[!i] <> '\\' then utf8 lexbuf s i else + if s.[!i] >= '\x80' then utf8 s i else + if s.[!i] <> '\\' then Char.code s.[!i] else match (incr i; s.[!i]) with | 'n' -> Char.code '\n' | 'r' -> Char.code '\r' @@ -55,13 +52,13 @@ let unicode lexbuf s i = in incr i; u let char lexbuf s = - unicode lexbuf s (ref 1) + codepoint lexbuf s (ref 1) let text lexbuf s = let b = Buffer.create (String.length s) in let i = ref 1 in while !i < String.length s - 1 do - let bs = Utf8.encode [unicode lexbuf s i] in + let bs = Utf8.encode [codepoint lexbuf s i] in Buffer.add_substring b bs 0 (String.length bs) done; Buffer.contents b From 9e0c2bc5de13dd157af9f27aee195ae08a788d7a Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Thu, 21 Mar 2019 16:53:07 +0100 Subject: [PATCH 64/76] Represent arguments without references directly as a databuf as for the scaffolding of the Produce Exchange, passing references is probably not a requirement, so it is worth making the life of the other side here. --- design/TmpWireFormat.md | 59 +++++++--- src/compile.ml | 105 +++++++++++++----- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 54 ++++++++- 3 files changed, 176 insertions(+), 42 deletions(-) diff --git a/design/TmpWireFormat.md b/design/TmpWireFormat.md index 56695f7c294..7138f18574e 100644 --- a/design/TmpWireFormat.md +++ b/design/TmpWireFormat.md @@ -13,8 +13,9 @@ It also does not support all features that we want to support eventually. In particular, it does not support subtyping. Some types have a *specialized argument format* when used directly as a -function arguments, rather than nested inside a data structure. All others use -the *general argument format*. +function arguments, rather than nested inside a data structure. Other types use +the _general argument format (without references)_ or the _general argument +format (with references)_. Each argument of a function is serialized separately. If the function is defined with a list of arguments, these all become arguments of the WebAssembly @@ -36,16 +37,13 @@ Note that there is no terminating `\0`, and the length is implicit as the length of the `databuf`. -General argument format ------------------------ +General argument format (without references) +-------------------------------------------- -All other arguments are represented as a non-empty `elembuf` where - - * the first entry is a `databuf` containing the actual data (see below) - * all further entries are the references contained in the data. - -The `databuf` is generated by an in-order traversal of the data type. -All numbers are fixed-width and in little endian format. +Arguments with a type that does not mention any reference types (no actors, no +shared functions), are represented as a `databuf`. This `databuf` is generated +by an in-order traversal of the data type. All numbers are fixed-width and in +little endian format. * A `Nat`, `Int` or `Word64` is represented by 8 bytes. * A `Word32` is represented by 4 bytes. @@ -63,9 +61,42 @@ All numbers are fixed-width and in little endian format. are statically known.) * An `Option` is represented by a single byte `0` if it is `null`, or otherwise by a single byte `1` followed by the representation of the value - * A reference (`actor`, `shared func`) is represented as a 32 bit number (4 - bytes) that is an index into the surrounding `elembuf`. This is never `0`, as - the first entry in the `elembuf` is the `databuf` with the actual data. * An empty tuple, the type `Null` and the type `Shared` are represented by zero bytes. + +*Example:* The ActorScript value +``` +(null, ?4, "!") : (?Text, ?Int, Text) +``` +is represented as +``` +00 01 04 00 00 00 00 00 00 00 01 21 +``` + +General argument format (with references) +----------------------------------------- + +Argument with a type that mentions reference types (actors or shared functions) +are represented as an `elembuf`: + + * the first entry is a `databuf` contains the data according to the format + above. + * all further entries are the references contained in the data. + +The above format is thus extended with the following case: + + * A reference (`actor`, `shared func`) is represented as a 32 bit number (4 + bytes). Thus number is an index into the surrounding `elembuf`. + + NB: The index is never never `0`, as the first entry in the `elembuf` is the + `databuf` with the actual data. + +*Example:* The ActorScript value +``` +(null, ?console) : (?actor {}, ?actor {log : Text -> () }) +``` +is represented as +``` +elembuf [databuf [00 01 01 00 00 00], console] +``` diff --git a/src/compile.ml b/src/compile.ml index 739f541f298..41b9d83ffef 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -2458,6 +2458,40 @@ module Serialization = struct let typ_id : Type.typ -> string = Type.string_of_typ + + (* Checks whether the serialization of a given type could contain references *) + module TS = Set.Make (struct type t = Type.typ let compare = compare end) + let has_no_references : Type.typ -> bool = fun t -> + let open Type in + let seen = ref TS.empty in (* break the cycles *) + let rec go t = + TS.mem t !seen || + begin + seen := TS.add t !seen; + match t with + | Var _ -> assert false + | (Prim _ | Any | Non | Shared | Pre) -> true + | Con (c, ts) -> + begin match Con.kind c with + | Abs _ -> assert false + | Def (tbs,t) -> go (open_ ts t) (* TBR this may fail to terminate *) + end + | Array t -> go t + | Tup ts -> List.for_all go ts + | Func (Sharable, c, tbs, ts1, ts2) -> false + | Func (s, c, tbs, ts1, ts2) -> + let ts = open_binds tbs in + List.for_all go (List.map (open_ ts) ts1) && + List.for_all go (List.map (open_ ts) ts2) + | Opt t -> go t + | Async t -> go t + | Obj (Actor, fs) -> false + | Obj (s, fs) -> List.for_all (fun f -> go f.typ) fs + | Mut t -> go t + | Serialized t -> go t + end + in go t + (* Returns data (in bytes) and reference buffer size (in entries) needed *) let rec buffer_size env t = let open Type in @@ -2830,10 +2864,20 @@ module Serialization = struct G.i (Call (nr (Dfinity.data_externalize_i env))) ^^ store_unskewed_ptr ^^ - (* Finally, create elembuf *) - get_refs_start ^^ - get_refs_size ^^ compile_add_const 1l ^^ - G.i (Call (nr (Dfinity.elem_externalize_i env))) + if has_no_references t + then + (* Sanity check: Really no references *) + get_refs_size ^^ + G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ^^ + G.if_ (ValBlockType None) G.nop (G.i Unreachable) ^^ + (* If there are no references, just return the databuf *) + get_refs_start ^^ + load_unskewed_ptr + else + (* Finally, create elembuf *) + get_refs_start ^^ + get_refs_size ^^ compile_add_const 1l ^^ + G.i (Call (nr (Dfinity.elem_externalize_i env))) ) let deserialize_text env get_databuf = @@ -2871,28 +2915,36 @@ module Serialization = struct let (set_refs_start, get_refs_start) = new_local env "refs_start" in let (set_databuf, get_databuf) = new_local env "databuf" in - (* Allocate space for the elem buffer *) - get_elembuf ^^ - G.i (Call (nr (Dfinity.elem_length_i env))) ^^ - set_refs_size ^^ - - get_refs_size ^^ - Array.alloc env ^^ - compile_add_const Array.header_size ^^ - compile_add_const ptr_unskew ^^ - set_refs_start ^^ - - (* Copy elembuf *) - get_refs_start ^^ - get_refs_size ^^ - get_elembuf ^^ - compile_unboxed_const 0l ^^ - G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ - - (* Get databuf *) - get_refs_start ^^ - load_unskewed_ptr ^^ - set_databuf ^^ + begin + if has_no_references t + then + (* We have no elembuf wrapper, so the argument is the databuf *) + compile_unboxed_const 0l ^^ set_refs_start ^^ + get_elembuf ^^ set_databuf + else + (* Allocate space for the elem buffer *) + get_elembuf ^^ + G.i (Call (nr (Dfinity.elem_length_i env))) ^^ + set_refs_size ^^ + + get_refs_size ^^ + Array.alloc env ^^ + compile_add_const Array.header_size ^^ + compile_add_const ptr_unskew ^^ + set_refs_start ^^ + + (* Copy elembuf *) + get_refs_start ^^ + get_refs_size ^^ + get_elembuf ^^ + compile_unboxed_const 0l ^^ + G.i (Call (nr (Dfinity.elem_internalize_i env))) ^^ + + (* Get databuf *) + get_refs_start ^^ + load_unskewed_ptr ^^ + set_databuf + end ^^ (* Allocate space for the data buffer *) get_databuf ^^ @@ -2925,6 +2977,7 @@ module Serialization = struct | Type.Prim Type.Text -> CustomSections.DataBuf | Type.Prim Type.Word32 -> CustomSections.I32 | Type.Obj (Type.Actor, _) -> CustomSections.ActorRef + | t' when has_no_references t' -> CustomSections.DataBuf | _ -> CustomSections.ElemBuf end (* Serialization *) diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok index ecbe21eb798..5810d542f08 100644 --- a/test/run-dfinity/ok/nary-async.wasm.stderr.ok +++ b/test/run-dfinity/ok/nary-async.wasm.stderr.ok @@ -1,3 +1,53 @@ deserialize: T/77 -serialize: T/77 -buffer_size: T/77 +prelude:103.1-128.2: internal error, File "compile.ml", line 2476, characters 21-27: Assertion failed + +Last environment: +@new_async = func +Array_init = func +Array_tabulate = func +abs = func +btstWord16 = func +btstWord32 = func +btstWord64 = func +btstWord8 = func +charToWord32 = func +clzWord16 = func +clzWord32 = func +clzWord64 = func +clzWord8 = func +ctzWord16 = func +ctzWord32 = func +ctzWord64 = func +ctzWord8 = func +hashInt = func +ignore = func +intToWord16 = func +intToWord32 = func +intToWord64 = func +intToWord8 = func +natToWord16 = func +natToWord32 = func +natToWord64 = func +natToWord8 = func +popcntWord16 = func +popcntWord32 = func +popcntWord64 = func +popcntWord8 = func +print = func +printInt = func +range = func +revrange = func +shrsWord16 = func +shrsWord32 = func +shrsWord64 = func +shrsWord8 = func +word16ToInt = func +word16ToNat = func +word32ToChar = func +word32ToInt = func +word32ToNat = func +word64ToInt = func +word64ToNat = func +word8ToInt = func +word8ToNat = func + From ae47fb05acd91ba7e979205e090ea18a2d344c9c Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Sat, 23 Mar 2019 21:47:57 +0100 Subject: [PATCH 65/76] Update test output (#267) according to what I see on hydra. I am not sure how that slipped in. Maybe due to Github not testing the result of a merge. Maybe some non-determinism in the output from `dvm`. Also add `ci-pr.nix` to adjust to changes on Hydra, namely https://github.com/dfinity-lab/hydra-jobsets/pull/6 --- ci-pr.nix | 1 + test/run-dfinity/ok/counter-class.dvm-run.ok | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) create mode 100644 ci-pr.nix delete mode 100644 test/run-dfinity/ok/counter-class.dvm-run.ok diff --git a/ci-pr.nix b/ci-pr.nix new file mode 100644 index 00000000000..7dcd26dad09 --- /dev/null +++ b/ci-pr.nix @@ -0,0 +1 @@ +import ./ci.nix 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 3292a97eddf..00000000000 --- a/test/run-dfinity/ok/counter-class.dvm-run.ok +++ /dev/null @@ -1 +0,0 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable From c5a32d5448af0cf00e4d196aad2da0816c9d00cf Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 25 Mar 2019 17:07:06 +0100 Subject: [PATCH 66/76] Pull in deterministic dvm i.e. one with https://github.com/dfinity-lab/dev/pull/698 applied. This way, the log output should be the same, even under system load, which caused our test suite to fail unexpectedly before. Also includes some minor improvements to the `Makefile`s. --- default.nix | 14 ++++++++------ test/Makefile | 2 +- test/dvm.sh | 2 +- test/run-dfinity/ok/actor-reexport.dvm-run.ok | 2 +- test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok | 3 ++- test/run-dfinity/ok/counter-class.dvm-run.ok | 1 + test/run-dfinity/ok/overflow.dvm-run.ok | 4 ++-- 7 files changed, 16 insertions(+), 12 deletions(-) create mode 100644 test/run-dfinity/ok/counter-class.dvm-run.ok diff --git a/default.nix b/default.nix index 3c381abd7f3..d4c0723a70c 100644 --- a/default.nix +++ b/default.nix @@ -32,8 +32,8 @@ let real-dvm = then let dev = builtins.fetchGit { url = "ssh://git@github.com/dfinity-lab/dev"; - rev = "0ce1f507cb3bb4fa8bba9223082a382fc9191f67"; - ref = "master"; + ref = "joachim/more-logging"; + rev = "70d3b158611c96fe5e82b66d4a62c9d02bcd5345"; }; in # Pass devel = true until the dev test suite runs on MacOS again (import dev { devel = true; }).dvm @@ -121,11 +121,13 @@ rec { asc --version make -C stdlib ASC=asc all make -C samples ASC=asc all - make -C test VERBOSE=1 ASC=asc quick '' + - (if test-dvm then '' - make --load-average -j8 -C test/run-dfinity VERBOSE=1 ASC=asc quick - '' else ""); + (if test-dvm + then '' + make -C test ASC=asc parallel + '' else '' + make -C test ASC=asc quick + ''); installPhase = '' mkdir -p $out diff --git a/test/Makefile b/test/Makefile index 693499a6eba..e8763d23934 100644 --- a/test/Makefile +++ b/test/Makefile @@ -3,7 +3,7 @@ all: $(MAKE) -C run $(MAKE) -C run-dfinity -MAKE_PAR := $(MAKE) --no-print-directory --load-average -j $(shell getconf _NPROCESSORS_ONLN) +MAKE_PAR := $(MAKE) --no-print-directory --load-average -j $(shell getconf _NPROCESSORS_ONLN) --keep-going quick: $(MAKE_PAR) -C fail quick diff --git a/test/dvm.sh b/test/dvm.sh index 16037510060..7a1c8f6d372 100755 --- a/test/dvm.sh +++ b/test/dvm.sh @@ -7,7 +7,7 @@ then fi name="$(basename $1 .wasm)_0" -DVM_TMP=$(mktemp -d) +DVM_TMP=$(mktemp --directory --tmpdir dvm-XXXXXX) trap 'rm -rf $DVM_TMP' EXIT export LANG=C diff --git a/test/run-dfinity/ok/actor-reexport.dvm-run.ok b/test/run-dfinity/ok/actor-reexport.dvm-run.ok index 3292a97eddf..86607643126 100644 --- a/test/run-dfinity/ok/actor-reexport.dvm-run.ok +++ b/test/run-dfinity/ok/actor-reexport.dvm-run.ok @@ -1 +1 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling start failed with trap message: Uncaught RuntimeError: unreachable 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 index 3292a97eddf..bc31b890000 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1 +1,2 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$92 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$98 failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/counter-class.dvm-run.ok b/test/run-dfinity/ok/counter-class.dvm-run.ok new file mode 100644 index 00000000000..86607643126 --- /dev/null +++ b/test/run-dfinity/ok/counter-class.dvm-run.ok @@ -0,0 +1 @@ +W, hypervisor: calling start failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok index 8ca337c71a9..95eb31c1554 100644 --- a/test/run-dfinity/ok/overflow.dvm-run.ok +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -1,5 +1,5 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$104 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$110 failed with trap message: Uncaught RuntimeError: unreachable This is reachable. This is reachable. This is reachable. From 4a0b01b106fa150fc1e5b0a6d6e8d7927318d763 Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 25 Mar 2019 16:37:56 +0100 Subject: [PATCH 67/76] remove devel workaround --- default.nix | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/default.nix b/default.nix index d4c0723a70c..fd1ffb8497e 100644 --- a/default.nix +++ b/default.nix @@ -35,8 +35,7 @@ let real-dvm = ref = "joachim/more-logging"; rev = "70d3b158611c96fe5e82b66d4a62c9d02bcd5345"; }; in - # Pass devel = true until the dev test suite runs on MacOS again - (import dev { devel = true; }).dvm + (import dev {}).dvm else null else dvm; in From fec3f05900000883bf4f66bcfed4e41560a4e0dc Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Mon, 25 Mar 2019 18:02:30 +0100 Subject: [PATCH 68/76] fix comments (#265) * fix comments --- src/compile.ml | 5 +++-- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index 41b9d83ffef..87ef44daab0 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -431,12 +431,13 @@ let new_local64 env name = (* Some common code macros *) -(* expects a number on the stack. Iterates from zero t below that number *) +(* Iterates while cond is true. *) let compile_while cond body = G.loop_ (ValBlockType None) ( cond ^^ G.if_ (ValBlockType None) (body ^^ G.i (Br (nr 1l))) G.nop ) +(* Expects a number on the stack. Iterates from zero to below that number. *) let from_0_to_n env mk_body = let (set_n, get_n) = new_local env "n" in let (set_i, get_i) = new_local env "i" in @@ -2423,7 +2424,7 @@ module Serialization = struct * We traverse the data to calculate the size needed for the data buffer and the reference buffer. * We remember the current heap pointer, and use the space after as scratch space. - * The scratch space is separated into two region: + * The scratch space is separated into two regions: One for references, and one for raw data. * We traverse the data, in a type-driven way, and copy it to the scratch space. We thread through pointers to the current free space of the two scratch spaces. diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok index 5810d542f08..bb97c60cb2a 100644 --- a/test/run-dfinity/ok/nary-async.wasm.stderr.ok +++ b/test/run-dfinity/ok/nary-async.wasm.stderr.ok @@ -1,5 +1,5 @@ deserialize: T/77 -prelude:103.1-128.2: internal error, File "compile.ml", line 2476, characters 21-27: Assertion failed +prelude:103.1-128.2: internal error, File "compile.ml", line 2477, characters 21-27: Assertion failed Last environment: @new_async = func From 91d6bf35112661ba12c184f221a8179e29fa8878 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 25 Mar 2019 18:17:49 +0100 Subject: [PATCH 69/76] AST-70: Eliminate 1-tuples (#263) * Eliminate 1-tuples --- src/desugar.ml | 7 +----- src/parser.mly | 22 +++++-------------- test/fail/ok/one-tuple-ambiguity.tc.ok | 8 ------- test/run-dfinity/ok/data-params.run-ir.ok | 6 ++--- test/run-dfinity/ok/data-params.run-low.ok | 6 ++--- test/run-dfinity/ok/data-params.run.ok | 6 ++--- test/run-dfinity/ok/data-params.tc.ok | 6 ++--- .../run-dfinity/ok/data-params.wasm.stderr.ok | 6 ++--- test/run-dfinity/ok/nary-async.dvm-run.ok | 2 -- test/run/ok/coverage.run-ir.ok | 6 ++--- test/run/ok/coverage.run-low.ok | 6 ++--- test/run/ok/coverage.run.ok | 6 ++--- test/run/ok/coverage.tc.ok | 6 ++--- test/run/ok/coverage.wasm.stderr.ok | 6 ++--- 14 files changed, 37 insertions(+), 62 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index 2f320ba5af1..1004e84a99d 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -238,12 +238,7 @@ and to_arg p : (Ir.arg * (Ir.exp -> Ir.exp)) = (fun e -> blockE [letP (pat p) v] e) -and to_args cc p0 : (Ir.arg list * (Ir.exp -> Ir.exp)) = - let p = match p0.it, p0.note with - | S.ParP p1, _ -> p1 - | S.TupP [p1], Type.Tup [n] -> { p0 with it = p1.it; note = n } - | _ -> p0 in - +and to_args cc p : (Ir.arg list * (Ir.exp -> Ir.exp)) = let n = cc.Value.n_args in let tys = if n = 1 then [p.note] else T.as_seq p.note in diff --git a/src/parser.mly b/src/parser.mly index ff4c4503ab9..054ab737bff 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -146,10 +146,6 @@ seplist(X, SEP) : | x=X { [x] } | x=X SEP xs=seplist(X, SEP) { x::xs } -seplist1(X, SEP) : - | (* empty *) { [] } - | x=X SEP xs=seplist(X, SEP) { x::xs } - (* Basics *) @@ -201,10 +197,8 @@ typ_obj : { tfs } typ_nullary : - | LPAR t=typ RPAR - { ParT(t) @! at $loc } - | LPAR ts=seplist1(typ_item, COMMA) RPAR - { TupT(ts) @! at $sloc } + | LPAR ts=seplist(typ_item, COMMA) RPAR + { (match ts with [t] -> ParT(t) | _ -> TupT(ts)) @! at $sloc } | x=id tso=typ_args? { VarT(x, Lib.Option.get tso []) @! at $sloc } | LBRACKET m=var_opt t=typ RBRACKET @@ -337,10 +331,8 @@ exp_nullary : { VarE(x) @? at $sloc } | l=lit { LitE(ref l) @? at $sloc } - | LPAR e=exp RPAR - { e } - | LPAR es=seplist1(exp, COMMA) RPAR - { TupE(es) @? at $sloc } + | LPAR es=seplist(exp, COMMA) RPAR + { match es with [e] -> e | _ -> TupE(es) @? at $sloc } | PRIM s=TEXT { PrimE(s) @? at $sloc } @@ -482,10 +474,8 @@ pat_nullary : { VarP(x) @! at $sloc } | l=lit { LitP(ref l) @! at $sloc } - | LPAR p=pat RPAR - { ParP(p) @! p.at } - | LPAR ps=seplist1(pat_bin, COMMA) RPAR - { TupP(ps) @! at $sloc } + | LPAR ps=seplist(pat_bin, COMMA) RPAR + { (match ps with [p] -> ParP(p) | _ -> TupP(ps)) @! at $sloc } pat_un : | p=pat_nullary diff --git a/test/fail/ok/one-tuple-ambiguity.tc.ok b/test/fail/ok/one-tuple-ambiguity.tc.ok index d81f6ed4b3b..5baf5c2e6d0 100644 --- a/test/fail/ok/one-tuple-ambiguity.tc.ok +++ b/test/fail/ok/one-tuple-ambiguity.tc.ok @@ -1,14 +1,6 @@ -one-tuple-ambiguity.as:10.2-10.7: type error, expression of type - ((),) -cannot produce expected type - () one-tuple-ambiguity.as:16.3-16.5: type error, literal of type Nat does not have expected type (Nat, Bool) one-tuple-ambiguity.as:16.1-16.5: type error, expected function type, but expression produces type () -one-tuple-ambiguity.as:21.2-21.16: type error, expression of type - ((Nat, Bool),) -cannot produce expected type - (Nat, Bool) diff --git a/test/run-dfinity/ok/data-params.run-ir.ok b/test/run-dfinity/ok/data-params.run-ir.ok index a814fca710b..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run-ir.ok +++ b/test/run-dfinity/ok/data-params.run-ir.ok @@ -1,6 +1,6 @@ -data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:118.19-118.27: warning, this pattern does not cover all possible values -data-params.as:190.19-190.27: warning, this pattern does not cover all possible values +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.run-low.ok b/test/run-dfinity/ok/data-params.run-low.ok index a814fca710b..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run-low.ok +++ b/test/run-dfinity/ok/data-params.run-low.ok @@ -1,6 +1,6 @@ -data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:118.19-118.27: warning, this pattern does not cover all possible values -data-params.as:190.19-190.27: warning, this pattern does not cover all possible values +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.run.ok b/test/run-dfinity/ok/data-params.run.ok index a814fca710b..1438d09752b 100644 --- a/test/run-dfinity/ok/data-params.run.ok +++ b/test/run-dfinity/ok/data-params.run.ok @@ -1,6 +1,6 @@ -data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:118.19-118.27: warning, this pattern does not cover all possible values -data-params.as:190.19-190.27: warning, this pattern does not cover all possible values +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values 1 3 6 diff --git a/test/run-dfinity/ok/data-params.tc.ok b/test/run-dfinity/ok/data-params.tc.ok index a83d17237ff..8606a83e6af 100644 --- a/test/run-dfinity/ok/data-params.tc.ok +++ b/test/run-dfinity/ok/data-params.tc.ok @@ -1,3 +1,3 @@ -data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:118.19-118.27: warning, this pattern does not cover all possible values -data-params.as:190.19-190.27: warning, this pattern does not cover all possible values +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/data-params.wasm.stderr.ok b/test/run-dfinity/ok/data-params.wasm.stderr.ok index a83d17237ff..8606a83e6af 100644 --- a/test/run-dfinity/ok/data-params.wasm.stderr.ok +++ b/test/run-dfinity/ok/data-params.wasm.stderr.ok @@ -1,3 +1,3 @@ -data-params.as:46.19-46.27: warning, this pattern does not cover all possible values -data-params.as:118.19-118.27: warning, this pattern does not cover all possible values -data-params.as:190.19-190.27: warning, this pattern does not cover all possible values +data-params.as:46.18-46.28: warning, this pattern does not cover all possible values +data-params.as:118.18-118.28: warning, this pattern does not cover all possible values +data-params.as:190.18-190.28: warning, this pattern does not cover all possible values diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index 9fae09f51ed..861a4fd347e 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,6 +1,4 @@ W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable 0_0 1_0 2_0 diff --git a/test/run/ok/coverage.run-ir.ok b/test/run/ok/coverage.run-ir.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run-ir.ok +++ b/test/run/ok/coverage.run-ir.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.run-low.ok b/test/run/ok/coverage.run-low.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run-low.ok +++ b/test/run/ok/coverage.run-low.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.run.ok b/test/run/ok/coverage.run.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.run.ok +++ b/test/run/ok/coverage.run.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.tc.ok b/test/run/ok/coverage.tc.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.tc.ok +++ b/test/run/ok/coverage.tc.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values diff --git a/test/run/ok/coverage.wasm.stderr.ok b/test/run/ok/coverage.wasm.stderr.ok index b432a6df617..3e28522aedb 100644 --- a/test/run/ok/coverage.wasm.stderr.ok +++ b/test/run/ok/coverage.wasm.stderr.ok @@ -14,12 +14,12 @@ coverage.as:32.43-32.44: warning, this pattern is never matched coverage.as:33.35-33.49: warning, this case is never reached coverage.as:34.42-34.51: warning, this case is never reached coverage.as:4.7-4.8: warning, this pattern does not cover all possible values -coverage.as:5.8-5.14: warning, this pattern does not cover all possible values +coverage.as:5.7-5.15: warning, this pattern does not cover all possible values coverage.as:9.7-9.9: warning, this pattern does not cover all possible values coverage.as:10.7-10.9: warning, this pattern does not cover all possible values coverage.as:11.7-11.9: warning, this pattern does not cover all possible values -coverage.as:15.11-15.12: warning, this pattern does not cover all possible values -coverage.as:16.11-16.17: warning, this pattern does not cover all possible values +coverage.as:15.10-15.13: warning, this pattern does not cover all possible values +coverage.as:16.10-16.18: warning, this pattern does not cover all possible values coverage.as:23.3-23.25: warning, the cases in this switch do not cover all possible values coverage.as:24.3-24.36: warning, the cases in this switch do not cover all possible values coverage.as:32.3-32.50: warning, the cases in this switch do not cover all possible values From 26ed2f1d33e4fbad2ef16f7723ad529a0e073e55 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 25 Mar 2019 17:52:29 +0100 Subject: [PATCH 70/76] Nix: Use builtins.path this way, we get consistent store paths independent of wether we have the sources locally, or get them via `fetchGit`. See https://github.com/NixOS/nix/issues/1305 --- default.nix | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index fd1ffb8497e..b06b074fa86 100644 --- a/default.nix +++ b/default.nix @@ -5,11 +5,14 @@ let stdenv = nixpkgs.stdenv; in -let sourceByRegex = src: regexes: builtins.filterSource (path: type: +let sourceByRegex = src: regexes: builtins.path + { name = "actorscript"; + path = src; + filter = path: type: let relPath = nixpkgs.lib.removePrefix (toString src + "/") (toString path); in let match = builtins.match (nixpkgs.lib.strings.concatStringsSep "|" regexes); in - ( type == "directory" && match (relPath + "/") != null - || match relPath != null)) src; in + ( type == "directory" && match (relPath + "/") != null || match relPath != null); + }; in let ocaml_wasm = (import ./nix/ocaml-wasm.nix) { inherit (nixpkgs) stdenv fetchFromGitHub ocaml; From 11cfb7dd9bcb76272f38ab5ec0c0397d8fea5aec Mon Sep 17 00:00:00 2001 From: Matthew Hammer Date: Tue, 26 Mar 2019 07:03:56 -0600 Subject: [PATCH 71/76] WIP: Text iteration (#197) * text iteration * clean and expand test file * `printChar`, `decodeUTF8` and `charToText` in `prelude` * add conversion testcases --- src/compile.ml | 307 +++++++++++++++--- src/prelude.ml | 21 ++ src/type.ml | 7 + src/value.ml | 16 +- .../ok/array-out-of-bounds.dvm-run.ok | 2 +- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 5 +- test/run-dfinity/ok/overflow.dvm-run.ok | 2 +- test/run/conversions.as | 9 +- test/run/ok/text-iter.run-ir.ok | 20 ++ test/run/ok/text-iter.run-low.ok | 20 ++ test/run/ok/text-iter.run.ok | 20 ++ test/run/ok/text-iter.wasm-run.ok | 1 + test/run/text-iter.as | 72 ++++ 13 files changed, 456 insertions(+), 46 deletions(-) create mode 100644 test/run/ok/text-iter.run-ir.ok create mode 100644 test/run/ok/text-iter.run-low.ok create mode 100644 test/run/ok/text-iter.run.ok create mode 100644 test/run/ok/text-iter.wasm-run.ok create mode 100644 test/run/text-iter.as diff --git a/src/compile.ml b/src/compile.ml index 87ef44daab0..a2dc9cf229b 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -410,6 +410,13 @@ 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 +let compile_shrU_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.ShrU n +let compile_shl_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.Shl n +let compile_bitand_const = compile_op_const I32Op.And +let compile_bitor_const = function + | 0l -> G.nop | n -> compile_op_const I32Op.Or n (* Locals *) @@ -820,8 +827,7 @@ module BitTagged = struct Func.share_code1 env "is_unboxed" ("x", I32Type) [I32Type] (fun env get_x -> (* Get bit *) get_x ^^ - compile_unboxed_const 0x2l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) ^^ + compile_bitand_const 0x2l ^^ (* Check bit *) G.i (Test (Wasm.Values.I32 I32Op.Eqz)) ) ^^ @@ -829,8 +835,7 @@ module BitTagged = struct (* The untag_scalar and tag functions expect 64 bit numbers *) let untag_scalar env = - compile_unboxed_const scalar_shift ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) ^^ + compile_shrU_const scalar_shift ^^ G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) let tag = @@ -840,8 +845,7 @@ module BitTagged = struct (* The untag_i32 and tag_i32 functions expect 32 bit numbers *) let untag_i32 env = - compile_unboxed_const scalar_shift ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) + compile_shrU_const scalar_shift let tag_i32 = compile_unboxed_const scalar_shift ^^ @@ -1332,12 +1336,7 @@ module UnboxedSmallWord = struct (* Makes sure that we only shift/rotate the maximum number of bits available in the word. *) let clamp_shift_amount = function | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (bitwidth_mask_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) - - let shiftWordNtoI32 b = - compile_unboxed_const b ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) + | ty -> compile_bitand_const (bitwidth_mask_of_type ty) let shift_leftWordNtoI32 b = compile_unboxed_const b ^^ @@ -1346,7 +1345,7 @@ module UnboxedSmallWord = struct (* Makes sure that the word payload (e.g. shift/rotate amount) is in the LSB bits of the word. *) let lsb_adjust = function | Type.Word32 -> G.nop - | ty -> shiftWordNtoI32 (shift_of_type ty) + | ty -> compile_shrU_const (shift_of_type ty) (* Makes sure that the word payload (e.g. operation result) is in the MSB bits of the word. *) let msb_adjust = function @@ -1356,14 +1355,12 @@ module UnboxedSmallWord = struct (* Makes sure that the word representation invariant is restored. *) let sanitize_word_result = function | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (mask_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.And)) + | ty -> compile_bitand_const (mask_of_type ty) (* Sets the number (according to the type's word invariant) of LSBs. *) let compile_word_padding = function | Type.Word32 -> G.nop - | ty -> compile_unboxed_const (padding_of_type ty) ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Or)) + | ty -> compile_bitor_const (padding_of_type ty) (* Kernel for counting leading zeros, according to the word invariant. *) let clz_kernel ty = @@ -1393,6 +1390,77 @@ module UnboxedSmallWord = struct G.i (Binary (Wasm.Values.I32 I32Op.Shl)) ^^ G.i (Binary (Wasm.Values.I32 I32Op.And)) + (* Code points occupy 21 bits, no alloc needed in vanilla SR. *) + let unbox_codepoint = compile_shrU_const 8l + let box_codepoint = compile_shl_const 8l + + (* Two utilities for dealing with utf-8 encoded bytes. *) + let compile_load_byte get_ptr offset = + get_ptr ^^ G.i (Load {ty = I32Type; align = 0; offset; sz = Some (Wasm.Memory.Pack8, Wasm.Memory.ZX)}) + + let compile_6bit_mask = compile_bitand_const 0b00111111l + + (* consume from get_c and build result (get/set_res), inspired by + * https://rosettacode.org/wiki/UTF-8_encode_and_decode#C *) + + (* Examine the byte pointed to by get_ptr, and if needed, following + * bytes, building an unboxed Unicode code point in location + * get_res, and finally returning the number of bytes consumed on + * the stack. *) + let len_UTF8_head env get_ptr set_res get_res = + let (set_c, get_c) = new_local env "utf-8" in + let under thres = + get_c ^^ set_res ^^ + get_c ^^ compile_unboxed_const thres ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU)) in + let load_follower offset = compile_load_byte get_ptr offset ^^ compile_6bit_mask + in compile_load_byte get_ptr 0l ^^ set_c ^^ + under 0x80l ^^ + G.if_ (ValBlockType (Some I32Type)) + compile_unboxed_one + (under 0xe0l ^^ + G.if_ (ValBlockType (Some I32Type)) + (get_res ^^ compile_bitand_const 0b00011111l ^^ + compile_shl_const 6l ^^ + load_follower 1l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 2l) + (under 0xf0l ^^ + G.if_ (ValBlockType (Some I32Type)) + (get_res ^^ compile_bitand_const 0b00001111l ^^ + compile_shl_const 12l ^^ + load_follower 1l ^^ + compile_shl_const 6l ^^ + load_follower 2l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 3l) + (get_res ^^ compile_bitand_const 0b00000111l ^^ + compile_shl_const 18l ^^ + load_follower 1l ^^ + compile_shl_const 12l ^^ + load_follower 2l ^^ + compile_shl_const 6l ^^ + load_follower 3l ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Or)) ^^ + set_res ^^ + compile_unboxed_const 4l))) + + (* The get_ptr argument moves a pointer to the payload of a Text onto the stack. + Then char_length_of_UTF8 decodes the first character of the string and puts + + - the length (in bytes) of the UTF-8 encoding of the first character and + - its assembled code point (boxed) + onto the stack. *) + let char_length_of_UTF8 env get_ptr = + let (set_res, get_res) = new_local env "res" + in len_UTF8_head env get_ptr set_res get_res ^^ + BoxedSmallWord.box env ^^ + get_res ^^ box_codepoint + end (* UnboxedSmallWord *) (* Primitive functions *) @@ -1428,7 +1496,7 @@ module Prim = struct let prim_word32toNat = G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) let prim_shiftWordNtoUnsigned b = - UnboxedSmallWord.shiftWordNtoI32 b ^^ + compile_shrU_const b ^^ prim_word32toNat let prim_word32toInt = G.i (Convert (Wasm.Values.I64 I64Op.ExtendSI32)) @@ -1595,6 +1663,8 @@ module Text = struct ┌─────┬─────────┬──────────────────┐ │ tag │ n_bytes │ bytes (padded) … │ └─────┴─────────┴──────────────────┘ + + Note: The bytes are UTF-8 encoded code points from Unicode. *) let header_size = Int32.add Tagged.header_size 1l @@ -1633,8 +1703,9 @@ module Text = struct get_x ) - let payload_ptr_unskewed = - compile_add_const Int32.(add ptr_unskew (mul Heap.word_size header_size)) + let unskewed_payload_offset = Int32.(add ptr_unskew (mul Heap.word_size header_size)) + let payload_ptr_unskewed = + compile_add_const unskewed_payload_offset (* String concatentation. Expects two strings on stack *) let concat env = Func.share_code2 env "concat" (("x", I32Type), ("y", I32Type)) [I32Type] (fun env get_x get_y -> @@ -1704,6 +1775,152 @@ module Text = struct Bool.lit true ) + let prim_decodeUTF8 env = + Func.share_code1 env "decodeUTF8" ("string", I32Type) [I32Type; + I32Type] (fun env get_string -> + let (set_ptr, get_ptr) = new_local env "ptr" + in get_string ^^ payload_ptr_unskewed ^^ set_ptr ^^ + UnboxedSmallWord.char_length_of_UTF8 env get_ptr + ) + + let common_funcs env0 = + let next_fun () : E.func_with_names = Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + let (set_n, get_n) = new_local env "n" in + let (set_char, get_char) = new_local env "char" in + let (set_ptr, get_ptr) = new_local env "ptr" in + (* Get pointer to counter from closure *) + Closure.get ^^ Closure.load_data 0l ^^ + (* Get current counter (boxed) *) + Var.load ^^ + + (* Get current counter (unboxed) *) + BoxedSmallWord.unbox env ^^ + set_n ^^ + + get_n ^^ + (* Get length *) + Closure.get ^^ Closure.load_data 1l ^^ Heap.load_field len_field ^^ + G.i (Compare (Wasm.Values.I32 I32Op.GeU)) ^^ + G.if_ (ValBlockType (Some I32Type)) + (* Then *) + Opt.null + (* Else *) + begin (* Return stuff *) + Opt.inject env ( + Closure.get ^^ Closure.load_data 0l ^^ + get_n ^^ + get_n ^^ + Closure.get ^^ Closure.load_data 1l ^^ payload_ptr_unskewed ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr ^^ + UnboxedSmallWord.len_UTF8_head env get_ptr set_char get_char ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ + (* Store advanced counter *) + BoxedSmallWord.box env ^^ + Var.store ^^ + get_char ^^ UnboxedSmallWord.box_codepoint) + end + ) in + + let get_text_object = Closure.get ^^ Closure.load_data 0l in + let mk_iterator next_funid = Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + (* next function *) + let (set_ni, get_ni) = new_local env "next" in + Closure.fixed_closure env next_funid + [ Tagged.obj env Tagged.MutBox [ compile_unboxed_zero ] + ; get_text_object + ] ^^ + set_ni ^^ + + Object.lit_raw env + [ nr_ (Name "next"), fun _ -> get_ni ]) + in E.define_built_in env0 "text_chars_next" next_fun; + E.define_built_in env0 "text_chars" + (fun () -> mk_iterator (E.built_in env0 "text_chars_next")); + + E.define_built_in env0 "text_len" + (fun () -> Func.of_body env0 ["clos", I32Type] [I32Type] (fun env -> + let (set_max, get_max) = new_local env "max" in + let (set_n, get_n) = new_local env "n" in + let (set_char, get_char) = new_local env "char" in + let (set_ptr, get_ptr) = new_local env "ptr" in + let (set_len, get_len) = new_local env "len" + in compile_unboxed_zero ^^ set_n ^^ + compile_unboxed_zero ^^ set_len ^^ + get_text_object ^^ Heap.load_field len_field ^^ set_max ^^ + compile_while + (get_n ^^ get_max ^^ G.i (Compare (Wasm.Values.I32 I32Op.LtU))) + begin + get_text_object ^^ payload_ptr_unskewed ^^ get_n ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_ptr ^^ + UnboxedSmallWord.len_UTF8_head env get_ptr set_char get_char ^^ + get_n ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ set_n ^^ + get_len ^^ compile_add_const 1l ^^ set_len + end ^^ + get_len ^^ + G.i (Convert (Wasm.Values.I64 I64Op.ExtendUI32)) ^^ + BoxedInt.box env)) + + let fake_object_idx_option env built_in_name = + let (set_text, get_text) = new_local env "text" in + set_text ^^ + Closure.fixed_closure env (E.built_in env built_in_name) [ get_text ] + + let fake_object_idx env = function + | "chars" -> Some (fake_object_idx_option env "text_chars") + | "len" -> Some (fake_object_idx_option env "text_len") + | _ -> None + + let prim_showChar env = + let (set_c, get_c) = new_local env "c" in + let (set_utf8, get_utf8) = new_local env "utf8" in + let storeLeader bitpat shift = + get_c ^^ compile_shrU_const shift ^^ compile_bitor_const bitpat ^^ + G.i (Store {ty = I32Type; align = 0; + offset = unskewed_payload_offset; + sz = Some Wasm.Memory.Pack8}) in + let storeFollower offset shift = + get_c ^^ compile_shrU_const shift ^^ UnboxedSmallWord.compile_6bit_mask ^^ + compile_bitor_const 0b10000000l ^^ + G.i (Store {ty = I32Type; align = 0; + offset = Int32.add offset unskewed_payload_offset; + sz = Some Wasm.Memory.Pack8}) in + let allocPayload n = compile_unboxed_const n ^^ alloc env ^^ set_utf8 ^^ get_utf8 in + UnboxedSmallWord.unbox_codepoint ^^ + set_c ^^ + get_c ^^ + compile_unboxed_const 0x80l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + (allocPayload 1l ^^ storeLeader 0b00000000l 0l) + begin + get_c ^^ + compile_unboxed_const 0x800l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + begin + allocPayload 2l ^^ storeFollower 1l 0l ^^ + get_utf8 ^^ storeLeader 0b11000000l 6l + end + begin + get_c ^^ + compile_unboxed_const 0x10000l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtU)) ^^ + G.if_ (ValBlockType None) + begin + allocPayload 3l ^^ storeFollower 2l 0l ^^ + get_utf8 ^^ storeFollower 1l 6l ^^ + get_utf8 ^^ storeLeader 0b11100000l 12l + end + begin + allocPayload 4l ^^ storeFollower 3l 0l ^^ + get_utf8 ^^ storeFollower 2l 6l ^^ + get_utf8 ^^ storeFollower 1l 12l ^^ + get_utf8 ^^ storeLeader 0b11110000l 18l + end + end + end ^^ + get_utf8 + end (* String *) module Array = struct @@ -1793,8 +2010,7 @@ module Array = struct (* Then *) Opt.null (* Else *) - ( (* Get point to counter from closure *) - Closure.get ^^ Closure.load_data 0l ^^ + ( Closure.get ^^ Closure.load_data 0l ^^ (* Store increased counter *) get_i ^^ compile_add_const 1l ^^ @@ -1844,9 +2060,9 @@ module Array = struct ] @ element_instructions) let fake_object_idx_option env built_in_name = - let (set_i, get_i) = new_local env "array" in - set_i ^^ - Closure.fixed_closure env (E.built_in env built_in_name) [ get_i ] + let (set_array, get_array) = new_local env "array" in + set_array ^^ + Closure.fixed_closure env (E.built_in env built_in_name) [ get_array ] let fake_object_idx env = function | "get" -> Some (fake_object_idx_option env "array_get") @@ -3676,8 +3892,7 @@ let rec compile_binop env t op = let (set_res, get_res) = new_local env "res" in let mul = snd (compile_binop env t MulOp) in let square_recurse_with_shifted sanitize = - get_n ^^ get_exp ^^ compile_unboxed_const 1l ^^ - G.i (Binary (I32 I32Op.ShrU)) ^^ sanitize ^^ + get_n ^^ get_exp ^^ compile_shrU_const 1l ^^ sanitize ^^ pow () ^^ set_res ^^ get_res ^^ get_res ^^ mul in get_exp ^^ G.i (Test (I32 I32Op.Eqz)) ^^ G.if_ (StackRep.to_block_type env SR.UnboxedWord32) @@ -3738,7 +3953,7 @@ let rec compile_binop env t op = | Type.Prim Type.(Word8 | Word16 as ty), RotLOp -> UnboxedSmallWord.( Func.share_code2 env (name_of_type ty "rotl") (("n", I32Type), ("by", I32Type)) [I32Type] Wasm.Values.(fun env get_n get_by -> - let beside_adjust = compile_unboxed_const (Int32.sub 32l (shift_of_type ty)) ^^ G.i (Binary (I32 I32Op.ShrU)) in + let beside_adjust = compile_shrU_const (Int32.sub 32l (shift_of_type ty)) in get_n ^^ get_n ^^ beside_adjust ^^ G.i (Binary (I32 I32Op.Or)) ^^ get_by ^^ lsb_adjust ty ^^ clamp_shift_amount ty ^^ G.i (Binary (I32 I32Op.Rotl)) ^^ sanitize_word_result ty)) @@ -3823,16 +4038,17 @@ and compile_exp (env : E.t) exp = | DotE (e, ({it = Name n;_} as name)) -> SR.Vanilla, compile_exp_vanilla env e ^^ - begin match Array.fake_object_idx env n with - | None -> Object.load_idx env e.note.note_typ name - | Some array_code -> + begin + let obj = Object.load_idx env e.note.note_typ name in 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 e.note.note_typ name - ; Tagged.Array, get_o ^^ array_code ] - ) + let selective tag = function + | None -> [] | Some code -> [ tag, get_o ^^ code ] + in match selective Tagged.Array (Array.fake_object_idx env n) + @ selective Tagged.Text (Text.fake_object_idx env n) with + | [] -> obj + | l -> set_o ^^ get_o ^^ + Tagged.branch env (ValBlockType (Some I32Type)) + ((Tagged.Object, get_o ^^ obj) :: l) end | ActorDotE (e, ({it = Name n;_} as name)) -> SR.UnboxedReference, @@ -3886,8 +4102,7 @@ and compile_exp (env : E.t) exp = | "Char->Word32" -> SR.UnboxedWord32, compile_exp_vanilla env e ^^ - compile_unboxed_const 8l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.ShrU)) + UnboxedSmallWord.unbox_codepoint | "Word8->Nat" -> SR.UnboxedInt64, @@ -3923,8 +4138,7 @@ and compile_exp (env : E.t) exp = | "Word32->Char" -> SR.Vanilla, compile_exp_as env SR.UnboxedWord32 e ^^ - compile_unboxed_const 8l ^^ - G.i (Binary (Wasm.Values.I32 I32Op.Shl)) + UnboxedSmallWord.box_codepoint | "Int~hash" -> SR.UnboxedWord32, @@ -3954,6 +4168,11 @@ and compile_exp (env : E.t) exp = | "ctz16" -> SR.Vanilla, compile_exp_vanilla env e ^^ UnboxedSmallWord.ctz_kernel Type.Word16 | "ctz64" -> SR.UnboxedInt64, compile_exp_as env SR.UnboxedInt64 e ^^ G.i (Unary (Wasm.Values.I64 I64Op.Ctz)) + | "Char->Text" -> + SR.Vanilla, + compile_exp_vanilla env e ^^ + Text.prim_showChar env + | "printInt" -> SR.unit, compile_exp_vanilla env e ^^ @@ -3962,6 +4181,10 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_vanilla env e ^^ Dfinity.prim_print env + | "decodeUTF8" -> + SR.UnboxedTuple 2, + compile_exp_vanilla env e ^^ + Text.prim_decodeUTF8 env | _ -> (* Now try the binary prims, expecting a manifest tuple argument *) begin match e.it with @@ -4471,6 +4694,7 @@ and actor_lit outer_env this ds fs at = let env = E.mk_global (E.mode outer_env) (E.get_prelude outer_env) ClosureTable.table_end in if E.mode env = DfinityMode then Dfinity.system_imports env; + Text.common_funcs env; Array.common_funcs env; (* Allocate static positions for exported functions *) @@ -4607,6 +4831,7 @@ let compile mode module_name (prelude : Ir.prog) (progs : Ir.prog list) : extend let env = E.mk_global mode prelude ClosureTable.table_end in if E.mode env = DfinityMode then Dfinity.system_imports env; + Text.common_funcs env; Array.common_funcs env; let start_fun = compile_start_func env (prelude :: progs) in diff --git a/src/prelude.ml b/src/prelude.ml index e343f5545f2..21db6583103 100644 --- a/src/prelude.ml +++ b/src/prelude.ml @@ -31,7 +31,10 @@ class revrange(x : Nat, y : Nat) { next() : ?Nat { if (i <= y) null else {i -= 1; ?i} }; }; +func charToText(c : Char) : Text = (prim "Char->Text" : Char -> Text) c; + func printInt(x : Int) { (prim "printInt" : Int -> ()) x }; +func printChar(x : Char) { print (charToText x) }; func print(x : Text) { (prim "print" : Text -> ()) x }; // Hashing @@ -61,6 +64,7 @@ func word64ToInt(n : Word64) : Int = (prim "Word64->Int" : Word64 -> Int) n; func charToWord32(c : Char) : Word32 = (prim "Char->Word32" : Char -> Word32) c; func word32ToChar(w : Word32) : Char = (prim "Word32->Char" : Word32 -> Char) w; +func decodeUTF8(s : Text) : (Word32, Char) = (prim "decodeUTF8" : Text -> (Word32, Char)) s; // Exotic bitwise operations func shrsWord8(w : Word8, amount : Word8) : Word8 = (prim "shrs8" : (Word8, Word8) -> Word8) (w, amount); @@ -254,8 +258,25 @@ let prim = function | Word64 y -> Word64 (Word64.and_ y (Word64.shl 1L (as_word64 a))) | _ -> failwith "btst") + | "Char->Text" -> fun v k -> let str = match as_char v with + | c when c <= 0o177 -> String.make 1 (Char.chr c) + | code -> Wasm.Utf8.encode [code] + in k (Text str) | "print" -> fun v k -> Printf.printf "%s%!" (as_text v); k unit | "printInt" -> fun v k -> Printf.printf "%d%!" (Int.to_int (as_int v)); k unit + | "decodeUTF8" -> fun v k -> + let s = as_text v in + let take_and_mask bits offset = Int32.(logand (sub (shift_left 1l bits) 1l) (of_int (Char.code s.[offset]))) in + let classify_utf8_leader = + Int32.(function + | ch when logand ch (lognot 0b01111111l) = 0b00000000l -> [take_and_mask 7] + | ch when logand ch (lognot 0b00011111l) = 0b11000000l -> [take_and_mask 5; take_and_mask 6] + | ch when logand ch (lognot 0b00001111l) = 0b11100000l -> [take_and_mask 4; take_and_mask 6; take_and_mask 6] + | ch when logand ch (lognot 0b00000111l) = 0b11110000l -> [take_and_mask 3; take_and_mask 6; take_and_mask 6; take_and_mask 6] + | _ -> failwith "decodeUTF8") in + let nobbles = List.mapi (fun i f -> f i) (classify_utf8_leader (Int32.of_int (Char.code s.[0]))) in + let code = List.fold_left Int32.(fun acc nobble -> logor (shift_left acc 6) nobble) 0l nobbles + in k (Tup [Word32 (Int32.of_int (List.length nobbles)); Char (Int32.to_int code)]) | "@serialize" -> fun v k -> k (Serialized v) | "@deserialize" -> fun v k -> k (as_serialized v) | "Array.init" -> fun v k -> diff --git a/src/type.ml b/src/type.ml index ffed970b78c..29eaf48fd1c 100644 --- a/src/type.ml +++ b/src/type.ml @@ -101,6 +101,12 @@ let array_obj t = | Mut t' -> Obj (Object Local, List.sort compare_field (mut t')) | t -> Obj (Object Local, List.sort compare_field (immut t)) +let text_obj = + let immut = + [ {lab = "chars"; typ = Func (Local, Returns, [], [], [iter_obj (Prim Char)])}; + {lab = "len"; typ = Func (Local, Returns, [], [], [Prim Nat])}; + ] in + Obj (Object Local, List.sort compare_field immut) (* Shifting *) @@ -278,6 +284,7 @@ let as_prim_sub p t = match promote t with let rec as_obj_sub lab t = match promote t with | Obj (s, tfs) -> s, tfs | Array t -> as_obj_sub lab (array_obj t) + | Prim Text -> as_obj_sub lab text_obj | Non -> Object Sharable, [{lab; typ = Non}] | _ -> invalid "as_obj_sub" let as_array_sub t = match promote t with diff --git a/src/value.ml b/src/value.ml index e264740a87e..7a7986f6e26 100644 --- a/src/value.ml +++ b/src/value.ml @@ -298,7 +298,21 @@ let obj_of_array a = Env.from_list ["get", get; "set", set; "len", len; "keys", keys; "vals", vals] -let as_obj = function Obj ve -> ve | Array a -> obj_of_array a | _ -> invalid "as_obj" +let obj_of_text t = + let chars = local_func 0 1 @@ fun v k -> + as_unit v; + let i = ref 0 in + let s = Wasm.Utf8.decode t in + let next = local_func 0 1 @@ fun v k' -> + if !i = List.length s then k' Null else + let v = Opt (Char (List.nth s !i)) in incr i; k' v + in k (Obj (Env.singleton "next" next)) in + let len = local_func 0 1 @@ fun v k -> + as_unit v; k (Int (Nat.of_int (List.length (Wasm.Utf8.decode t)))) in + + Env.from_list ["chars", chars; "len", len] + +let as_obj = function Obj ve -> ve | Array a -> obj_of_array a | Text t -> obj_of_text t | _ -> invalid "as_obj" let as_func = function Func (cc, f) -> cc, f | _ -> invalid "as_func" let as_async = function Async a -> a | _ -> invalid "as_async" let as_mut = function Mut r -> r | _ -> invalid "as_mut" 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 index bc31b890000..e9abc3dcbac 100644 --- a/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok +++ b/test/run-dfinity/ok/array-out-of-bounds.dvm-run.ok @@ -1,2 +1,2 @@ -W, hypervisor: calling func$92 failed with trap message: Uncaught RuntimeError: unreachable W, hypervisor: calling func$98 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$104 failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok index bb97c60cb2a..45847ddb83e 100644 --- a/test/run-dfinity/ok/nary-async.wasm.stderr.ok +++ b/test/run-dfinity/ok/nary-async.wasm.stderr.ok @@ -1,5 +1,5 @@ deserialize: T/77 -prelude:103.1-128.2: internal error, File "compile.ml", line 2477, characters 21-27: Assertion failed +prelude:107.1-132.2: internal error, File "compile.ml", line 2693, characters 21-27: Assertion failed Last environment: @new_async = func @@ -10,6 +10,7 @@ btstWord16 = func btstWord32 = func btstWord64 = func btstWord8 = func +charToText = func charToWord32 = func clzWord16 = func clzWord32 = func @@ -19,6 +20,7 @@ ctzWord16 = func ctzWord32 = func ctzWord64 = func ctzWord8 = func +decodeUTF8 = func hashInt = func ignore = func intToWord16 = func @@ -34,6 +36,7 @@ popcntWord32 = func popcntWord64 = func popcntWord8 = func print = func +printChar = func printInt = func range = func revrange = func diff --git a/test/run-dfinity/ok/overflow.dvm-run.ok b/test/run-dfinity/ok/overflow.dvm-run.ok index 95eb31c1554..63e039d9bb0 100644 --- a/test/run-dfinity/ok/overflow.dvm-run.ok +++ b/test/run-dfinity/ok/overflow.dvm-run.ok @@ -1,5 +1,5 @@ -W, hypervisor: calling func$104 failed with trap message: Uncaught RuntimeError: unreachable W, hypervisor: calling func$110 failed with trap message: Uncaught RuntimeError: unreachable +W, hypervisor: calling func$116 failed with trap message: Uncaught RuntimeError: unreachable This is reachable. This is reachable. This is reachable. diff --git a/test/run/conversions.as b/test/run/conversions.as index 60afd31f484..472dd48517c 100644 --- a/test/run/conversions.as +++ b/test/run/conversions.as @@ -157,4 +157,11 @@ assert(charToWord32 '\u{10ffff}' == (0x10FFFF : Word32)); roundtrip 100000; roundtrip 1000000; roundtrip 0x10FFFF; // largest code point -} +}; + + +// Char <--> Text + +assert(charToText 'П' == "П"); +func snd((a : Word32, b : Char)) : Char = b; +assert(snd (decodeUTF8 "П") =='П'); diff --git a/test/run/ok/text-iter.run-ir.ok b/test/run/ok/text-iter.run-ir.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run-ir.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.run-low.ok b/test/run/ok/text-iter.run-low.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run-low.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.run.ok b/test/run/ok/text-iter.run.ok new file mode 100644 index 00000000000..5ac6300d553 --- /dev/null +++ b/test/run/ok/text-iter.run.ok @@ -0,0 +1,20 @@ +via `print`: +hello world! + +via iteration and `printChar`: #1 +hello world! + +via iteration and `printChar`: #2 +1:'h' 2:'e' 3:'l' 4:'l' 5:'o' 6:' ' 7:'w' 8:'o' 9:'r' 10:'l' 11:'d' 12:'!' 13:' +' +via iteration and `printChar` (Unicode): #3 +1:'П' 2:'р' 3:'и' 4:'в' 5:'е' 6:'т' 7:'с' 8:'т' 9:'в' 10:'у' 11:'ю' 12:',' 13:' ' 14:'м' 15:'и' 16:'р' 17:'!' 18:' +' +via iteration and `printChar` (Unicode): #4 +1:'🙈' 2:'🎸' 3:'😋' +Приветствую, мир! + +2 +П +4 +🙈 diff --git a/test/run/ok/text-iter.wasm-run.ok b/test/run/ok/text-iter.wasm-run.ok new file mode 100644 index 00000000000..7033c807320 --- /dev/null +++ b/test/run/ok/text-iter.wasm-run.ok @@ -0,0 +1 @@ +_out/text-iter.wasm:0x___: runtime trap: unreachable executed diff --git a/test/run/text-iter.as b/test/run/text-iter.as new file mode 100644 index 00000000000..36f987b9392 --- /dev/null +++ b/test/run/text-iter.as @@ -0,0 +1,72 @@ +let s = "hello world!\n"; + +print "via `print`:\n"; +print s; +print "\n"; + +print "via iteration and `printChar`: #1\n"; +for (a in s.chars()) { + printChar a; +}; +print "\n"; + +print "via iteration and `printChar`: #2\n"; +var x = 0; +for (a in s.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; + +let russian = "Приветствую, мир!\n"; +assert(russian.len() == 18); + +print "via iteration and `printChar` (Unicode): #3\n"; +x := 0; +for (a in russian.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; +assert(x == 18); + +let emojis = "🙈🎸😋"; +assert(emojis.len() == 3); + +print "via iteration and `printChar` (Unicode): #4\n"; +x := 0; +for (a in emojis.chars()) { + x += 1; + printInt x; + print ":"; + printChar '\''; + printChar a; + printChar '\''; + print " "; +}; +print "\n"; +assert(x == 3); + +{ + let (len, c) = decodeUTF8 russian; + print russian; print "\n"; + printInt (word32ToInt len); print "\n"; + printChar c; print "\n"; +}; + +{ + let (len, c) = decodeUTF8 emojis; + assert ((len == (4 : Word32)) and (c == '\u{1f648}')); + printInt (word32ToInt len); print "\n"; + printChar c; print "\n"; +}; From 703850c573a9ba9b313440105bd42759ae74c7d8 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 25 Mar 2019 23:06:51 +0100 Subject: [PATCH 72/76] Switch `dev` to master (PR got merged) --- default.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/default.nix b/default.nix index b06b074fa86..60691f3ee33 100644 --- a/default.nix +++ b/default.nix @@ -35,8 +35,8 @@ let real-dvm = then let dev = builtins.fetchGit { url = "ssh://git@github.com/dfinity-lab/dev"; - ref = "joachim/more-logging"; - rev = "70d3b158611c96fe5e82b66d4a62c9d02bcd5345"; + ref = "master"; + rev = "55724569782676b1e08fdce265b7daddaeaec860"; }; in (import dev {}).dvm else null From 2b83bbbc3e05ed94161573a8030b8442208bc353 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 25 Mar 2019 23:18:32 +0100 Subject: [PATCH 73/76] nix: Tighten file-includes whitelist --- default.nix | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/default.nix b/default.nix index 60691f3ee33..ac2abd61328 100644 --- a/default.nix +++ b/default.nix @@ -95,9 +95,10 @@ rec { "test/" "test/.*Makefile.*" "test/quick.mk" - "test/(run.*|fail)/" - "test/(run.*|fail)/.*.as" - "test/(run.*|fail)/ok/.*" + "test/(fail|run|run-dfinity)/" + "test/(fail|run|run-dfinity)/.*.as" + "test/(fail|run|run-dfinity)/ok/" + "test/(fail|run|run-dfinity)/ok/.*.ok" "test/.*.sh" "samples/" "samples/.*" @@ -154,9 +155,10 @@ rec { "test/" "test/.*Makefile.*" "test/quick.mk" - "test/(run.*|fail)/" - "test/(run.*|fail)/.*.as" - "test/(run.*|fail)/ok/.*" + "test/(fail|run|run-dfinity)/" + "test/(fail|run|run-dfinity)/.*.as" + "test/(fail|run|run-dfinity)/ok/" + "test/(fail|run|run-dfinity)/ok/.*.ok" "test/.*.sh" "samples/" "samples/.*" From 885e1071bf805c89dbbf27e6fdd8e69b69a722df Mon Sep 17 00:00:00 2001 From: Gabor Greif Date: Wed, 27 Mar 2019 00:42:28 +0100 Subject: [PATCH 74/76] Eliminators for tagged heap objects (#273) * `tagged` now won't have a default * `tagged_with` and `tagged_default_with` pass the scrutinee to the handler code on the stack Semantics: - branch_default --> tag may be not covered, needs default - branch --> known tag - _branch_default_with --> each leg also has the TOS, tag may be not covered, needs default - branch_with --> each leg also has the TOS, known tag --- src/compile.ml | 39 ++++++++++++------- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 2 +- 2 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src/compile.ml b/src/compile.ml index a2dc9cf229b..8047c06ac62 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -920,8 +920,27 @@ module Tagged = struct set_tag ^^ go cases - let branch env retty (cases : (tag * G.t) list) : G.t = - branch_default env retty (G.i Unreachable) cases + (* like branch_default but the tag is known statically *) + let branch env retty = function + | [] -> failwith "branch" + | [_, code] -> G.i Drop ^^ code + | (_, code) :: cases -> branch_default env retty code cases + + (* like branch_default but also pushes the scrutinee on the stack for the + * branch's consumption *) + let _branch_default_with env retty def cases = + let (set_o, get_o) = new_local env "o" in + let prep (t, code) = (t, get_o ^^ code) + in set_o ^^ get_o ^^ branch_default env retty def (List.map prep cases) + + (* like branch_default_with but the tag is known statically *) + let branch_with env retty = function + | [] -> failwith "branch_with" + | [_, code] -> code + | (_, code) :: cases -> + let (set_o, get_o) = new_local env "o" in + let prep (t, code) = (t, get_o ^^ code) + in set_o ^^ get_o ^^ branch_default env retty (get_o ^^ code) (List.map prep cases) let obj env tag element_instructions : G.t = Heap.obj env @@ @@ -4038,18 +4057,12 @@ and compile_exp (env : E.t) exp = | DotE (e, ({it = Name n;_} as name)) -> SR.Vanilla, compile_exp_vanilla env e ^^ - begin - let obj = Object.load_idx env e.note.note_typ name in - let (set_o, get_o) = new_local env "o" in let selective tag = function - | None -> [] | Some code -> [ tag, get_o ^^ code ] - in match selective Tagged.Array (Array.fake_object_idx env n) - @ selective Tagged.Text (Text.fake_object_idx env n) with - | [] -> obj - | l -> set_o ^^ get_o ^^ - Tagged.branch env (ValBlockType (Some I32Type)) - ((Tagged.Object, get_o ^^ obj) :: l) - end + | None -> [] | Some code -> [ tag, code ] + in Tagged.branch_with env (ValBlockType (Some I32Type)) + (List.concat [ [Tagged.Object, Object.load_idx env e.note.note_typ name] + ; selective Tagged.Array (Array.fake_object_idx env n) + ; selective Tagged.Text (Text.fake_object_idx env n)]) | ActorDotE (e, ({it = Name n;_} as name)) -> SR.UnboxedReference, if E.mode env <> DfinityMode then G.i Unreachable else diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok index 45847ddb83e..7578b4ea4b8 100644 --- a/test/run-dfinity/ok/nary-async.wasm.stderr.ok +++ b/test/run-dfinity/ok/nary-async.wasm.stderr.ok @@ -1,5 +1,5 @@ deserialize: T/77 -prelude:107.1-132.2: internal error, File "compile.ml", line 2693, characters 21-27: Assertion failed +prelude:107.1-132.2: internal error, File "compile.ml", line 2712, characters 21-27: Assertion failed Last environment: @new_async = func From c56e500e1dd620d078ee21f923472eab720de0a3 Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 18 Mar 2019 17:59:39 +0100 Subject: [PATCH 75/76] Rule out messages with abstract types in the type checker MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit My work-in-progress implementation of type-based serialization `assert`s `false` when it encounters such, but it is much nicer to just rule them out statically. I updated some tests that were using abstract types in messages, but were (I believe) testing something else to use concrete types. The test case should outline what it allows and what it forbids. Interesting design decisions: * I only check that parameters, arguments and return types are concrete upon a shared function definition and shared function calls, but not within any type annotation. The main purpose is to still allow type definitions to have abstract types in these places, as long as they are made concrete when they are used. This allows type X = shared B -> () // abstract type in arguments func foo ( f: X ) = {f 5} // now a concrete type * I do not explicitly forbid shared functions to have type parameter lists. Because of the other check this is only possible if the type parameters are not used (i.e. are phantom), so doesn’t matter in practice. But there is also no hard reason to forbid them right now. We *could* make `is_concrete` return `true` for functions and actors, if we want, because their representation is independent of the types of the arguments/fields. This is a neat observation, but probably more confusing than relevant, so I am *not* doing that. The implementation of `is_concrete` uses the same memoization technique like `rel_typ` to deal with recursive types, and may diverge when there is non-uniform recursion (but so will the code generation for serialization). --- src/check_ir.ml | 23 ++++++-- src/type.ml | 44 ++++++++++++++- src/type.mli | 3 +- src/typing.ml | 40 +++++++++---- test/fail/abstract-msgs.as | 35 ++++++++++++ test/fail/asyncret2.as | 2 +- test/fail/asyncret3.as | 2 +- test/fail/ok/abstract-msgs.tc.ok | 14 +++++ test/fail/ok/asyncret1.tc.ok | 2 +- test/fail/ok/asyncret2.tc.ok | 6 +- test/fail/ok/asyncret3.tc.ok | 2 +- test/run-dfinity/nary-async.as | 2 + test/run-dfinity/ok/nary-async.dvm-run.ok | 1 - test/run-dfinity/ok/nary-async.run-ir.ok | 4 +- test/run-dfinity/ok/nary-async.run-low.ok | 4 +- test/run-dfinity/ok/nary-async.run.ok | 4 +- test/run-dfinity/ok/nary-async.wasm.stderr.ok | 56 ------------------- 17 files changed, 152 insertions(+), 92 deletions(-) create mode 100644 test/fail/abstract-msgs.as create mode 100644 test/fail/ok/abstract-msgs.tc.ok delete mode 100644 test/run-dfinity/ok/nary-async.wasm.stderr.ok diff --git a/src/check_ir.ml b/src/check_ir.ml index 331651ed0a6..2d26b1943df 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -123,6 +123,10 @@ let check_shared env at t = else check env at (T.sub t T.Shared) "message argument is not sharable:\n %s" (T.string_of_typ_expand t) +let check_concrete env at t = + check env at (T.is_concrete t) + "message argument is not concrete:\n %s" (T.string_of_typ_expand t) + let rec check_typ env typ : unit = match typ with | T.Pre -> @@ -372,16 +376,22 @@ let rec check_exp env (exp:Ir.exp) : unit = check_exp env exp2; (* TODO: check call_conv (assuming there's something to check) *) let t1 = T.promote (typ exp1) in - let tbs, t2, t3 = - try T.as_func_sub (List.length insts) t1 with + let _, tbs, t2, t3 = + try T.as_func_sub call_conv.Value.sort (List.length insts) t1 with | Invalid_argument _ -> error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand t1) in check_inst_bounds env tbs insts exp.at; check_exp env exp2; - typ exp2 <: T.open_ insts t2; - T.open_ insts t3 <: t; + let t_arg = T.open_ insts t2 in + let t_ret = T.open_ insts t3 in + if (call_conv.Value.sort = T.Sharable) then begin + check_concrete env exp.at t_arg; + check_concrete env exp.at t_ret; + end; + typ exp2 <: t_arg; + t_ret <: t; | BlockE (ds, exp1) -> let scope = gather_block_decs env ds in let env' = adjoin env scope in @@ -487,6 +497,7 @@ let rec check_exp env (exp:Ir.exp) : unit = check ((cc.Value.sort = T.Sharable && Type.is_async ret_ty) ==> isAsyncE exp) "shared function with async type has non-async body"; + if (cc.Value.sort = T.Sharable) then check_concrete env exp.at ret_ty; let env'' = {env' with labs = T.Env.empty; rets = Some ret_ty; async = false} in check_exp (adjoin_vals env'' ve) exp; @@ -496,6 +507,10 @@ let rec check_exp env (exp:Ir.exp) : unit = let ts2 = if cc.Value.n_res = 1 then [ret_ty] else T.as_seq ret_ty in + if (cc.Value.sort = T.Sharable) then begin + List.iter (check_concrete env exp.at) ts1; + List.iter (check_concrete env exp.at) ts2; + end; let fun_ty = T.Func ( cc.Value.sort, cc.Value.control , tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2 diff --git a/src/type.ml b/src/type.ml index 29eaf48fd1c..2939eb7f195 100644 --- a/src/type.ml +++ b/src/type.ml @@ -306,9 +306,9 @@ let as_pair_sub t = match promote t with | Tup [t1; t2] -> t1, t2 | Non -> Non, Non | _ -> invalid "as_pair_sub" -let as_func_sub n t = match promote t with - | Func (_, _, tbs, ts1, ts2) -> tbs, seq ts1, seq ts2 - | Non -> Lib.List.make n {var = "X"; bound = Any}, Any, Non +let as_func_sub default_s default_arity t = match promote t with + | Func (s, _, tbs, ts1, ts2) -> s, tbs, seq ts1, seq ts2 + | Non -> default_s, Lib.List.make default_arity {var = "X"; bound = Any}, Any, Non | _ -> invalid "as_func_sub" let as_mono_func_sub t = match promote t with | Func (_, _, [], ts1, ts2) -> seq ts1, seq ts2 @@ -387,6 +387,44 @@ let avoid cons t = if cons = ConSet.empty then t else avoid' cons t +(* Checking for concrete types *) + +module TS = Set.Make (struct type t = typ let compare = compare end) + +(* +This check is a stop-gap measure until we have an IDL strategy that +allows polymorphic types, see #250. It is not what we desire for ActorScript. +*) + +let is_concrete t = + let seen = ref TS.empty in (* break the cycles *) + let rec go t = + TS.mem t !seen || + begin + seen := TS.add t !seen; + match t with + | Var _ -> assert false + | (Prim _ | Any | Non | Shared | Pre) -> true + | Con (c, ts) -> + begin match Con.kind c with + | Abs _ -> false + | Def (tbs,t) -> go (open_ ts t) (* TBR this may fail to terminate *) + end + | Array t -> go t + | Tup ts -> List.for_all go ts + | Func (s, c, tbs, ts1, ts2) -> + let ts = open_binds tbs in + List.for_all go (List.map (open_ ts) ts1) && + List.for_all go (List.map (open_ ts) ts2) + | Opt t -> go t + | Async t -> go t + | Obj (s, fs) -> List.for_all (fun f -> go f.typ) fs + | Mut t -> go t + | Serialized t -> go t + end + in go t + + (* Equivalence & Subtyping *) diff --git a/src/type.mli b/src/type.mli index 9f41e972794..37cc11163a0 100644 --- a/src/type.mli +++ b/src/type.mli @@ -92,7 +92,7 @@ val as_opt_sub : typ -> typ val as_tup_sub : int -> typ -> typ list val as_unit_sub : typ -> unit val as_pair_sub : typ -> typ * typ -val as_func_sub : int -> typ -> bind list * typ * typ +val as_func_sub : sharing -> int -> typ -> sharing * bind list * typ * typ val as_mono_func_sub : typ -> typ * typ val as_async_sub : typ -> typ @@ -120,6 +120,7 @@ val promote : typ -> typ exception Unavoidable of con val avoid : ConSet.t -> typ -> typ (* raise Unavoidable *) +val is_concrete : typ -> bool (* Equivalence and Subtyping *) diff --git a/src/typing.ml b/src/typing.ml index 42b86f4d825..e0aeeda523f 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -171,9 +171,9 @@ and check_typ' env typ : T.typ = | [] -> () | [T.Async t2] -> if not (T.sub t2 T.Shared) then - error env typ1.at "shared function has non-shared result type\n %s" + error env typ2.at "shared function has non-shared result type\n %s" (T.string_of_typ_expand t2); - | _ -> error env typ1.at "shared function has non-async result type\n %s" + | _ -> error env typ2.at "shared function has non-async result type\n %s" (T.string_of_typ_expand (T.seq ts2)) ) end; @@ -470,12 +470,18 @@ and infer_exp'' env exp : T.typ = if not (T.sub t1 T.Shared) then error env pat.at "shared function has non-shared parameter type\n %s" (T.string_of_typ_expand t1); + if not (T.is_concrete t1) then + error env pat.at "shared function parameter contains abstract type\n %s" + (T.string_of_typ_expand t1); begin match t2 with | T.Tup [] -> () | T.Async t2 -> if not (T.sub t2 T.Shared) then error env typ.at "shared function has non-shared result type\n %s" (T.string_of_typ_expand t2); + if not (T.is_concrete t2) then + error env typ.at "shared function result contains abstract type\n %s" + (T.string_of_typ_expand t2); if not (isAsyncE exp) then error env exp.at "shared function with async type has non-async body" | _ -> error env typ.at "shared function has non-async result type\n %s" @@ -494,15 +500,27 @@ and infer_exp'' env exp : T.typ = T.Func (sort.it, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) | CallE (exp1, insts, exp2) -> let t1 = infer_exp_promote env exp1 in - (try - let tbs, t2, t = T.as_func_sub (List.length insts) t1 in - let ts = check_inst_bounds env tbs insts exp.at in - if not env.pre then check_exp env (T.open_ ts t2) exp2; - T.open_ ts t - with Invalid_argument _ -> - error env exp1.at "expected function type, but expression produces type\n %s" - (T.string_of_typ_expand t1) - ) + let sort, tbs, t_arg, t_ret = + try T.as_func_sub T.Local (List.length insts) t1 + with Invalid_argument _ -> + error env exp1.at "expected function type, but expression produces type\n %s" + (T.string_of_typ_expand t1) + in + let ts = check_inst_bounds env tbs insts exp.at in + let t_arg = T.open_ ts t_arg in + let t_ret = T.open_ ts t_ret in + if not env.pre then begin + check_exp env t_arg exp2; + if sort = T.Sharable then begin + if not (T.is_concrete t_arg) then + error env exp1.at "shared function argument contains abstract type\n %s" + (T.string_of_typ_expand t_arg); + if not (T.is_concrete t_ret) then + error env exp2.at "shared function call result contains abstract type\n %s" + (T.string_of_typ_expand t_ret); + end + end; + t_ret | BlockE decs -> let t, scope = infer_block env decs exp.at in (try T.avoid scope.con_env t with T.Unavoidable c -> diff --git a/test/fail/abstract-msgs.as b/test/fail/abstract-msgs.as new file mode 100644 index 00000000000..10d5e595e45 --- /dev/null +++ b/test/fail/abstract-msgs.as @@ -0,0 +1,35 @@ +// In function definitions, parameters with abstract types are not fine +{ shared func foo( x : A ) : () = (); }; +{ shared func foo() : ?A = null; }; +{ func foo() : () = { + { shared func bar( x : A ) : () = (); }; + { shared func bar() : async ?A { null } }; +}}; + +// In function calls, parameters with abstract types are not fine +{ func foo( f : shared A -> (), x : A ) = (f x); }; +{ func foo( f : shared () -> async A ) : async A = async { await (f ())}; }; + +// Just in types, away from definitinos and calls, parameters with abstract types are fine +{ let x : ?(shared A -> ()) = null; }; +{ let x : ?(shared () -> async A) = null; }; +{ let x : ?((shared A -> ()) -> ()) = null; }; +{ let x : ?((shared () -> async A) -> ()) = null; }; + + +// This is mostly because type aliases can have message arguments with type +// variables, as long as they are instantiated with concrete types. So this +// whould be fine: +{ type X = shared B -> (); + shared func foo ( f: X ) = (); +}; + +// But this not +{ type X = shared B -> (); + func foo() { shared func foo(f: X) = (); () } +}; + +// Also, phantom parameters are fine +{ type X = shared () -> (); + func foo() { shared func foo(f: X) = (); () } +}; diff --git a/test/fail/asyncret2.as b/test/fail/asyncret2.as index 7bc988fbe3e..60aa284698e 100644 --- a/test/fail/asyncret2.as +++ b/test/fail/asyncret2.as @@ -1 +1 @@ -func call3(f : shared () -> async B) : async B { f(); }; +func call3(f : shared () -> async Int) : async Int { f(); }; diff --git a/test/fail/asyncret3.as b/test/fail/asyncret3.as index 01b5a29b418..5883d109b8d 100644 --- a/test/fail/asyncret3.as +++ b/test/fail/asyncret3.as @@ -1 +1 @@ -shared func call4(f : shared () -> async B) : async B = f(); +shared func call4(f : shared () -> async Int) : async Int = f(); diff --git a/test/fail/ok/abstract-msgs.tc.ok b/test/fail/ok/abstract-msgs.tc.ok new file mode 100644 index 00000000000..f1619b120dd --- /dev/null +++ b/test/fail/ok/abstract-msgs.tc.ok @@ -0,0 +1,14 @@ +abstract-msgs.as:2.31-2.40: type error, shared function parameter contains abstract type + A/1 +abstract-msgs.as:3.36-3.38: type error, shared function has non-async result type + ?A/3 +abstract-msgs.as:5.20-5.29: type error, shared function parameter contains abstract type + A/5 +abstract-msgs.as:6.25-6.33: type error, shared function result contains abstract type + ?A/5 +abstract-msgs.as:10.58-10.59: type error, shared function argument contains abstract type + A/7 +abstract-msgs.as:11.82-11.84: type error, shared function call result contains abstract type + async A/9 +abstract-msgs.as:29.44-29.53: type error, shared function parameter contains abstract type + X/1 = shared A/19 -> () diff --git a/test/fail/ok/asyncret1.tc.ok b/test/fail/ok/asyncret1.tc.ok index d19068c4431..8dfc6b7f512 100644 --- a/test/fail/ok/asyncret1.tc.ok +++ b/test/fail/ok/asyncret1.tc.ok @@ -1,2 +1,2 @@ -asyncret1.as:1.36-1.38: type error, shared function has non-async result type +asyncret1.as:1.42-1.43: type error, shared function has non-async result type C diff --git a/test/fail/ok/asyncret2.tc.ok b/test/fail/ok/asyncret2.tc.ok index c323bd2a7ec..c9e51a16899 100644 --- a/test/fail/ok/asyncret2.tc.ok +++ b/test/fail/ok/asyncret2.tc.ok @@ -1,4 +1,4 @@ -asyncret2.as:1.63-1.66: type error, expression of type - async B/1 +asyncret2.as:1.54-1.57: type error, expression of type + async Int cannot produce expected type - B/1 + Int diff --git a/test/fail/ok/asyncret3.tc.ok b/test/fail/ok/asyncret3.tc.ok index 5cdd96a69bf..9bd82d6175d 100644 --- a/test/fail/ok/asyncret3.tc.ok +++ b/test/fail/ok/asyncret3.tc.ok @@ -1 +1 @@ -asyncret3.as:1.70-1.73: type error, shared function with async type has non-async body +asyncret3.as:1.61-1.64: type error, shared function with async type has non-async body diff --git a/test/run-dfinity/nary-async.as b/test/run-dfinity/nary-async.as index 3d7009061a6..5f2ae4c65c4 100644 --- a/test/run-dfinity/nary-async.as +++ b/test/run-dfinity/nary-async.as @@ -121,6 +121,7 @@ let _ : async (Int,) = async { */ +/* Disabled: No generic messages are supported func Generic(t:Text, x:T,eq:(T,T)->Bool) { shared func fu_u(x:T) : async T { @@ -143,3 +144,4 @@ Generic<()>("<()>\n", (), func eq(i:(),j:()) : Bool = true); Generic<(Int,Bool)>("<(Int,Bool)>\n", (1,true), func eq((i,b):(Int,Bool), (j,c):(Int,Bool)) : Bool = i == j and b == c); +*/ diff --git a/test/run-dfinity/ok/nary-async.dvm-run.ok b/test/run-dfinity/ok/nary-async.dvm-run.ok index 861a4fd347e..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.dvm-run.ok +++ b/test/run-dfinity/ok/nary-async.dvm-run.ok @@ -1,4 +1,3 @@ -W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable 0_0 1_0 2_0 diff --git a/test/run-dfinity/ok/nary-async.run-ir.ok b/test/run-dfinity/ok/nary-async.run-ir.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run-ir.ok +++ b/test/run-dfinity/ok/nary-async.run-ir.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.run-low.ok b/test/run-dfinity/ok/nary-async.run-low.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run-low.ok +++ b/test/run-dfinity/ok/nary-async.run-low.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.run.ok b/test/run-dfinity/ok/nary-async.run.ok index 5b2baf03eb2..3df16532e56 100644 --- a/test/run-dfinity/ok/nary-async.run.ok +++ b/test/run-dfinity/ok/nary-async.run.ok @@ -6,6 +6,4 @@ 0_1 0_2 0_3 -!! -<()> -<(Int,Bool)> +!! diff --git a/test/run-dfinity/ok/nary-async.wasm.stderr.ok b/test/run-dfinity/ok/nary-async.wasm.stderr.ok deleted file mode 100644 index 7578b4ea4b8..00000000000 --- a/test/run-dfinity/ok/nary-async.wasm.stderr.ok +++ /dev/null @@ -1,56 +0,0 @@ -deserialize: T/77 -prelude:107.1-132.2: internal error, File "compile.ml", line 2712, characters 21-27: Assertion failed - -Last environment: -@new_async = func -Array_init = func -Array_tabulate = func -abs = func -btstWord16 = func -btstWord32 = func -btstWord64 = func -btstWord8 = func -charToText = func -charToWord32 = func -clzWord16 = func -clzWord32 = func -clzWord64 = func -clzWord8 = func -ctzWord16 = func -ctzWord32 = func -ctzWord64 = func -ctzWord8 = func -decodeUTF8 = func -hashInt = func -ignore = func -intToWord16 = func -intToWord32 = func -intToWord64 = func -intToWord8 = func -natToWord16 = func -natToWord32 = func -natToWord64 = func -natToWord8 = func -popcntWord16 = func -popcntWord32 = func -popcntWord64 = func -popcntWord8 = func -print = func -printChar = func -printInt = func -range = func -revrange = func -shrsWord16 = func -shrsWord32 = func -shrsWord64 = func -shrsWord8 = func -word16ToInt = func -word16ToNat = func -word32ToChar = func -word32ToInt = func -word32ToNat = func -word64ToInt = func -word64ToNat = func -word8ToInt = func -word8ToNat = func - From c81e3250b05ffaa29d15ccb26805c37dac6a7973 Mon Sep 17 00:00:00 2001 From: Paul Young Date: Thu, 28 Mar 2019 10:56:50 -0700 Subject: [PATCH 76/76] Change Server class to actor So that all other definitions are moved inside of it by the compiler, since it's the last actor. See the Jira ticket for details. AST-73 --- stdlib/examples/produce-exchange/serverActor.as | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stdlib/examples/produce-exchange/serverActor.as b/stdlib/examples/produce-exchange/serverActor.as index cbc335372ac..8e03022fb3e 100644 --- a/stdlib/examples/produce-exchange/serverActor.as +++ b/stdlib/examples/produce-exchange/serverActor.as @@ -4,7 +4,7 @@ -------------------- */ -actor class Server() { +actor { /** PESS: Server Actor