From 9760437862db78e297da5ca99933544701e6390d Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Wed, 6 Feb 2019 12:09:37 +0100
Subject: [PATCH 1/9] Avoid allocating unused closures

---
 src/compile.ml  | 29 +++++++++++++++++++----------
 test/debug.html |  8 +++++++-
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 5b5e04d5def..ec4dead1804 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -3281,7 +3281,7 @@ and compile_exp (env : E.t) exp =
       (code1 ^^ StackRep.adjust env sr1 sr)
       (code2 ^^ StackRep.adjust env sr2 sr)
   | BlockE (decs,_) ->
-    compile_decs env decs
+    compile_decs env false decs
   | LabelE (name, _ty, e) ->
     (* The value here can come from many places -- the expression,
        or any of the nested returns. Hard to tell which is the best
@@ -3634,13 +3634,16 @@ 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 as_unit how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) =
   (fun (pre_env,alloc_code,mk_code) ->
        (pre_env, G.with_region dec.at alloc_code, fun env ->
          (fun (sr, code) -> (sr, G.with_region dec.at code)) (mk_code env))) @@
   match dec.it with
   | TypD _ -> (pre_env, G.nop, fun _ -> StackRep.unit, G.nop)
-  | ExpD e -> (pre_env, G.nop, fun env -> compile_exp env e)
+  | ExpD e -> (pre_env, G.nop, fun env ->
+    if as_unit
+    then StackRep.unit, compile_exp_unit env e
+    else 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 ->
@@ -3665,23 +3668,27 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) =
       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
+        if as_unit
+        then StackRep.unit, mk_code env
+        else StackRep.Vanilla, mk_code env ^^ Var.get_val env name.it
       )
 
-and compile_decs env decs : StackRep.t * G.t = snd (compile_decs_block env decs)
+and compile_decs env as_unit decs : StackRep.t * G.t =
+  snd (compile_decs_block env as_unit decs)
 
-and compile_decs_block env decs : (E.t * (StackRep.t * G.t)) =
+and compile_decs_block env as_unit decs : (E.t * (StackRep.t * G.t)) =
   let how = AllocHow.decs env decs in
   let rec go pre_env decs = match decs with
     | []          -> (pre_env, G.nop, fun _ -> (StackRep.unit, G.nop))
-    | [dec]       -> compile_dec pre_env how dec
+    | [dec]       -> compile_dec pre_env as_unit how dec
     | (dec::decs) ->
-        let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env how dec in
+        let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env true how dec in
         let (pre_env2, alloc_code2, mk_code2) = go          pre_env1 decs in
         ( pre_env2,
           alloc_code1 ^^ alloc_code2,
           fun env ->
             let (sr1, code1) = mk_code1 env in
+            assert (sr1 = StackRep.unit);
             let (sr2, code2) = mk_code2 env in
             (sr2, code1 ^^ StackRep.drop env sr1 ^^ code2)
          ) in
@@ -3691,7 +3698,8 @@ and compile_decs_block env decs : (E.t * (StackRep.t * G.t)) =
 
 and compile_prelude env =
   (* Allocate the primitive functions *)
-  let (env1, (sr, code)) = compile_decs_block env (E.get_prelude env).it in
+  let (env1, (sr, code)) = compile_decs_block env true (E.get_prelude env).it in
+  assert (sr = StackRep.unit);
   (env1, code ^^ StackRep.drop env sr)
 
 (* Is this a hack? When determining whether an actor is closed,
@@ -3711,8 +3719,9 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names =
       | [] -> G.nop
       | (prog::progs) ->
         G.with_region prog.at @@
-        let (env1, (sr, code1)) = compile_decs_block env prog.it in
+        let (env1, (sr, code1)) = compile_decs_block env true prog.it in
         let code2 = go env1 progs in
+        assert (sr = StackRep.unit);
         code1 ^^ StackRep.drop env1 sr ^^ code2 in
     go env1 progs
     )
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 @@
+<!-- run with
+python -m SimpleHTTPServer
+google-chrome --js-flags="--experimental-wasm-mv" http://127.0.0.1:8000/debug.html
+-->
+
 <html>
 <head>
   <script>
+  let file = 'run/_out/empty.wasm';
 
   async function createWebAssembly(path, importObject) {
     const result = await window.fetch(path);
@@ -23,7 +29,7 @@
     };
     const importObject = {env};
 
