diff --git a/src/compile.ml b/src/compile.ml index 8a8ad22c173..7c77c1c4a15 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -30,6 +30,35 @@ let nr_ x = { it = x; at = no_region; note = () } let todo fn se x = Printf.eprintf "%s: %s" fn (Wasm.Sexpr.to_string 80 se); x +module SR = struct + (* This goes with the StackRep module, but we need the types earlier *) + + (* Statically known values: They are not put on the stack, but the + “stack representation“ carries the static information. + *) + type static_thing = + | StaticFun of int32 + + (* Value representation on the stack: + + Compiling an expression means putting its value on the stack. But + there are various ways of putting a value onto the stack -- unboxed, + tupled etc. + *) + type t = + | Vanilla + | UnboxedTuple of int + | UnboxedInt + | UnboxedReference + | Unreachable + | StaticThing of static_thing + + let unit = UnboxedTuple 0 + + let bool = Vanilla + +end (* SR *) + (* ** The compiler environment. @@ -91,8 +120,8 @@ type 'env varloc = produce a value on demand: *) and 'env deferred_loc = - { allocate : 'env -> G.t - ; is_direct_call : int32 option (* To optimize known calls. *) + { materialize : 'env -> (SR.t * G.t) + ; materialize_vanilla : 'env -> G.t } module E = struct @@ -126,6 +155,7 @@ module E = struct (* Immutable *) local_vars_env : t varloc NameEnv.t; (* variables ↦ their location *) + con_env : Type.con_env; (* Mutable *) func_types : func_type list ref; @@ -157,6 +187,7 @@ module E = struct mode; prelude; local_vars_env = NameEnv.empty; + con_env = Con.Env.empty; func_types = ref []; imports = ref []; exports = ref []; @@ -196,8 +227,22 @@ module E = struct (* We avoid accessing the fields of t directly from outside of E, so here are a bunch of accessors. *) - let mode (e : t) = e.mode + let mode (env : t) = env.mode + + let con_env (env : t) = env.con_env + let add_con (env : t) c k = + { env with con_env = Con.Env.add c k env.con_env } + + let add_typ_binds (env : t) typ_binds = + (* There is some code duplication with Check_ir.check_open_typ_binds. + This shoulds be extracte into Type.add_open_typ_binds + and maybe we need a type open_typ_bind that can be used inside the IR. + *) + let cs = Check_ir.cons_of_typ_binds typ_binds in + let ks = List.map (fun tp -> Type.Abs([],tp.it.Type.bound)) typ_binds in + let ce = List.fold_right2 Con.Env.add cs ks Con.Env.empty in + { env with con_env = Con.Env.adjoin env.con_env ce } let lookup_var env var = match NameEnv.find_opt var env.local_vars_env with @@ -229,6 +274,12 @@ module E = struct let add_local_deferred (env : t) name d = { env with local_vars_env = NameEnv.add name (Deferred d) env.local_vars_env } + 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 + { env with local_vars_env = NameEnv.add name (Deferred d) env.local_vars_env } + let add_direct_local (env : t) name = let i = add_anon_local env I32Type in add_local_name env i name; @@ -438,12 +489,39 @@ module Heap = struct (* Memory addresses are 32 bit (I32Type). *) let word_size = 4l + (* WebAssembly pages are 64kb. *) + let page_size = Int32.of_int (64*1024) + (* We keep track of the end of the used heap in this global, and bump it if we allocate stuff. *) let heap_global = 2l let get_heap_ptr = G.i (GlobalGet (nr heap_global)) let set_heap_ptr = G.i (GlobalSet (nr heap_global)) + (* Page allocation. Ensures that the memory up to the heap pointer is allocated. *) + let grow_memory env = + Func.share_code env "grow_memory" [] [] (fun env -> + let (set_pages_needed, get_pages_needed) = new_local env "pages_needed" in + get_heap_ptr ^^ compile_divU_const page_size ^^ + compile_add_const 1l ^^ + G.i MemorySize ^^ + G.i (Binary (Wasm.Values.I32 I32Op.Sub)) ^^ + set_pages_needed ^^ + + (* Check that the new heap pointer is within the memory *) + get_pages_needed ^^ + compile_unboxed_const 0l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.GtU)) ^^ + G.if_ (ValBlockType None) + ( get_pages_needed ^^ + G.i MemoryGrow ^^ + (* Check result *) + compile_unboxed_const 0l ^^ + G.i (Compare (Wasm.Values.I32 I32Op.LtS)) ^^ + G.if_ (ValBlockType None) (G.i Unreachable) G.nop + ) G.nop + ) + (* Dynamic allocation *) let dyn_alloc_words env = Func.share_code env "alloc_words" ["n", I32Type] [I32Type] (fun env -> @@ -453,13 +531,11 @@ module Heap = struct get_heap_ptr ^^ (* Update heap pointer *) - get_n ^^ - compile_mul_const word_size ^^ - - (* Add to old heap value *) get_heap_ptr ^^ + get_n ^^ compile_mul_const word_size ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ - set_heap_ptr + set_heap_ptr ^^ + grow_memory env ) let dyn_alloc_bytes env = @@ -789,7 +865,7 @@ module Var = struct (* When accessing a variable that is a static function, then we need to create a heap-allocated closure-like thing on the fly. *) - let static_fun_pointer fi env = + let static_fun_pointer env fi = Tagged.obj env Tagged.Closure [ compile_unboxed_const fi; compile_unboxed_const 0l (* number of parameters: none *) @@ -825,13 +901,18 @@ module Var = struct | Some (Deferred d) -> G.i Unreachable | None -> G.i Unreachable - (* Returns the payload *) - let get_val env var = match E.lookup_var env var with - | Some (Local i) -> G.i (LocalGet (nr i)) - | Some (HeapInd (i, off)) -> G.i (LocalGet (nr i)) ^^ Heap.load_field off + (* Returns the payload (vanialla 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 | Some (Static i) -> compile_unboxed_const i ^^ load_ptr - | Some (Deferred d) -> d.allocate env - | None -> G.i Unreachable + | Some (Deferred d) -> d.materialize_vanilla env + | None -> G.i Unreachable + + (* Returns the payload (optimized representation) *) + let get_val env var = match E.lookup_var env var with + | Some (Deferred d) -> d.materialize env + | _ -> SR.Vanilla, get_val_vanilla env var (* Returns the value to put in the closure, and code to restore it, including adding to the environment @@ -864,9 +945,11 @@ module Var = struct *) let field_box env code = Tagged.obj env Tagged.ObjInd [ code ] + let get_val_ptr env var = match E.lookup_var env var with | Some (HeapInd (i, 1l)) -> G.i (LocalGet (nr i)) - | _ -> field_box env (get_val env var) + | _ -> field_box env (get_val_vanilla env var) + end (* Var *) module Opt = struct @@ -1118,14 +1201,15 @@ module Object = struct │ tag │ n_fields │ field_hash1 │ field_data1 │ … │ └─────┴──────────┴─────────────┴─────────────┴───┘ - The field_data are pointers to either an ObjInd, or a MutBox (they - have the same layout). This indirection is a consequence of how we - compile object literals with `await` instructions, as these mutable + The field_data for immutable fields simply point to the value. + + The field_data for mutable fields are pointers to either an ObjInd, or a + MutBox (they have the same layout). This indirection is a consequence of + how we compile object literals with `await` instructions, as these mutable fields need to be able to alias local mutal variables. - We could (and eventually should) use the type information to avoid this - indirection for immutable fields. Or switch to an allocate-first approach - in the await-translation of objects, and get rid of this indirection. + We could alternatively switch to an allocate-first approach in the + await-translation of objects, and get rid of this indirection. *) let header_size = Int32.add Tagged.header_size 1l @@ -1140,6 +1224,7 @@ module Object = struct module FieldEnv = Env.Make(String) (* This is for non-recursive objects, i.e. ObjNewE *) + (* The instructions in the field already create the indirection if needed *) let lit_raw env fs = let name_pos_map = fs |> @@ -1191,8 +1276,8 @@ module Object = struct (* Return the pointer to the object *) get_ri - (* Returns a pointer to the object field *) - let idx_hash env = + (* Returns a pointer to the object field (without following the indirection) *) + let idx_hash_raw env = Func.share_code env "obj_idx" ["x", I32Type; "hash", I32Type] [I32Type] (fun env -> let get_x = G.i (LocalGet (nr 0l)) in let get_hash = G.i (LocalGet (nr 1l)) in @@ -1217,9 +1302,6 @@ module Object = struct G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ^^ G.if_ (ValBlockType None) ( get_f ^^ - compile_add_const Heap.word_size ^^ - (* dereference the indirection *) - load_ptr ^^ compile_add_const Heap.word_size ^^ set_r ) G.nop @@ -1227,11 +1309,37 @@ module Object = struct get_r ) - let idx env name = + (* Returns a pointer to the object field (possibly following the indirection) *) + let idx_hash env indirect = + if indirect + then Func.share_code env "obj_idx_ind" ["x", I32Type; "hash", I32Type] [I32Type] (fun env -> + let get_x = G.i (LocalGet (nr 0l)) in + let get_hash = G.i (LocalGet (nr 1l)) in + get_x ^^ get_hash ^^ + idx_hash_raw env ^^ + load_ptr ^^ compile_add_const Heap.word_size + ) + else idx_hash_raw env + + (* Determines whether the field is mutable (and thus needs an indirection) *) + let is_mut_field env obj_type ({it = Syntax.Name s; _}) = + let _, fields = Type.as_obj_sub "" (E.con_env env) obj_type in + let field_typ = Type.lookup_field s fields in + let mut = Type.is_mut field_typ in + mut + + let idx env obj_type name = compile_unboxed_const (hash_field_name name) ^^ - idx_hash env + idx_hash env (is_mut_field env obj_type name) - let load_idx env f = idx env f ^^ load_ptr + let load_idx env obj_type f = + 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 *) @@ -1477,8 +1585,7 @@ module Array = struct set_ni ^^ Object.lit_raw env1 - [ (nr_ (Syntax.Name "next"), - fun _ -> Var.field_box env1 get_ni) ] + [ nr_ (Syntax.Name "next"), fun _ -> get_ni ] ) in E.define_built_in env "array_keys_next" @@ -1906,6 +2013,7 @@ module OrthogonalPersistence = struct get_i ^^ compile_add_const ElemHeap.table_end ^^ Heap.set_heap_ptr ^^ + Heap.grow_memory env ^^ (* Load memory *) compile_unboxed_const ElemHeap.table_end ^^ @@ -2425,6 +2533,7 @@ module Serialization = struct (* Reset the heap counter, to free some space *) get_start ^^ Heap.set_heap_ptr ^^ + Heap.grow_memory env ^^ (* Finally, create elembuf *) get_end ^^ @@ -2460,7 +2569,12 @@ module Serialization = struct get_elembuf ^^ G.i (Call (nr (Dfinity.elem_length_i env))) ^^ set_tbl_size ^^ - (* First load databuf (last entry) at the heap position somehow *) + (* Get scratch space (one word) *) + Heap.alloc env 1l ^^ G.i Drop ^^ + get_start ^^ Heap.set_heap_ptr ^^ + + (* First load databuf reference (last entry) at the heap position somehow *) + (* now load the databuf *) get_start ^^ compile_unboxed_const 1l ^^ get_elembuf ^^ @@ -2472,6 +2586,10 @@ module Serialization = struct get_databuf ^^ G.i (Call (nr (Dfinity.data_length_i env))) ^^ set_data_len ^^ + (* Get some scratch space *) + get_data_len ^^ Heap.dyn_alloc_bytes env ^^ G.i Drop ^^ + get_start ^^ Heap.set_heap_ptr ^^ + (* Load data from databuf *) get_start ^^ get_data_len ^^ @@ -2492,6 +2610,7 @@ module Serialization = struct get_data_len ^^ G.i (Binary (Wasm.Values.I32 I32Op.Add)) ^^ Heap.set_heap_ptr ^^ + Heap.grow_memory env ^^ (* Fix pointers *) get_start ^^ @@ -2660,6 +2779,99 @@ module GC = struct end (* GC *) +module StackRep = struct + open SR + + (* + Most expression have a “preferred”, most optimal, form. Hence, + compile_exp put them on the stack in that form, and also returns + the form it chose. + + But the users of compile_exp usually want a specific form as well. + So they use compile_exp_as, indicating the form they expect. + compile_exp_as then does the necessary coercions. + *) + + let of_arity n = + if n = 1 then Vanilla else UnboxedTuple n + + (* The stack rel of a primitive type, i.e. what the binary operators expect *) + let of_type : Type.typ -> t = function + | Type.Prim Type.Bool -> bool + | Type.Prim Type.Nat -> UnboxedInt + | Type.Prim Type.Int -> UnboxedInt + | Type.Prim Type.Text -> Vanilla + | p -> todo "of_type" (Arrange_ir.typ p) Vanilla + + let to_block_type env = function + | Vanilla -> ValBlockType (Some I32Type) + | UnboxedInt -> ValBlockType (Some I64Type) + | UnboxedReference -> ValBlockType (Some I32Type) + | UnboxedTuple 0 -> ValBlockType None + | UnboxedTuple 1 -> ValBlockType (Some I32Type) + | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) + | StaticThing _ -> ValBlockType None + | Unreachable -> ValBlockType None + + let to_string = function + | Vanilla -> "Vanilla" + | UnboxedInt -> "UnboxedInt" + | UnboxedReference -> "UnboxedReference" + | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n + | Unreachable -> "Unreachable" + | StaticThing _ -> "StaticThing" + + let join (sr1 : t) (sr2 : t) = match sr1, sr2 with + | Unreachable, sr2 -> sr2 + | sr1, Unreachable -> sr1 + | UnboxedInt, UnboxedInt -> UnboxedInt + | UnboxedReference, UnboxedReference -> UnboxedReference + | UnboxedTuple n, UnboxedTuple m when n = m -> sr1 + | _, Vanilla -> Vanilla + | Vanilla, _ -> Vanilla + | _, _ -> + Printf.eprintf "Invalid stack rep join (%s, %s)\n" + (to_string sr1) (to_string sr2); sr1 + + let drop env (sr_in : t) = + match sr_in with + | Vanilla -> G.i Drop + | UnboxedInt -> G.i Drop + | UnboxedReference -> G.i Drop + | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) + | StaticThing _ -> G.nop + | Unreachable -> G.nop + + let materialize env = function + | StaticFun fi -> Var.static_fun_pointer env fi + + let adjust env (sr_in : t) sr_out = + if sr_in = sr_out + then G.nop + else match sr_in, sr_out with + | Unreachable, Unreachable -> G.nop + | Unreachable, _ -> G.i Unreachable + + | UnboxedTuple n, Vanilla -> Tuple.from_stack env n + | Vanilla, UnboxedTuple n -> Tuple.to_stack env n + + | UnboxedInt, Vanilla -> BoxedInt.box env + | Vanilla, UnboxedInt -> BoxedInt.unbox env + + | UnboxedReference, Vanilla -> Dfinity.box_reference env + | Vanilla, UnboxedReference -> Dfinity.unbox_reference env + + | StaticThing s, Vanilla -> materialize env s + | StaticThing s, UnboxedTuple 0 -> G.nop + + | _, _ -> + Printf.eprintf "Unknown stack_rep conversion %s -> %s\n" + (to_string sr_in) (to_string sr_out); + G.nop + +end (* StackRep *) + + (* This comes late because it also deals with messages *) module FuncDec = struct (* We use the first table slot for calls to funcrefs *) @@ -2694,7 +2906,7 @@ module FuncDec = struct ] ) - let static_self_message_pointer name env = + let static_self_message_pointer env name = Dfinity.compile_databuf_of_bytes env name.it ^^ export_self_message env @@ -2791,7 +3003,10 @@ module FuncDec = struct (* Compile a closed function declaration (has no free variables) *) let dec_closed pre_env cc name mk_pat mk_body at = let (fi, fill) = E.reserve_fun pre_env name.it in - let d = { allocate = Var.static_fun_pointer fi; is_direct_call = Some fi } in + let d = + { materialize = (fun env -> (SR.StaticThing (SR.StaticFun fi), G.nop)) + ; materialize_vanilla = (fun env -> Var.static_fun_pointer env fi) + } in let pre_env1 = E.add_local_deferred pre_env name.it d in ( pre_env1, G.nop, fun env -> let restore_no_env env1 _ = (env1, G.nop) in @@ -2805,7 +3020,7 @@ module FuncDec = struct let is_local = cc.Value.sort <> Type.Sharable in let (set_li, get_li) = new_local pre_env (name.it ^ "_clos") in - let (pre_env1, alloc_code0) = AllocHow.add_how pre_env name.it h in + let (pre_env1, alloc_code0) = AllocHow.add_how pre_env name.it (Some h) in let len = Wasm.I32.of_int_u (List.length captured) in let alloc_code = @@ -2903,108 +3118,10 @@ module FuncDec = struct assert is_local; dec_closed pre_env cc name mk_pat mk_body at | Some h -> - dec_closure pre_env cc (Some h) name captured mk_pat mk_body at + dec_closure pre_env cc h name captured mk_pat mk_body at end (* FuncDec *) -module StackRep = struct - - (* Value representation on the stack: - - Compiling an expression means putting its value on the stack. But - there are various ways of putting a value onto the stack -- unboxed, - tupled etc. - *) - type t = - | Vanilla - | UnboxedTuple of int - | UnboxedInt - | UnboxedReference - | Unreachable - - let unit = UnboxedTuple 0 - - let bool = Vanilla - - (* - Most expression have a “preferred”, most optimal, form. Hence, - compile_exp put them on the stack in that form, and also returns - the form it chose. - - But the users of compile_exp usually want a specific form as well. - So they use compile_exp_as, indicating the form they expect. - compile_exp_as then does the necessary coercions. - *) - - let of_arity n = - if n = 1 then Vanilla else UnboxedTuple n - - (* The stack rel of a primitive type, i.e. what the binary operators expect *) - let of_type : Type.typ -> t = function - | Type.Prim Type.Bool -> bool - | Type.Prim Type.Nat -> UnboxedInt - | Type.Prim Type.Int -> UnboxedInt - | Type.Prim Type.Text -> Vanilla - | p -> todo "of_type" (Arrange_ir.typ p) Vanilla - - let to_block_type env = function - | Vanilla -> ValBlockType (Some I32Type) - | UnboxedInt -> ValBlockType (Some I64Type) - | UnboxedReference -> ValBlockType (Some I32Type) - | UnboxedTuple 0 -> ValBlockType None - | UnboxedTuple 1 -> ValBlockType (Some I32Type) - | UnboxedTuple n -> VarBlockType (nr (E.func_type env (FuncType ([], Lib.List.make n I32Type)))) - | Unreachable -> ValBlockType None - - let to_string = function - | Vanilla -> "Vanilla" - | UnboxedInt -> "UnboxedInt" - | UnboxedReference -> "UnboxedReference" - | UnboxedTuple n -> Printf.sprintf "UnboxedTuple %d" n - | Unreachable -> "Unreachable" - - let join (sr1 : t) (sr2 : t) = match sr1, sr2 with - | Unreachable, sr2 -> sr2 - | sr1, Unreachable -> sr1 - | UnboxedInt, UnboxedInt -> UnboxedInt - | UnboxedReference, UnboxedReference -> UnboxedReference - | UnboxedTuple n, UnboxedTuple m when n = m -> sr1 - | _, Vanilla -> Vanilla - | Vanilla, _ -> Vanilla - | _, _ -> - Printf.eprintf "Invalid stack rep join (%s, %s)\n" - (to_string sr1) (to_string sr2); sr1 - - let drop env (sr_in : t) = - match sr_in with - | Vanilla -> G.i Drop - | UnboxedInt -> G.i Drop - | UnboxedReference -> G.i Drop - | UnboxedTuple n -> G.table n (fun _ -> G.i Drop) - | Unreachable -> G.nop - - let adjust env (sr_in : t) sr_out = - if sr_in = sr_out - then G.nop - else match sr_in, sr_out with - | Unreachable, Unreachable -> G.nop - | Unreachable, _ -> G.i Unreachable - - | UnboxedTuple n, Vanilla -> Tuple.from_stack env n - | Vanilla, UnboxedTuple n -> Tuple.to_stack env n - - | UnboxedInt, Vanilla -> BoxedInt.box env - | Vanilla, UnboxedInt -> BoxedInt.unbox env - - | UnboxedReference, Vanilla -> Dfinity.box_reference env - | Vanilla, UnboxedReference -> Dfinity.unbox_reference env - - | _, _ -> - Printf.eprintf "Unknown stack_rep conversion %s -> %s\n" - (to_string sr_in) (to_string sr_out); - G.nop -end - module PatCode = struct (* Pattern failure code on demand. @@ -3068,18 +3185,18 @@ open PatCode let compile_lit env lit = Syntax.(match lit with (* Booleans are directly in Vanilla representation *) - | BoolLit false -> StackRep.bool, Bool.lit false - | BoolLit true -> StackRep.bool, Bool.lit true + | BoolLit false -> SR.bool, Bool.lit false + | BoolLit true -> SR.bool, Bool.lit true (* This maps int to int32, instead of a proper arbitrary precision library *) - | IntLit n -> StackRep.UnboxedInt, + | IntLit n -> SR.UnboxedInt, (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) - | NatLit n -> StackRep.UnboxedInt, + | NatLit n -> SR.UnboxedInt, (try compile_const_64 (Big_int.int64_of_big_int n) with Failure _ -> Printf.eprintf "compile_lit: Overflow in literal %s\n" (Big_int.string_of_big_int n); G.i Unreachable) - | NullLit -> StackRep.Vanilla, Opt.null - | TextLit t -> StackRep.Vanilla, Text.lit env t - | _ -> todo "compile_lit" (Arrange.lit lit) (StackRep.Vanilla, 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) ) let compile_lit_as env sr_out lit = @@ -3088,7 +3205,7 @@ let compile_lit_as env sr_out lit = let compile_unop env t op = Syntax.(match op with | NegOp -> - StackRep.UnboxedInt, + SR.UnboxedInt, Func.share_code env "neg" ["n", I64Type] [I64Type] (fun env -> let get_n = G.i (LocalGet (nr 0l)) in compile_const_64 0L ^^ @@ -3096,9 +3213,9 @@ let compile_unop env t op = Syntax.(match op with G.i (Binary (Wasm.Values.I64 I64Op.Sub)) ) | PosOp -> - StackRep.UnboxedInt, + SR.UnboxedInt, G.nop - | _ -> todo "compile_unop" (Arrange.unop op) (StackRep.Vanilla, G.i Unreachable) + | _ -> todo "compile_unop" (Arrange.unop op) (SR.Vanilla, G.i Unreachable) ) (* This returns a single StackRep, to be used for both arguments and the @@ -3114,7 +3231,7 @@ let compile_binop env t op = let get_n1 = G.i (LocalGet (nr 0l)) in let get_n2 = G.i (LocalGet (nr 1l)) in get_n1 ^^ get_n2 ^^ G.i (Compare (Wasm.Values.I64 I64Op.LtU)) ^^ - G.if_ (StackRep.to_block_type env StackRep.UnboxedInt) + G.if_ (StackRep.to_block_type env SR.UnboxedInt) (G.i Unreachable) (get_n1 ^^ get_n2 ^^ G.i (Binary (Wasm.Values.I64 I64Op.Sub))) ) @@ -3141,7 +3258,7 @@ let compile_relop env t op = Syntax.(match t, op with | _, EqOp -> compile_eq env t | _, NeqOp -> compile_eq env t ^^ - G.if_ (StackRep.to_block_type env StackRep.bool) + 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)) @@ -3165,14 +3282,14 @@ let rec compile_lexp (env : E.t) exp = Var.set_val env var.it | IdxE (e1,e2) -> compile_exp_vanilla env e1 ^^ (* offset to array *) - compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) + compile_exp_as env SR.UnboxedInt e2 ^^ (* idx *) G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ Array.idx env, store_ptr | DotE (e, n) -> compile_exp_vanilla env e ^^ (* Only real objects have mutable fields, no need to branch on the tag *) - Object.idx env n, + Object.idx env e.note.note_typ n, store_ptr | _ -> todo "compile_lexp" (Arrange_ir.exp exp) (G.i Unreachable, G.nop) @@ -3180,35 +3297,35 @@ and compile_exp (env : E.t) exp = (fun (sr,code) -> (sr, G.with_region exp.at code)) @@ match exp.it with | IdxE (e1, e2) -> - StackRep.Vanilla, + SR.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to array *) - compile_exp_as env StackRep.UnboxedInt e2 ^^ (* idx *) + compile_exp_as env SR.UnboxedInt e2 ^^ (* idx *) G.i (Convert (Wasm.Values.I32 I32Op.WrapI64)) ^^ Array.idx env ^^ load_ptr | DotE (e, ({it = Syntax.Name n;_} as name)) -> - StackRep.Vanilla, + SR.Vanilla, compile_exp_vanilla env e ^^ begin match Array.fake_object_idx env n with - | None -> Object.load_idx env name + | None -> Object.load_idx env e.note.note_typ name | Some array_code -> let (set_o, get_o) = new_local env "o" in set_o ^^ get_o ^^ Tagged.branch env (ValBlockType (Some I32Type)) ( - [ Tagged.Object, get_o ^^ Object.load_idx env name + [ Tagged.Object, get_o ^^ Object.load_idx env e.note.note_typ name ; Tagged.Array, get_o ^^ array_code ] ) end | ActorDotE (e, ({it = Syntax.Name n;_} as name)) -> - StackRep.UnboxedReference, + SR.UnboxedReference, if E.mode env <> DfinityMode then G.i Unreachable else - compile_exp_as env StackRep.UnboxedReference e ^^ + 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]; _}) -> - StackRep.Vanilla, + SR.Vanilla, begin compile_exp_vanilla env e1 ^^ compile_exp_vanilla env e2 ^^ @@ -3222,26 +3339,25 @@ and compile_exp (env : E.t) exp = begin match p with | "abs" -> - StackRep.Vanilla, + SR.Vanilla, compile_exp_vanilla env e ^^ Prim.prim_abs env | "printInt" -> - StackRep.unit, + SR.unit, compile_exp_vanilla env e ^^ Dfinity.prim_printInt env | "print" -> - StackRep.unit, + SR.unit, compile_exp_vanilla env e ^^ Dfinity.prim_print env | _ -> - StackRep.Unreachable, + SR.Unreachable, todo "compile_exp" (Arrange_ir.exp pe) (G.i Unreachable) end | VarE var -> - StackRep.Vanilla, Var.get_val env var.it | AssignE (e1,e2) -> - StackRep.unit, + SR.unit, let (prepare_code, store_code) = compile_lexp env e1 in prepare_code ^^ compile_exp_vanilla env e2 ^^ @@ -3249,8 +3365,8 @@ and compile_exp (env : E.t) exp = | LitE l -> compile_lit env l | AssertE e1 -> - StackRep.unit, - compile_exp_as env StackRep.bool e1 ^^ + SR.unit, + compile_exp_as env SR.bool e1 ^^ G.if_ (ValBlockType None) G.nop (G.i Unreachable) | UnE (t, op, e1) -> let sr, code = compile_unop env t op in @@ -3265,12 +3381,12 @@ and compile_exp (env : E.t) exp = code | RelE (t, e1, op, e2) -> let sr, code = compile_relop env t op in - StackRep.bool, + SR.bool, compile_exp_as env sr e1 ^^ compile_exp_as env sr e2 ^^ code | IfE (scrut, e1, e2) -> - let code_scrut = compile_exp_as env StackRep.bool scrut in + let code_scrut = compile_exp_as env SR.bool scrut in let sr1, code1 = compile_exp env e1 in let sr2, code2 = compile_exp env e2 in let sr = StackRep.join sr1 sr2 in @@ -3286,8 +3402,8 @@ and compile_exp (env : E.t) exp = or any of the nested returns. Hard to tell which is the best stack representation here. So let’s go with Vanialla. *) - StackRep.Vanilla, - G.block_ (StackRep.to_block_type env StackRep.Vanilla) ( + SR.Vanilla, + G.block_ (StackRep.to_block_type env SR.Vanilla) ( G.with_current_depth (fun depth -> let env1 = E.add_label env name depth in compile_exp_vanilla env1 e @@ -3295,49 +3411,49 @@ and compile_exp (env : E.t) exp = ) | BreakE (name, e) -> let d = E.get_label_depth env name in - StackRep.Unreachable, + SR.Unreachable, compile_exp_vanilla env e ^^ G.branch_to_ d | LoopE (e, None) -> - StackRep.Unreachable, + SR.Unreachable, G.loop_ (ValBlockType None) (compile_exp_unit env e ^^ G.i (Br (nr 0l)) ) ^^ G.i Unreachable | LoopE (e1, Some e2) -> - StackRep.unit, + SR.unit, G.loop_ (ValBlockType None) ( compile_exp_unit env e1 ^^ - compile_exp_as env StackRep.bool e2 ^^ + compile_exp_as env SR.bool e2 ^^ G.if_ (ValBlockType None) (G.i (Br (nr 1l))) G.nop ) | WhileE (e1, e2) -> - StackRep.unit, + SR.unit, G.loop_ (ValBlockType None) ( - compile_exp_as env StackRep.bool e1 ^^ + 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 -> - StackRep.Unreachable, + SR.Unreachable, compile_exp_as env (StackRep.of_arity (E.get_n_res env)) e ^^ G.i Return | OptE e -> - StackRep.Vanilla, + SR.Vanilla, Opt.inject env (compile_exp_vanilla env e) | TupE es -> - StackRep.UnboxedTuple (List.length es), + SR.UnboxedTuple (List.length es), G.concat_map (compile_exp_vanilla env) es | ProjE (e1,n) -> - StackRep.Vanilla, + SR.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to tuple (an array) *) Tuple.load_n (Int32.of_int n) | ArrayE (m, t, es) -> - StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) + SR.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) | ActorE (name, fs, _) -> - StackRep.UnboxedReference, + SR.UnboxedReference, let captured = Freevars.exp exp in let prelude_names = find_prelude_names env in if Freevars.M.is_empty (Freevars.diff captured prelude_names) @@ -3345,29 +3461,31 @@ and compile_exp (env : E.t) exp = else todo "non-closed actor" (Arrange_ir.exp exp) G.i Unreachable | CallE (cc, e1, _, e2) -> StackRep.of_arity (cc.Value.n_res), - begin match isDirectCall env e1, cc.Value.sort with - | Some fi, _ -> + let fun_sr, code1 = compile_exp env e1 in + begin match fun_sr, cc.Value.sort with + | SR.StaticThing (SR.StaticFun fi), _ -> + code1 ^^ compile_unboxed_zero ^^ (* A dummy closure *) compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ (* the args *) G.i (Call (nr fi)) - | None, Type.Local -> + | _, Type.Local -> let (set_clos, get_clos) = new_local env "clos" in - compile_exp_vanilla env e1 ^^ + code1 ^^ StackRep.adjust env fun_sr SR.Vanilla ^^ set_clos ^^ get_clos ^^ compile_exp_as env (StackRep.of_arity cc.Value.n_args) e2 ^^ get_clos ^^ Closure.call_closure env cc - | None, Type.Sharable -> + | _, Type.Sharable -> let (set_funcref, get_funcref) = new_local env "funcref" in - compile_exp_as env StackRep.UnboxedReference e1 ^^ + 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 ^^ FuncDec.call_funcref env cc get_funcref end | SwitchE (e, cs) -> - StackRep.Vanilla, + SR.Vanilla, let code1 = compile_exp_vanilla env e in let (set_i, get_i) = new_local env "switch_in" in let (set_j, get_j) = new_local env "switch_out" in @@ -3386,7 +3504,7 @@ and compile_exp (env : E.t) exp = let code2 = go env cs in code1 ^^ set_i ^^ orTrap code2 ^^ get_j | ForE (p, e1, e2) -> - StackRep.unit, + SR.unit, let code1 = compile_exp_vanilla env e1 in let (env1, alloc_code, code2) = compile_mono_pat env AllocHow.M.empty p in let code3 = compile_exp_unit env1 e2 in @@ -3398,9 +3516,9 @@ and compile_exp (env : E.t) exp = G.loop_ (ValBlockType None) ( get_i ^^ - Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ + Object.load_idx_immut env1 (nr_ (Syntax.Name "next")) ^^ get_i ^^ - Object.load_idx env1 (nr_ (Syntax.Name "next")) ^^ + Object.load_idx_immut env1 (nr_ (Syntax.Name "next")) ^^ Closure.call_closure env1 (Value.local_cc 0 1) ^^ let (set_oi, get_oi) = new_local env "opt" in set_oi ^^ @@ -3424,28 +3542,22 @@ and compile_exp (env : E.t) exp = G.i (LocalSet (nr i)) ^^ code | DefineE (name, _, e) -> - StackRep.unit, + SR.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it | NewObjE ({ it = Type.Object _ (*sharing*); _}, fs, _) -> - StackRep.Vanilla, - let fs' = List.map - (fun (name, id) -> (name, fun env -> Var.get_val_ptr env id.it)) - fs in + SR.Vanilla, + let fs' = fs |> List.map + (fun (name, id) -> (name, fun env -> + if Object.is_mut_field env exp.note.note_typ name + then Var.get_val_ptr env id.it + else Var.get_val_vanilla env id.it)) in Object.lit_raw env fs' - | _ -> StackRep.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i Unreachable) - -and isDirectCall env e = match e.it with - | VarE var -> - begin match E.lookup_var env var.it with - | Some (Deferred d) -> d.is_direct_call - | _ -> None - end - | _ -> None + | _ -> SR.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i Unreachable) and compile_exp_as env sr_out e = - let sr_in, code = compile_exp env e in G.with_region e.at ( + let sr_in, code = compile_exp env e in code ^^ StackRep.adjust env sr_in sr_out ) @@ -3459,10 +3571,10 @@ and compile_exp_as_opt env sr_out_o e = ) and compile_exp_vanilla (env : E.t) exp = - compile_exp_as env StackRep.Vanilla exp + compile_exp_as env SR.Vanilla exp and compile_exp_unit (env : E.t) exp = - compile_exp_as env StackRep.unit exp + compile_exp_as env SR.unit exp (* @@ -3496,7 +3608,7 @@ enabled mutual recursion. and compile_lit_pat env l = match l with | Syntax.NullLit -> - compile_lit_as env StackRep.Vanilla l ^^ + compile_lit_as env SR.Vanilla l ^^ G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | Syntax.BoolLit true -> G.nop @@ -3505,7 +3617,7 @@ and compile_lit_pat env l = G.i (Compare (Wasm.Values.I32 I32Op.Eq)) | Syntax.(NatLit _ | IntLit _) -> BoxedInt.unbox env ^^ - compile_lit_as env StackRep.UnboxedInt l ^^ + compile_lit_as env SR.UnboxedInt l ^^ compile_eq env (Type.Prim Type.Nat) | Syntax.(TextLit t) -> Text.lit env t ^^ @@ -3593,14 +3705,14 @@ and compile_n_ary_pat env how pat = | WildP -> None, G.nop (* The good case: We have a tuple pattern *) | TupP ps when List.length ps <> 1 -> - Some (StackRep.UnboxedTuple (List.length ps)), + Some (SR.UnboxedTuple (List.length ps)), (* We have to fill the pattern in reverse order, to take things off the stack. This is only ok as long as patterns have no side effects. *) G.concat_mapi (fun i p -> orTrap (fill_pat env1 p)) (List.rev ps) (* The general case: Create a single value, match that. *) | _ -> - Some StackRep.Vanilla, + Some SR.Vanilla, orTrap (fill_pat env1 pat) in (env1, alloc_code, arity, fill_code) @@ -3633,17 +3745,19 @@ and compile_func_pat env cc pat = orTrap (fill_pat env1 pat) in (env1, alloc_code, fill_code) -and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = +and compile_dec pre_env how dec : E.t * G.t * (E.t -> (SR.t * G.t)) = (fun (pre_env,alloc_code,mk_code) -> (pre_env, G.with_region dec.at alloc_code, fun env -> (fun (sr, code) -> (sr, G.with_region dec.at code)) (mk_code env))) @@ match dec.it with - | TypD _ -> (pre_env, G.nop, fun _ -> StackRep.unit, G.nop) - | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env e) + | TypD (c,k) -> + let pre_env1 = E.add_con pre_env c k in + (pre_env1, G.nop, fun _ -> SR.unit, G.nop) + | ExpD e ->(pre_env, G.nop, fun env -> compile_exp env e) | LetD (p, e) -> let (pre_env1, alloc_code, pat_arity, fill_code) = compile_n_ary_pat pre_env how p in ( pre_env1, alloc_code, fun env -> - StackRep.unit, + SR.unit, compile_exp_as_opt env pat_arity e ^^ fill_code ) @@ -3653,26 +3767,30 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) = let (pre_env1, alloc_code) = AllocHow.add_local pre_env how name.it in ( pre_env1, alloc_code, fun env -> - StackRep.unit, + SR.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it ) - | FuncD (cc, name, _, p, _rt, e) -> + | FuncD (cc, name, typ_binds, p, _rt, e) -> (* Get captured variables *) let captured = Freevars.captured p e in 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 let (pre_env1, alloc_code, mk_code) = FuncDec.dec pre_env how name cc captured mk_pat mk_body dec.at in (pre_env1, alloc_code, fun env -> - StackRep.Vanilla, mk_code env ^^ Var.get_val env name.it + (* Bring type parameters into scope *) + let env1 = E.add_typ_binds env typ_binds in + let sr, code = Var.get_val env1 name.it in + sr, mk_code env1 ^^ code ) -and compile_decs env decs : StackRep.t * G.t = snd (compile_decs_block env decs) +and compile_decs env decs : SR.t * G.t = + snd (compile_decs_block env decs) -and compile_decs_block env decs : (E.t * (StackRep.t * G.t)) = +and compile_decs_block env decs : (E.t * (SR.t * G.t)) = let how = AllocHow.decs env decs in let rec go pre_env decs = match decs with - | [] -> (pre_env, G.nop, fun _ -> (StackRep.unit, G.nop)) + | [] -> (pre_env, G.nop, fun _ -> (SR.unit, G.nop)) | [dec] -> compile_dec pre_env how dec | (dec::decs) -> let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env how dec in @@ -3742,8 +3860,8 @@ and compile_public_actor_field pre_env (f : Ir.exp_field) = name = Dfinity.explode name.it; edesc = nr (FuncExport (nr fi)) }); - let d = { allocate = FuncDec.static_self_message_pointer name; is_direct_call = None } in - let pre_env1 = E.add_local_deferred pre_env name.it d in + let pre_env1 = E.add_local_deferred_vanilla pre_env name.it + (fun env -> FuncDec.static_self_message_pointer env name) in ( pre_env1, fun env -> G.with_region f.at @@ let mk_pat inner_env = compile_func_pat inner_env cc pat in @@ -3783,8 +3901,7 @@ and actor_lit outer_env name fs at = let (env4, prelude_code) = compile_prelude env3 in (* Bind the self pointer *) - let d = { allocate = Dfinity.get_self_reference; is_direct_call = None } in - let env5 = E.add_local_deferred env4 name.it d in + let env5 = E.add_local_deferred_vanilla env4 name.it Dfinity.get_self_reference in let (_env6, init_code) = compile_actor_fields env5 fs in prelude_code ^^ init_code) in @@ -3848,6 +3965,8 @@ and conclude_module env module_name start_fi_o = init; }) (E.get_static_memory env) in + let mem_size = Int32.(add (div (E.get_end_of_static_memory env) Heap.page_size) 1l) in + { module_ = nr { types = List.map nr (E.get_types env); funcs = List.map (fun (f,_,_) -> f) funcs; @@ -3858,7 +3977,7 @@ and conclude_module env module_name start_fi_o = init = List.mapi (fun i _ -> nr (Wasm.I32.of_int_u (ni + i))) funcs } ]; start = start_fi_o; globals = globals; - memories = [nr {mtype = MemoryType {min = 1024l; max = None}} ]; + memories = [nr {mtype = MemoryType {min = mem_size; max = None}} ]; imports; exports = E.get_exports env; data diff --git a/test/debug.html b/test/debug.html index 78b39ab6863..10a97d51948 100644 --- a/test/debug.html +++ b/test/debug.html @@ -1,6 +1,12 @@ + +