First pass of updating the in-memory layout of closures, for issue 81.

3 files changed, 153 insertions, 121 deletions

diff --git a/src/boot/be/abi.ml b/src/boot/be/abi.ml
index 5dd6037bcc4..32c9f44ac99 100644
--- a/src/boot/be/abi.ml
+++ b/src/boot/be/abi.ml
@@ -45,9 +45,9 @@ let stk_field_valgrind_id = 0;;
 let stk_field_limit = stk_field_valgrind_id + 1;;
 let stk_field_data = stk_field_limit + 1;;
 
-(* Both obj and fn are two-word "bindings":  One word points to some
- * static dispatch information (vtbl or thunk), and the other points to
- * some bag of bound data (object-body or closure).
+(* Both obj and fn are two-word "bindings": One word points to some static
+ * dispatch information (vtbl, thunk, callee), and the other points to some
+ * box of bound data (object-body or closure).
  *)
 
 let binding_field_dispatch = 0;;
@@ -59,11 +59,12 @@ let obj_field_box = binding_field_bound_data;;
 let obj_body_elt_tydesc = 0;;
 let obj_body_elt_fields = 1;;
 
-let fn_field_thunk = binding_field_dispatch;;
-let fn_field_closure = binding_field_bound_data;;
-let closure_elt_rc = 0;;
-let closure_elt_target = 1;;
-let closure_elt_bound_args = 2;;
+let fn_field_code = binding_field_dispatch;;
+let fn_field_box = binding_field_bound_data;;
+
+let closure_body_elt_tydesc = 0;;
+let closure_body_elt_target = 1;;
+let closure_body_elt_bound_args = 2;;
 
 let tag_elt_discriminant = 0;;
 let tag_elt_variant = 1;;
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 6cf03dfc1c4..8a7d6aa015a 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -36,7 +36,7 @@ type glue =
   | GLUE_mark_frame of node_id    (* Node is the frame.                 *)
   | GLUE_drop_frame of node_id    (* Node is the frame.                 *)
   | GLUE_reloc_frame of node_id   (* Node is the frame.                 *)
-  | GLUE_fn_binding of node_id    (* Node is the 'bind' stmt.           *)
+  | GLUE_fn_thunk of node_id      (* Node is the 'bind' stmt.           *)
   | GLUE_obj_drop of node_id      (* Node is the obj.                   *)
   | GLUE_loop_body of node_id     (* Node is the 'for each' body block. *)
   | GLUE_forward of (Ast.ident * Ast.ty_obj * Ast.ty_obj)
@@ -1878,21 +1878,64 @@ let tydesc_rty (word_bits:Il.bits) : Il.referent_ty =
     |]
 ;;
 
-(* 
- * [ rc [ tydesc* | obj-body ] ]
- *)
 let obj_box_rty (word_bits:Il.bits) : Il.referent_ty =