-    const wa = await createWebAssembly('while.wasm', importObject);
+    const wa = await createWebAssembly(file, importObject);
     exports = wa.instance.exports;
     console.info('got exports', exports);
 

From 345736ce2d3c5851929bd7f326c5e2d7c4e1c27f Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Wed, 6 Feb 2019 17:00:32 +0100
Subject: [PATCH 2/9] Actualy grow memory when needed

and start with a memory size that is just big enough for the static
memory.
---
 src/compile.ml        | 53 +++++++++++++++++++++++++++++++++++++------
 test/run/large-mem.as |  1 +
 2 files changed, 47 insertions(+), 7 deletions(-)
 create mode 100644 test/run/large-mem.as

diff --git a/src/compile.ml b/src/compile.ml
index ec4dead1804..51a3e69c3a4 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -438,12 +438,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 +480,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 =
@@ -1907,6 +1932,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 ^^
@@ -2426,6 +2452,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 ^^
@@ -2461,7 +2488,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 ^^
@@ -2473,6 +2505,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 ^^
@@ -2493,6 +2529,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 ^^
@@ -3858,6 +3895,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;
@@ -3868,7 +3907,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/run/large-mem.as b/test/run/large-mem.as
new file mode 100644
index 00000000000..dc0a4c63996
--- /dev/null
+++ b/test/run/large-mem.as
@@ -0,0 +1 @@
+ignore(Array_init<()>(64*1024, ()));

From 5cb507d0797ff2e2a84cab3178ba7c0995b1047c Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Wed, 6 Feb 2019 18:28:10 +0100
Subject: [PATCH 3/9] `compile`: Keep a `con_env` around
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

wasn’t as painful as I thought it might be. I just hope I got it
correct.
---
 src/compile.ml | 12 ++++++++++--
 1 file changed, 10 insertions(+), 2 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 51a3e69c3a4..404db54cf12 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -126,6 +126,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 +158,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 +198,12 @@ 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 lookup_var env var =
     match NameEnv.find_opt var env.local_vars_env with
@@ -3676,7 +3682,9 @@ and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)
        (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)
+  | TypD (c,k) ->
+    let pre_env1 = E.add_con pre_env c k in
+    (pre_env1, G.nop, fun _ -> StackRep.unit, G.nop)
   | ExpD e -> (pre_env, G.nop, fun env ->
     if as_unit
     then StackRep.unit, compile_exp_unit env e

From e66a92fcb1b33f1fe327811a27f96b1a09191461 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Wed, 6 Feb 2019 18:28:49 +0100
Subject: [PATCH 4/9] Avoid pointless indirection for immutable object fields

we still need the indirection for mutable fields, as they need to be
able to alias local mutable variables.
---
 src/compile.ml | 65 ++++++++++++++++++++++++++++++++------------------
 1 file changed, 42 insertions(+), 23 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 404db54cf12..314a951a606 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -895,9 +895,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)
+
 end (* Var *)
 
 module Opt = struct
@@ -1149,14 +1151,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.
   *)
 
   (* First word: Class pointer (0x1, an invalid pointer, when none) *)
@@ -1172,6 +1175,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 |>
@@ -1224,8 +1228,9 @@ module Object = struct
      get_ri
 
   (* Returns a pointer to the object field *)
-  let idx_hash env =
-    Func.share_code env "obj_idx" ["x", I32Type; "hash", I32Type] [I32Type] (fun env ->
+  let idx_hash env indirect =
+    let rts_fun_name = if indirect then "obj_idx_mut" else "obj_idx" in
+    Func.share_code env rts_fun_name ["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
       let (set_f, get_f) = new_local env "f" in
@@ -1251,19 +1256,32 @@ module Object = struct
           ( get_f ^^
             compile_add_const Heap.word_size ^^
             (* dereference the indirection *)
-            load_ptr ^^
-            compile_add_const Heap.word_size ^^
+            ( if indirect
+              then load_ptr ^^ compile_add_const Heap.word_size
+              else G.nop) ^^
             set_r
           ) G.nop
       ) ^^
       get_r
     )
 
-  let idx env name =
+  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 obj_type f =
+    idx env obj_type f ^^ load_ptr
 
-  let load_idx env f = idx env f ^^ load_ptr
+  let load_idx_immut env name =
+    compile_unboxed_const (hash_field_name name) ^^
+    idx_hash env false ^^
+    load_ptr
 
 end (* Object *)
 
