Teach bind to actually bind typarams, as it claims to.

3 files changed, 103 insertions, 61 deletions

diff --git a/src/boot/be/abi.ml b/src/boot/be/abi.ml
index a7b98c2cd6a..9ea085b5550 100644
--- a/src/boot/be/abi.ml
+++ b/src/boot/be/abi.ml
@@ -63,8 +63,8 @@ let fn_field_code = binding_field_dispatch;;
 let fn_field_box = binding_field_bound_data;;
 
 let closure_body_elt_bound_args_tydesc = 0;;
-let closure_body_elt_target_tydesc = 1;;
-let closure_body_elt_target = 2;;
+let closure_body_elt_target = 1;;
+let closure_body_elt_bound_ty_params = 2;;
 let closure_body_elt_bound_args = 3;;
 
 let tag_elt_discriminant = 0;;
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index ee3b9aba76a..15105ab384d 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -2190,7 +2190,11 @@ let obj_rty (word_bits:Il.bits) : Il.referent_ty =
     r [| obj_vtbl_ptr; obj_box_ptr |]
 ;;
 
-let rec closure_box_rty (cx:ctxt) (bs:Ast.slot array) : Il.referent_ty =
+let rec closure_box_rty
+    (cx:ctxt)
+    (n_ty_params:int)
+    (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
@@ -2200,10 +2204,13 @@ let rec closure_box_rty (cx:ctxt) (bs:Ast.slot array) : Il.referent_ty =
   let rc = word_rty word_bits in
   let tydesc = sp (tydesc_rty word_bits) in
   let targ = fn_rty cx true in
+  let ty_param_rtys =
+      r (Array.init n_ty_params (fun _ -> tydesc))
+  in
   let bound_args = r (Array.map (slot_referent_type cx) bs) in
     (* First tydesc is the one describing bound_args; second tydesc is the one
      * to pass to targ when invoking it.  *)
-    r [| rc; r [| tydesc; tydesc; targ; bound_args |] |]
+    r [| rc; r [| tydesc; targ; ty_param_rtys; bound_args |] |]
 
 and fn_rty (cx:ctxt) (opaque_box_body:bool) : Il.referent_ty =
   let s t = Il.ScalarTy t in
@@ -2216,7 +2223,7 @@ and fn_rty (cx:ctxt) (opaque_box_body:bool) : Il.referent_ty =
   let box =
     if opaque_box_body
     then r [| word; Il.OpaqueTy |]
-    else closure_box_rty cx [||]
+    else closure_box_rty cx 0 [||]
   in
   let box_ptr = sp box in
   let code_ptr = sp Il.CodeTy in
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index 5983b4d6f16..b3544a856af 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -1663,6 +1663,7 @@ let trans_visitor
   (* FIXME (issue #2): this should eventually use tail calling logic *)
 
   and emit_fn_thunk_glue
+      (n_ty_params:int)
       (arg_slots:Ast.slot array)
       (arg_bound_flags:bool array)
       (fix:fixup)
@@ -1683,14 +1684,14 @@ let trans_visitor
     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_box_rty = closure_box_rty cx bound_slots in
+    let self_box_rty = closure_box_rty cx n_ty_params bound_slots in
 
     let self_args_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)
+      call_args_referent_type cx n_ty_params callee_ty (Some Il.OpaqueTy)
     in
 
     let callsz = Il.referent_ty_size word_bits callee_args_rty in
@@ -1729,6 +1730,7 @@ let trans_visitor
       in
 
         merge_bound_args
+          n_ty_params
           self_args_rty callee_args_rty
           arg_slots arg_bound_flags;
         iflog (fun _ -> annotate "call through to closure target fn");
@@ -1747,6 +1749,7 @@ let trans_visitor
 
   and get_fn_thunk_glue
       (bind_id:node_id)
+      (n_ty_params:int)
       (arg_slots:Ast.slot array)
       (arg_bound_flags:bool array)
       : fixup =
@@ -1755,7 +1758,7 @@ let trans_visitor
           Some code -> code.code_fixup
         | None ->
             let fix = new_fixup (glue_str cx g) in
-              emit_fn_thunk_glue arg_slots arg_bound_flags fix g;
+              emit_fn_thunk_glue n_ty_params arg_slots arg_bound_flags fix g;
               fix
 
 
@@ -4186,6 +4189,7 @@ let trans_visitor
       (closure_cell:Il.cell)
       (target_fn_ptr:Il.operand)
       (target_binding_ptr:Il.operand)
+      (ty_params:Ast.ty array)
       (bound_arg_slots:Ast.slot array)
       (bound_args:Ast.atom array)
       : unit =
@@ -4196,6 +4200,9 @@ let trans_visitor
     let bound_args_tydesc_cell =
       get_element_ptr body_cell Abi.closure_body_elt_bound_args_tydesc
     in
+    let bound_ty_params_cell =
+      get_element_ptr body_cell Abi.closure_body_elt_bound_ty_params
+    in
     let args_cell =
       get_element_ptr body_cell Abi.closure_body_elt_bound_args
     in
@@ -4219,6 +4226,16 @@ let trans_visitor
       (get_element_ptr targ_cell Abi.fn_field_box)
       (reify_ptr target_binding_ptr);
 
+    iflog (fun _ -> annotate "set closure bound tydescs");
+    Array.iteri
+      begin
+        fun i ty ->
+          mov
+            (get_element_ptr bound_ty_params_cell i)
+            (Il.Cell (get_tydesc None ty))
+      end
+      ty_params;
+
     iflog (fun _ -> annotate "set closure bound args");
     copy_bound_args args_cell bound_arg_slots bound_args
 
@@ -4233,6 +4250,12 @@ let trans_visitor
       : unit =
     let (dst_cell, _) = trans_lval_maybe_init initializing dst in
     let (target_ptr, _) = trans_callee flv in
+    let ty_params =
+      match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
+          Some params -> params
+        | None -> [| |]
+    in
+    let n_ty_params = Array.length ty_params in
     let arg_bound_flags = Array.map bool_of_option args in
     let arg_slots =
       arr_map2
@@ -4244,11 +4267,12 @@ let trans_visitor
     let bound_arg_slots = arr_filter_some arg_slots in
     let bound_args = arr_filter_some args in
     let thunk_fixup =
-      get_fn_thunk_glue bind_id fn_sig.Ast.sig_input_slots arg_bound_flags
+      get_fn_thunk_glue bind_id n_ty_params
+        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 cx bound_arg_slots in
+    let closure_box_rty = closure_box_rty cx n_ty_params bound_arg_slots in
     let closure_box_sz =
       calculate_sz_in_current_frame
         (Il.referent_ty_size word_bits closure_box_rty)
@@ -4268,6 +4292,7 @@ let trans_visitor
         (deref pair_box_cell)
         target_code_ptr
         target_box_ptr
+        ty_params
         bound_arg_slots
         bound_args
 
@@ -4466,6 +4491,7 @@ let trans_visitor
         bound_arg_slots
 
   and merge_bound_args
+      (n_ty_params:int)
       (all_self_args_rty:Il.referent_ty)
       (all_callee_args_rty:Il.referent_ty)
       (arg_slots:Ast.slot array)
@@ -4473,7 +4499,7 @@ let trans_visitor
       : unit =
     begin
       (* 
-       * NB: 'all_*_args', both self and callee, are always 4-tuples: 
+       * NB: 'all_*_args', both self and callee, are always 5-tuples: 
        * 
        *    [out_ptr, task_ptr, indirect_args, ty_params, [args]]
        * 
@@ -4486,17 +4512,31 @@ let trans_visitor
       let self_args_cell =
         get_element_ptr all_self_args_cell Abi.calltup_elt_args
       in
-      let self_ty_params_cell =
-        get_element_ptr all_self_args_cell Abi.calltup_elt_ty_params
+      let self_indirect_args_cell =
+        get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
+      in
+      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_body_elt_bound_args
+      in
+      let closure_ty_params_cell =
+        get_element_ptr closure_cell Abi.closure_body_elt_bound_ty_params
+      in
+      let callee_ty_params_cell =
+        get_element_ptr all_callee_args_cell Abi.calltup_elt_ty_params
       in
       let callee_args_cell =
         (* FIXME (issue #81):  Once we've actually got proper ty_params,
          * we should GEP dynamically here to get the args, since they may
          * be aligned dynamically if they have parameterized type. *)
-        get_element_ptr all_callee_args_cell Abi.calltup_elt_args
-      in
-      let self_indirect_args_cell =
-        get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
+        get_element_ptr_dyn closure_ty_params_cell
+          all_callee_args_cell Abi.calltup_elt_args
       in
 
       let n_args = Array.length arg_bound_flags in
@@ -4515,51 +4555,46 @@ let trans_visitor
           (Il.Cell (get_element_ptr all_self_args_cell
                       Abi.calltup_elt_task_ptr));
 
-        iflog (fun _ -> annotate "extract closure indirect-arg");
-        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_body_elt_bound_args
-        in
+        iflog (fun _ -> annotate "copy ty-params");
+        for ty_i = 0 to (n_ty_params - 1) do
+          mov
+            (get_element_ptr callee_ty_params_cell ty_i)
+            (Il.Cell (get_element_ptr closure_ty_params_cell ty_i))
+        done;
 
-          for arg_i = 0 to (n_args - 1) do
-            let dst_cell = get_element_ptr callee_args_cell arg_i in
-            let slot = arg_slots.(arg_i) in
-            let is_bound = arg_bound_flags.(arg_i) in
-            let src_cell =
-              if is_bound then
-                begin
-                  iflog (fun _ -> annotate
-                           (Printf.sprintf
-                              "extract bound arg %d as actual arg %d"
-                              !bound_i arg_i));
-                  get_element_ptr closure_args_cell (!bound_i)
-                end
-              else
-                begin
-                  iflog (fun _ -> annotate
-                           (Printf.sprintf
-                              "extract unbound arg %d as actual arg %d"
-                              !unbound_i arg_i));
-                  get_element_ptr self_args_cell (!unbound_i);
-                end
-            in
-              iflog (fun _ -> annotate
-                       (Printf.sprintf
-                          "copy into actual-arg %d" arg_i));
-              trans_init_slot_from_cell
-                self_ty_params_cell CLONE_none
-                dst_cell slot
-                (deref_slot false src_cell slot) (slot_ty slot);
-              incr (if is_bound then bound_i else unbound_i);
-          done;
-          assert ((!bound_i + !unbound_i) == n_args)
+        iflog (fun _ -> annotate "copy args");
+        for arg_i = 0 to (n_args - 1) do
+          let dst_cell = get_element_ptr callee_args_cell arg_i in
+          let slot = arg_slots.(arg_i) in
+          let is_bound = arg_bound_flags.(arg_i) in
+          let src_cell =
+            if is_bound then
+              begin
+                iflog (fun _ -> annotate
+                         (Printf.sprintf
+                            "extract bound arg %d as actual arg %d"
+                            !bound_i arg_i));
+                get_element_ptr closure_args_cell (!bound_i)
+              end
+            else
+              begin
+                iflog (fun _ -> annotate
+                         (Printf.sprintf
+                            "extract unbound arg %d as actual arg %d"
+                            !unbound_i arg_i));
+                get_element_ptr self_args_cell (!unbound_i);
+              end
+          in
+            iflog (fun _ -> annotate
+                     (Printf.sprintf
+                        "copy into actual-arg %d" arg_i));
+            trans_init_slot_from_cell
+              closure_ty_params_cell CLONE_none
+              dst_cell slot
+              (deref_slot false src_cell slot) (slot_ty slot);
+            incr (if is_bound then bound_i else unbound_i);
+        done;
+        assert ((!bound_i + !unbound_i) == n_args)
     end