-  Il.StructTy [|
-    word_rty word_bits;
-    Il.StructTy [|
-      Il.ScalarTy (Il.AddrTy (tydesc_rty word_bits));
-      word_rty word_bits (* A lie: it's opaque, but this permits
-                          * GEP'ing to it. *)
-    |]
-  |]
+  let s t = Il.ScalarTy t in
+  let p t = Il.AddrTy t in
+  let sp t = s (p t) in
+  let r rtys = Il.StructTy rtys in
+
+  let rc = word_rty word_bits in
+  let tydesc = sp (tydesc_rty word_bits) in
+
+  (* This is a lie: it's opaque, but this permits GEP'ing to it. *)
+  let fields = word_rty word_bits in
+
+    r [| rc; r [| tydesc; fields |] |]
 ;;
 
-let rec referent_type (word_bits:Il.bits) (t:Ast.ty) : Il.referent_ty =
+let obj_rty (word_bits:Il.bits) : Il.referent_ty =
+  let s t = Il.ScalarTy t in
+  let p t = Il.AddrTy t in
+  let sp t = s (p t) in
+  let r rtys = Il.StructTy rtys in
+
+  let obj_box_ptr = sp (obj_box_rty word_bits) in
+  let obj_vtbl_ptr = sp Il.OpaqueTy in
+
+    r [| obj_vtbl_ptr; obj_box_ptr |]
+;;
+
+
+
+let rec closure_box_rty
+    (word_bits:Il.bits)
+    (bs:Ast.slot array)
+    : Il.referent_ty =
+  let s t = Il.ScalarTy t in
+  let p t = Il.AddrTy t in
+  let sp t = s (p t) in
+  let r rtys = Il.StructTy rtys in
+
+  let rc = word_rty word_bits in
+  let tydesc = sp (tydesc_rty word_bits) in
+  let targ = fn_rty word_bits in
+  let bound_args = r (Array.map (slot_referent_type word_bits) bs) in
+
+    r [| rc; r [| tydesc; targ; bound_args |] |]
+
+and fn_rty (word_bits:Il.bits) : Il.referent_ty =
+  let s t = Il.ScalarTy t in
+  let p t = Il.AddrTy t in
+  let sp t = s (p t) in
+  let r rtys = Il.StructTy rtys in
+  let word = word_rty word_bits in
+
+  let box_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
+  let code_ptr = sp Il.CodeTy in
+
+    r [| code_ptr; box_ptr |]
+
+and referent_type (word_bits:Il.bits) (t:Ast.ty) : Il.referent_ty =
   let s t = Il.ScalarTy t in
   let v b = Il.ValTy b in
   let p t = Il.AddrTy t in
@@ -1902,7 +1945,6 @@ let rec referent_type (word_bits:Il.bits) (t:Ast.ty) : Il.referent_ty =
   let word = word_rty word_bits in
   let ptr = sp Il.OpaqueTy in
   let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
-  let codeptr = sp Il.CodeTy in
   let tup ttup = Il.StructTy (Array.map (referent_type word_bits) ttup) in
   let tag ttag =
     let union =
@@ -1943,13 +1985,8 @@ let rec referent_type (word_bits:Il.bits) (t:Ast.ty) : Il.referent_ty =
       | Ast.TY_tup tt -> tup tt
       | Ast.TY_rec tr -> tup (Array.map snd tr)
 
-      | Ast.TY_fn _ ->
-          let fn_closure_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
-            Il.StructTy [| codeptr; fn_closure_ptr |]
-
-      | Ast.TY_obj _ ->
-          let obj_box_ptr = sp (obj_box_rty word_bits) in
-            Il.StructTy [| ptr; obj_box_ptr |]
+      | Ast.TY_fn _ -> fn_rty word_bits
+      | Ast.TY_obj _ -> obj_rty word_bits
 
       | Ast.TY_tag ttag -> tag ttag
       | Ast.TY_iso tiso -> tag tiso.Ast.iso_group.(tiso.Ast.iso_index)
@@ -2292,8 +2329,8 @@ let glue_str (cx:ctxt) (g:glue) : string =
          * a statement; lookup bind target and encode bound arg 
          * tuple type.
          *)
-    | GLUE_fn_binding i
-      -> "glue$fn_binding$" ^ (string_of_int (int_of_node i))
+    | GLUE_fn_thunk i
+      -> "glue$fn_thunk$" ^ (string_of_int (int_of_node i))
     | GLUE_obj_drop oid
       -> (item_str cx oid) ^ ".drop"
     | GLUE_loop_body i
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 2dccb023a60..a37ed460809 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -1452,49 +1452,15 @@ let trans_visitor
               emit_exit_task_glue fix g;
               fix
 