@@ -1509,8 +1527,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"
@@ -3216,7 +3233,7 @@ let rec compile_lexp (env : E.t) exp =
   | 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)
 
@@ -3234,13 +3251,13 @@ and compile_exp (env : E.t) exp =
     StackRep.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
@@ -3442,9 +3459,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 ^^
@@ -3473,9 +3490,11 @@ and compile_exp (env : E.t) exp =
     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
+    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 env id.it)) in
     Object.lit_raw env fs'
   | _ -> StackRep.unit, todo "compile_exp" (Arrange_ir.exp exp) (G.i Unreachable)
 

From fb8e2be7017cdf94dbd66159579a4449d72b9c6c Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Thu, 7 Feb 2019 09:11:26 +0100
Subject: [PATCH 5/9] Refactor code around `Object.idx_hash` a bit

---
 src/compile.ml | 27 ++++++++++++++++++---------
 1 file changed, 18 insertions(+), 9 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 5f90685515e..f857e3f896d 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1226,10 +1226,9 @@ module Object = struct
      (* Return the pointer to the object *)
      get_ri
 
-  (* Returns a pointer to the object field *)
-  let idx_hash env indirect =
-    let rts_fun_name = if indirect then "obj_idx_mut" else "obj_idx" in
-    Func.share_code env rts_fun_name ["x", I32Type; "hash", I32Type] [I32Type] (fun 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
       let (set_f, get_f) = new_local env "f" in
@@ -1254,16 +1253,25 @@ module Object = struct
         G.if_ (ValBlockType None)
           ( get_f ^^
             compile_add_const Heap.word_size ^^
-            (* dereference the indirection *)
-            ( if indirect
-              then load_ptr ^^ compile_add_const Heap.word_size
-              else G.nop) ^^
             set_r
           ) G.nop
       ) ^^
       get_r
     )
 
+  (* 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
@@ -1275,7 +1283,8 @@ module Object = struct
     idx_hash env (is_mut_field env obj_type name)
 
   let load_idx env obj_type f =
-    idx env obj_type f ^^ load_ptr
+    idx env obj_type f ^^
+    load_ptr
 
   let load_idx_immut env name =
     compile_unboxed_const (hash_field_name name) ^^

From 0c4d6f64cb841d7932f65f7bdfc3fc4715c76b82 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Thu, 7 Feb 2019 10:17:56 +0100
Subject: [PATCH 6/9] Use the StackRep functionality to handle static values

for now, just static functions. This already introduced more direct
calls in the code :-)

It also prepares some ground for unboxed local variables.
---
 src/compile.ml | 426 ++++++++++++++++++++++++++-----------------------
 1 file changed, 229 insertions(+), 197 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index f857e3f896d..77892a2bab8 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
@@ -235,6 +264,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;
@@ -820,7 +855,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 *)
@@ -856,13 +891,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
@@ -898,7 +938,7 @@ module Var = struct
 
   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 *)
 
@@ -2729,6 +2769,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 *)
@@ -2763,7 +2896,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
 
@@ -2860,7 +2993,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
@@ -2976,104 +3112,6 @@ module FuncDec = struct
 
 end (* FuncDec *)
 
-module StackRep = struct
-
-  (* Value representation on the stack:
-
-     Compiling an expression means putting its value on the stack. But
-     there are various ways of putting a value onto the stack -- unboxed,
-     tupled etc.
-   *)
-  type t =
-    | Vanilla
-    | UnboxedTuple of int
-    | 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.
@@ -3137,18 +3175,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 =
@@ -3157,7 +3195,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 ^^
@@ -3165,9 +3203,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
@@ -3183,7 +3221,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)))
     )
@@ -3210,7 +3248,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))
@@ -3234,7 +3272,7 @@ 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
@@ -3249,14 +3287,14 @@ 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 e.note.note_typ name
@@ -3270,14 +3308,14 @@ and compile_exp (env : E.t) exp =
        )
     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 ^^
@@ -3291,26 +3329,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 ^^
@@ -3318,8 +3355,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
@@ -3334,12 +3371,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
@@ -3355,8 +3392,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
@@ -3364,49 +3401,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)
@@ -3414,29 +3451,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
@@ -3455,7 +3494,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
@@ -3493,30 +3532,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,
+    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 env id.it)) in
+        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
   )
 
@@ -3530,10 +3561,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
 
 
 (*
@@ -3567,7 +3598,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
@@ -3576,7 +3607,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 ^^
@@ -3664,14 +3695,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)
 
@@ -3704,22 +3735,22 @@ and compile_func_pat env cc pat =
         orTrap (fill_pat env1 pat) in
   (env1, alloc_code, fill_code)
 
-and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)) =
+and compile_dec pre_env as_unit 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 (c,k) ->
     let pre_env1 = E.add_con pre_env c k in
-    (pre_env1, G.nop, fun _ -> StackRep.unit, G.nop)
+    (pre_env1, G.nop, fun _ -> SR.unit, G.nop)
   | ExpD e -> (pre_env, G.nop, fun env ->
     if as_unit
-    then StackRep.unit, compile_exp_unit env e
+    then SR.unit, compile_exp_unit env e
     else 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
     )
@@ -3729,7 +3760,7 @@ and compile_dec pre_env as_unit 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
       )
@@ -3741,17 +3772,19 @@ and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (StackRep.t * G.t)
       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 ->
         if as_unit
-        then StackRep.unit, mk_code env
-        else StackRep.Vanilla, mk_code env ^^ Var.get_val env name.it
+        then SR.unit, mk_code env
+        else
+          let sr, code = Var.get_val env name.it in
+          sr, mk_code env ^^ code
       )
 
-and compile_decs env as_unit decs : StackRep.t * G.t =
+and compile_decs env as_unit decs : SR.t * G.t =
   snd (compile_decs_block env as_unit decs)
 
-and compile_decs_block env as_unit decs : (E.t * (StackRep.t * G.t)) =
+and compile_decs_block env as_unit 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 as_unit how dec
     | (dec::decs) ->
         let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env true how dec in
@@ -3760,7 +3793,7 @@ and compile_decs_block env as_unit decs : (E.t * (StackRep.t * G.t)) =
           alloc_code1 ^^ alloc_code2,
           fun env ->
             let (sr1, code1) = mk_code1 env in
-            assert (sr1 = StackRep.unit);
+            assert (sr1 = SR.unit);
             let (sr2, code2) = mk_code2 env in
             (sr2, code1 ^^ StackRep.drop env sr1 ^^ code2)
          ) in
@@ -3771,7 +3804,7 @@ and compile_decs_block env as_unit decs : (E.t * (StackRep.t * G.t)) =
 and compile_prelude env =
   (* Allocate the primitive functions *)
   let (env1, (sr, code)) = compile_decs_block env true (E.get_prelude env).it in
-  assert (sr = StackRep.unit);
+  assert (sr = SR.unit);
   (env1, code ^^ StackRep.drop env sr)
 
 (* Is this a hack? When determining whether an actor is closed,
@@ -3793,7 +3826,7 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names =
         G.with_region prog.at @@
         let (env1, (sr, code1)) = compile_decs_block env true prog.it in
         let code2 = go env1 progs in
-        assert (sr = StackRep.unit);
+        assert (sr = SR.unit);
         code1 ^^ StackRep.drop env1 sr ^^ code2 in
     go env1 progs
     )
@@ -3824,8 +3857,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
@@ -3865,8 +3898,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

From 613d9a6407b6181aa4ec35491c77a9c92d7567a9 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Thu, 7 Feb 2019 10:24:05 +0100
Subject: [PATCH 7/9] Remove the `as_unit` parameter from `compile_dec`

this should, in most cases, work just as well.
---
 src/compile.ml | 33 ++++++++++++---------------------
 1 file changed, 12 insertions(+), 21 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 77892a2bab8..9550222a05f 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -3386,7 +3386,7 @@ and compile_exp (env : E.t) exp =
       (code1 ^^ StackRep.adjust env sr1 sr)
       (code2 ^^ StackRep.adjust env sr2 sr)
   | BlockE (decs,_) ->
-    compile_decs env false decs
+    compile_decs env decs
   | LabelE (name, _ty, e) ->
     (* The value here can come from many places -- the expression,
        or any of the nested returns. Hard to tell which is the best
@@ -3735,7 +3735,7 @@ and compile_func_pat env cc pat =
         orTrap (fill_pat env1 pat) in
   (env1, alloc_code, fill_code)
 
-and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (SR.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))) @@
@@ -3743,10 +3743,7 @@ and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (SR.t * G.t)) =
   | 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 ->