-  (*
-   * Closure representation has 3 GEP-parts:
-   * 
-   *  ......
-   *  . gc . gc control word, if mutable
-   *  +----+
-   *  | rc | refcount
-   *  +----+
-   * 
-   *  +----+
-   *  | tf | ----> pair of fn+binding that closure 
-   *  +----+   /   targets
-   *  | tb | --
-   *  +----+
-   * 
-   *  +----+
-   *  | b1 | bound arg1
-   *  +----+
-   *  .    .
-   *  .    .
-   *  .    .
-   *  +----+
-   *  | bN | bound argN
-   *  +----+
-   *)
-
-  and closure_referent_type
-      (bs:Ast.slot array)
-      (* FIXME (issue #5): mutability flag *)
-      : Il.referent_ty =
-    let rc = Il.ScalarTy word_sty in
-    let targ = referent_type word_bits (mk_simple_ty_fn [||]) in
-    let bindings = Array.map (slot_referent_type word_bits) bs in
-      Il.StructTy [| rc; targ; Il.StructTy bindings |]
-
   (* FIXME (issue #2): this should eventually use tail calling logic *)
 
-  and emit_fn_binding_glue
+  and emit_fn_thunk_glue
       (arg_slots:Ast.slot array)
       (arg_bound_flags:bool array)
       (fix:fixup)
       (g:glue)
       : unit =
+
     let extract_slots want_bound =
       arr_filter_some
         (arr_map2
@@ -1505,14 +1471,16 @@ let trans_visitor
     in
     let bound_slots = extract_slots true in
     let unbound_slots = extract_slots false in
+
     let (self_ty:Ast.ty) = mk_simple_ty_fn unbound_slots in
     let (callee_ty:Ast.ty) = mk_simple_ty_fn arg_slots in
 
-    let self_closure_rty = closure_referent_type bound_slots in
-    (* FIXME (issue #81): binding type parameters doesn't work. *)
+    let self_box_rty = closure_box_rty word_bits bound_slots in
+
     let self_args_rty =
-      call_args_referent_type cx 0 self_ty (Some self_closure_rty)
+      call_args_referent_type cx 0 self_ty (Some self_box_rty)
     in
+
     let callee_args_rty =
       call_args_referent_type cx 0 callee_ty (Some Il.OpaqueTy)
     in
@@ -1522,18 +1490,26 @@ let trans_visitor
       trans_glue_frame_entry callsz spill;
 
       let all_self_args_cell = caller_args_cell self_args_rty in
+
       let self_indirect_args_cell =
         get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
       in
-      let closure_cell =
+
+      let box_cell =
         deref (get_element_ptr self_indirect_args_cell
                  Abi.indirect_args_elt_closure)
       in
+
+      let closure_cell =
+        get_element_ptr box_cell Abi.box_rc_field_body
+      in
+
       let closure_target_cell =
-        get_element_ptr closure_cell Abi.fn_field_closure
+        get_element_ptr closure_cell Abi.closure_body_elt_target
       in
-      let closure_target_fn_cell =
-        get_element_ptr closure_target_cell Abi.fn_field_thunk
+
+      let closure_target_code_cell =
+        get_element_ptr closure_target_cell Abi.fn_field_code
       in
 
         merge_bound_args
@@ -1541,21 +1517,21 @@ let trans_visitor
           arg_slots arg_bound_flags;
         iflog (fun _ -> annotate "call through to closure target fn");
 
-        call_code (code_of_cell closure_target_fn_cell);
+        call_code (code_of_cell closure_target_code_cell);
         trans_glue_frame_exit fix spill g
 
 
-  and get_fn_binding_glue
+  and get_fn_thunk_glue
       (bind_id:node_id)
       (arg_slots:Ast.slot array)
       (arg_bound_flags:bool array)
       : fixup =
-    let g = GLUE_fn_binding bind_id in
+    let g = GLUE_fn_thunk bind_id in
       match htab_search cx.ctxt_glue_code g with
           Some code -> code.code_fixup
         | None ->
             let fix = new_fixup (glue_str cx g) in
-              emit_fn_binding_glue arg_slots arg_bound_flags fix g;
+              emit_fn_thunk_glue arg_slots arg_bound_flags fix g;
               fix
 
 
@@ -2630,14 +2606,14 @@ let trans_visitor
 
           Ast.TY_fn _ ->
             note_drop_step ty "drop_ty: fn path";
-            let binding = get_element_ptr cell Abi.fn_field_closure in
-            let null_jmp = null_check binding in
+            let box = get_element_ptr cell Abi.fn_field_box in
+            let null_jmp = null_check box in
               (* Drop non-null bindings. *)
               (* FIXME (issue #58): this is completely wrong, Closures need to
                * carry tydescs like objs. For now this only works by accident,
                * and will leak closures with box substructure.
                *)
-              drop_ty ty_params binding (Ast.TY_box Ast.TY_int) curr_iso;
+              drop_ty ty_params box (Ast.TY_box Ast.TY_int) curr_iso;
               patch null_jmp;
               note_drop_step ty "drop_ty: done fn path";
 
@@ -3389,7 +3365,7 @@ let trans_visitor
 
         | (_, Ast.EXPR_atom (Ast.ATOM_lval src_lval)) ->
             if lval_is_direct_fn cx src_lval then
-              trans_copy_direct_fn dst_cell src_lval
+              trans_init_direct_fn dst_cell src_lval
             else
               (* Possibly-large structure copying *)
               let (src_cell, src_ty) = trans_lval src_lval in
@@ -3400,21 +3376,22 @@ let trans_visitor
                   src_cell src_ty
                   None
 
-  and trans_copy_direct_fn
+  and trans_init_direct_fn
       (dst_cell:Il.cell)
       (flv:Ast.lval)
       : unit =
     let item = lval_item cx flv in
     let fix = Hashtbl.find cx.ctxt_fn_fixups item.id in
 
-    let dst_pair_item_cell =
-      get_element_ptr dst_cell Abi.fn_field_thunk
+    let dst_pair_code_cell =
+      get_element_ptr dst_cell Abi.fn_field_code
     in
-    let dst_pair_binding_cell =
-      get_element_ptr dst_cell Abi.fn_field_closure
+
+    let dst_pair_box_cell =
+      get_element_ptr dst_cell Abi.fn_field_box
     in
-      mov dst_pair_item_cell (reify_ptr (Il.ImmPtr (fix, Il.CodeTy)));
-      mov dst_pair_binding_cell zero
+      mov dst_pair_code_cell (reify_ptr (Il.ImmPtr (fix, Il.CodeTy)));
+      mov dst_pair_box_cell zero
 
 
   and trans_init_structural_from_atoms
@@ -3636,21 +3613,31 @@ let trans_visitor
       (bound_args:Ast.atom array)
       : unit =
 
-    let rc_cell = get_element_ptr closure_cell Abi.closure_elt_rc in
-    let targ_cell = get_element_ptr closure_cell Abi.closure_elt_target in
-    let args_cell = get_element_ptr closure_cell Abi.closure_elt_bound_args in
+    let rc_cell = get_element_ptr closure_cell Abi.box_rc_field_refcnt in
+    let body_cell = get_element_ptr closure_cell Abi.box_rc_field_body in
+    let targ_cell = get_element_ptr body_cell Abi.closure_body_elt_target in
+    let tydesc_cell = get_element_ptr body_cell Abi.closure_body_elt_tydesc in
+    let args_cell =
+      get_element_ptr body_cell Abi.closure_body_elt_bound_args
+    in
 
     iflog (fun _ -> annotate "init closure refcount");
     mov rc_cell one;
 
+    iflog (fun _ -> annotate "set closure tydesc ptr");
+    mov tydesc_cell
+      (Il.Cell (get_tydesc None
+                  (Ast.TY_tup (Array.map slot_ty bound_arg_slots))));
+
+
     iflog (fun _ -> annotate "set closure target code ptr");
     mov
-      (get_element_ptr targ_cell Abi.fn_field_thunk)
+      (get_element_ptr targ_cell Abi.fn_field_code)
       (reify_ptr target_fn_ptr);
 
     iflog (fun _ -> annotate "set closure target closure ptr");
     mov
-      (get_element_ptr targ_cell Abi.fn_field_closure)
+      (get_element_ptr targ_cell Abi.fn_field_box)
       (reify_ptr target_binding_ptr);
 
     iflog (fun _ -> annotate "set closure bound args");
@@ -3677,28 +3664,31 @@ let trans_visitor
     in
     let bound_arg_slots = arr_filter_some arg_slots in
     let bound_args = arr_filter_some args in
-    let glue_fixup =
-      get_fn_binding_glue bind_id fn_sig.Ast.sig_input_slots arg_bound_flags
+    let thunk_fixup =
+      get_fn_thunk_glue bind_id fn_sig.Ast.sig_input_slots arg_bound_flags
+    in
+    let target_code_ptr = callee_code_ptr target_ptr cc in
+    let target_box_ptr = callee_box_ptr flv cc in
+    let closure_box_rty = closure_box_rty word_bits bound_arg_slots in
+    let closure_box_sz =
+      calculate_sz_in_current_frame
+        (Il.referent_ty_size word_bits closure_box_rty)
     in
-    let target_fn_ptr = callee_fn_ptr target_ptr cc in
-    let target_binding_ptr = callee_binding_ptr flv cc in
-    let closure_rty = closure_referent_type bound_arg_slots in
-    let closure_sz = force_sz (Il.referent_ty_size word_bits closure_rty) in
-    let fn_cell = get_element_ptr dst_cell Abi.fn_field_thunk in
-    let closure_cell =
+    let pair_code_cell = get_element_ptr dst_cell Abi.fn_field_code in
+    let pair_box_cell =
       ptr_cast
-        (get_element_ptr dst_cell Abi.fn_field_closure)
-        (Il.ScalarTy (Il.AddrTy (closure_rty)))
+        (get_element_ptr dst_cell Abi.fn_field_box)
+        (Il.ScalarTy (Il.AddrTy (closure_box_rty)))
     in
-      iflog (fun _ -> annotate "assign glue-code to fn slot of pair");
-      mov fn_cell (reify_ptr (Il.ImmPtr (glue_fixup, Il.CodeTy)));
+      iflog (fun _ -> annotate "assign thunk-ptr to code field of pair");
+      mov pair_code_cell (reify_ptr (Il.ImmPtr (thunk_fixup, Il.CodeTy)));
       iflog (fun _ ->
                annotate "heap-allocate closure to binding slot of pair");
-      trans_malloc closure_cell (imm closure_sz) zero;
+      trans_malloc pair_box_cell closure_box_sz zero;
       trans_init_closure
-        (deref closure_cell)
-        target_fn_ptr
-        target_binding_ptr
+        (deref pair_box_cell)
+        target_code_ptr
+        target_box_ptr
         bound_arg_slots
         bound_args
 
@@ -3947,12 +3937,16 @@ let trans_visitor
                       Abi.calltup_elt_task_ptr));
 
         iflog (fun _ -> annotate "extract closure indirect-arg");
-        let closure_cell =
+        let closure_box_cell =
           deref (get_element_ptr self_indirect_args_cell
                    Abi.indirect_args_elt_closure)
         in
+        let closure_cell =
+          get_element_ptr closure_box_cell Abi.box_rc_field_body
+        in
+
         let closure_args_cell =
-          get_element_ptr closure_cell Abi.closure_elt_bound_args
+          get_element_ptr closure_cell Abi.closure_body_elt_bound_args
         in
 
           for arg_i = 0 to (n_args - 1) do
@@ -3990,7 +3984,7 @@ let trans_visitor
     end
 
 
-  and callee_fn_ptr
+  and callee_code_ptr
       (fptr:Il.operand)
       (cc:call_ctrl)
       : Il.operand =
@@ -3998,11 +3992,11 @@ let trans_visitor
         CALL_direct
       | CALL_vtbl -> fptr
       | CALL_indirect ->
-          (* fptr is a pair [fptr, binding*] *)
+          (* fptr is a pair [code*, box*] *)
           let pair_cell = need_cell (reify_ptr fptr) in
-            Il.Cell (get_element_ptr pair_cell Abi.fn_field_thunk)
+            Il.Cell (get_element_ptr pair_cell Abi.fn_field_code)
 
-  and callee_binding_ptr
+  and callee_box_ptr
       (pair_lval:Ast.lval)
       (cc:call_ctrl)
       : Il.operand =
@@ -4054,7 +4048,7 @@ let trans_visitor
       begin
         match cc with
             CALL_direct -> [| |]
-          | CALL_indirect -> [| callee_binding_ptr flv cc |]
+          | CALL_indirect -> [| callee_box_ptr flv cc |]
           | CALL_vtbl ->
               begin
                 match flv with
@@ -4062,7 +4056,7 @@ let trans_visitor
                      * if we add a 'self' value for self-dispatch within
                      * objs. Also to support forwarding-functions / 'as'.
                      *)
-                    Ast.LVAL_ext (base, _) -> [| callee_binding_ptr base cc |]
+                    Ast.LVAL_ext (base, _) -> [| callee_box_ptr base cc |]
                   | _ ->
                       bug (lval_base_id flv)
                         "call_indirect_args on obj-fn without base obj"
@@ -4074,7 +4068,7 @@ let trans_visitor
       (caller_is_closure:bool)
       (call:call)
       : unit =
-    let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
+    let callee_fptr = callee_code_ptr call.call_callee_ptr call.call_ctrl in
     let callee_code = code_of_operand callee_fptr in
     let callee_args_rty =
       call_args_referent_type cx 0 call.call_callee_ty
@@ -4106,7 +4100,7 @@ let trans_visitor
       (call:call)
       : Il.operand =
 
-    let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
+    let callee_fptr = callee_code_ptr call.call_callee_ptr call.call_ctrl in
       iflog (fun _ -> annotate
                (Printf.sprintf "copy args for call to %s" (logname ())));
       copy_fn_args false initializing CLONE_none call;
@@ -5011,7 +5005,7 @@ let trans_visitor
             (Il.Cell (get_tydesc
                         (Some obj_id)
                         (Ast.TY_tup obj_fields_tup)));
-          iflog (fun _ -> annotate "copy ctor args to obj args");
+          iflog (fun _ -> annotate "copy ctor args to obj body fields");
           trans_copy_tup
             frame_ty_params true
             obj_fields frame_args obj_fields_tup;