-    if as_unit
-    then SR.unit, compile_exp_unit env e
-    else compile_exp env e)
+  | 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 ->
@@ -3771,29 +3768,25 @@ and compile_dec pre_env as_unit how dec : E.t * G.t * (E.t -> (SR.t * G.t)) =
       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 ->
-        if as_unit
-        then SR.unit, mk_code env
-        else
-          let sr, code = Var.get_val env name.it in
-          sr, mk_code env ^^ code
+        let sr, code = Var.get_val env name.it in
+        sr, mk_code env ^^ code
       )
 
-and compile_decs env as_unit decs : SR.t * G.t =
-  snd (compile_decs_block env as_unit decs)
+and compile_decs env decs : SR.t * G.t =
+  snd (compile_decs_block env decs)
 
-and compile_decs_block env as_unit decs : (E.t * (SR.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 _ -> (SR.unit, G.nop))
-    | [dec]       -> compile_dec pre_env as_unit how dec
+    | [dec]       -> compile_dec pre_env how dec
     | (dec::decs) ->
-        let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env true how dec in
+        let (pre_env1, alloc_code1, mk_code1) = compile_dec pre_env how dec in
         let (pre_env2, alloc_code2, mk_code2) = go          pre_env1 decs in
         ( pre_env2,
           alloc_code1 ^^ alloc_code2,
           fun env ->
             let (sr1, code1) = mk_code1 env in
-            assert (sr1 = SR.unit);
             let (sr2, code2) = mk_code2 env in
             (sr2, code1 ^^ StackRep.drop env sr1 ^^ code2)
          ) in
@@ -3803,8 +3796,7 @@ and compile_decs_block env as_unit decs : (E.t * (SR.t * G.t)) =
 
 and compile_prelude env =
   (* Allocate the primitive functions *)
-  let (env1, (sr, code)) = compile_decs_block env true (E.get_prelude env).it in
-  assert (sr = SR.unit);
+  let (env1, (sr, code)) = compile_decs_block env (E.get_prelude env).it in
   (env1, code ^^ StackRep.drop env sr)
 
 (* Is this a hack? When determining whether an actor is closed,
@@ -3824,9 +3816,8 @@ and compile_start_func env (progs : Ir.prog list) : E.func_with_names =
       | [] -> G.nop
       | (prog::progs) ->
         G.with_region prog.at @@
-        let (env1, (sr, code1)) = compile_decs_block env true prog.it in
+        let (env1, (sr, code1)) = compile_decs_block env prog.it in
         let code2 = go env1 progs in
-        assert (sr = SR.unit);
         code1 ^^ StackRep.drop env1 sr ^^ code2 in
     go env1 progs
     )

From 23baf999c39332ac10bc9396a29611cfaabc01b9 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Thu, 7 Feb 2019 11:26:20 +0100
Subject: [PATCH 8/9] Better type for dec_closure

---
 src/compile.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/compile.ml b/src/compile.ml
index 9550222a05f..f4dfd0b6961 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -3010,7 +3010,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 =
@@ -3108,7 +3108,7 @@ 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 *)
 

From 1c0c6ccf11846dba62fd0230a4f5fa9b6a4a7457 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Thu, 7 Feb 2019 12:03:50 +0100
Subject: [PATCH 9/9] `con_env` in `compiler`: Add `typ_binds` as needed.

with test case. HT to @claudio for pointing that out.
---
 src/compile.ml              | 18 +++++++++++++++---
 test/run/mut-field-bound.as |  6 ++++++
 2 files changed, 21 insertions(+), 3 deletions(-)
 create mode 100644 test/run/mut-field-bound.as

diff --git a/src/compile.ml b/src/compile.ml
index f4dfd0b6961..7c77c1c4a15 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -234,6 +234,16 @@ module E = struct
   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
       | Some l -> Some l
@@ -3761,15 +3771,17 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> (SR.t * G.t)) =
         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 ->
-        let sr, code = Var.get_val env name.it in
-        sr, mk_code env ^^ code
+        (* 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 : SR.t * G.t =
diff --git a/test/run/mut-field-bound.as b/test/run/mut-field-bound.as
new file mode 100644
index 00000000000..21ddc51f11a
--- /dev/null
+++ b/test/run/mut-field-bound.as
@@ -0,0 +1,6 @@
+type Obj = {var x : Nat};
+func foo<O <: Obj>(o : O) : Nat {
+  o.x
+};
+let o : Obj = new {var x : Nat = 1};
+assert(foo<{var x : Nat}>(o) == 1);