Better backpointer logic.

4 files changed, 65 insertions, 19 deletions

diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml
index 0e13b4c0..0888f8e8 100644
--- a/src/boot/be/il.ml
+++ b/src/boot/be/il.ml
@@ -903,9 +903,20 @@ let get_element_ptr
         (string_of_cell fmt mem_cell)
 ;;
 
-let ptr_cast (cell:cell) (rty:referent_ty) : cell =
+let cell_cast (cell:cell) (rty:referent_ty) : cell =
   match cell with
       Mem (mem, _) -> Mem (mem, rty)
+    | Reg (reg, _) ->
+        begin
+          match rty with
+              ScalarTy st -> Reg (reg, st)
+            | _ -> bug () "expected scalar type in Il.cell_cast on register"
+        end
+
+
+let ptr_cast (cell:cell) (rty:referent_ty) : cell =
+  match cell with
+      Mem (mem, ScalarTy (AddrTy _)) -> Mem (mem, ScalarTy (AddrTy rty))
     | Reg (reg, AddrTy _) -> Reg (reg, AddrTy rty)
     | _ -> bug () "expected address cell in Il.ptr_cast"
 ;;
diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml
index eb96d0ac..468d1ab1 100644
--- a/src/boot/be/x86.ml
+++ b/src/boot/be/x86.ml
@@ -1078,17 +1078,17 @@ let rec calculate_sz
 
       mov (rc eax) (Il.Cell closure_ptr);
       let obj_body = word_n (h eax) Abi.box_rc_field_body in
-      let obj_body = Il.ptr_cast obj_body obj_box_rty in
+      let obj_body = Il.cell_cast obj_body obj_box_rty in
       let tydesc_ptr = get_element_ptr obj_body Abi.obj_body_elt_tydesc in
 
         mov (rc eax) (Il.Cell tydesc_ptr);
-        let tydesc = Il.ptr_cast (word_at (h eax)) tydesc_rty in
+        let tydesc = Il.cell_cast (word_at (h eax)) tydesc_rty in
         let ty_params_ptr =
           get_element_ptr tydesc Abi.tydesc_field_first_param
         in
 
           mov (rc eax) (Il.Cell ty_params_ptr);
-          let ty_params = Il.ptr_cast (word_at (h eax)) ty_params_rty in
+          let ty_params = Il.cell_cast (word_at (h eax)) ty_params_rty in
             get_element_ptr ty_params i
   in
 
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 7f5e4cda..27524573 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -2142,27 +2142,33 @@ and vec_sty (word_bits:Il.bits) : Il.scalar_ty =
   let ptr = Il.ScalarTy (Il.AddrTy Il.OpaqueTy) in
     Il.AddrTy (Il.StructTy [| word; word; word; ptr |])
 
-and referent_type (cx:ctxt) (t:Ast.ty) : Il.referent_ty =
+and referent_type
+    ?parent_tags:parent_tags
+    ?boxed:(boxed=false)
+    (cx:ctxt)
+    (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
   let sv b = s (v b) in
   let sp t = s (p t) in
+  let recur ty = referent_type ?parent_tags ~boxed cx ty in
 
   let word_bits = cx.ctxt_abi.Abi.abi_word_bits in
   let word = word_rty word_bits in
   let ptr = sp Il.OpaqueTy in
   let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
-  let tup ttup = Il.StructTy (Array.map (referent_type cx) ttup) in
+  let tup ttup = Il.StructTy (Array.map recur ttup) in
   let tag ttag =
     let n = get_n_tag_tups cx ttag in
     let union =
-      let rty t =
-        match t with
-            Ast.TY_box (Ast.TY_tag dst_tag) when is_back_edge ttag dst_tag ->
-              sp (Il.StructTy [| word; Il.OpaqueTy |])
-          | _ -> referent_type cx t
+      let parent_tags =
+        match parent_tags with
+            None -> [ttag]
+          | Some pts -> ttag::pts
       in
+      let rty t = referent_type ~parent_tags ~boxed cx t in
       let tup ttup = Il.StructTy (Array.map rty ttup) in
         Array.init n (fun i -> tup (get_nth_tag_tup cx ttag i))
     in
@@ -2202,7 +2208,17 @@ and referent_type (cx:ctxt) (t:Ast.ty) : Il.referent_ty =
       | Ast.TY_fn _ -> fn_rty cx false
       | Ast.TY_obj _ -> obj_rty word_bits
 
-      | Ast.TY_tag ttag -> tag ttag
+      | Ast.TY_tag ttag ->
+          begin
+            match parent_tags with
+                Some parent_tags
+                  when boxed
+                    && parent_tags <> []
+                    && List.mem ttag parent_tags
+                    && is_back_edge ttag (List.hd parent_tags) ->
+                  Il.StructTy [| word; Il.OpaqueTy |]
+              | _ -> tag ttag
+          end
 
       | Ast.TY_chan _
       | Ast.TY_port _
@@ -2213,14 +2229,15 @@ and referent_type (cx:ctxt) (t:Ast.ty) : Il.referent_ty =
       | Ast.TY_native _ -> ptr
 
       | Ast.TY_box t ->
-          sp (Il.StructTy [| word; referent_type cx t |])
+          sp (Il.StructTy
+            [| word; referent_type ?parent_tags ~boxed:true cx t |])
 
-      | Ast.TY_mutable t -> referent_type cx t
+      | Ast.TY_mutable t -> recur t
 
       | Ast.TY_param (i, _) -> Il.ParamTy i
 
       | Ast.TY_named _ -> bug () "named type in referent_type"
-      | Ast.TY_constrained (t, _) -> referent_type cx t
+      | Ast.TY_constrained (t, _) -> recur t
 
 and slot_referent_type (cx:ctxt) (sl:Ast.slot) : Il.referent_ty =
   let s t = Il.ScalarTy t in
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index ce6f5d92..bb0d28a9 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -337,6 +337,8 @@ let trans_visitor
 
   let rec ptr_cast = Il.ptr_cast
 
+  and cell_cast = Il.cell_cast
+
   and curr_crate_ptr _ : Il.cell =
     word_at (fp_imm frame_crate_ptr)
 
@@ -465,7 +467,7 @@ let trans_visitor
     let indirect_args =
       get_element_ptr args_cell Abi.calltup_elt_indirect_args
     in
-      deref (ptr_cast
+      deref (cell_cast
                (get_element_ptr indirect_args Abi.indirect_args_elt_closure)
                (Il.ScalarTy (Il.AddrTy (obj_box_rty word_bits))))
   in
@@ -508,7 +510,7 @@ let trans_visitor
               get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
             in
             let ty_params =
-              ptr_cast ty_params (Il.ScalarTy (Il.AddrTy ty_params_rty))
+              cell_cast ty_params (Il.ScalarTy (Il.AddrTy ty_params_rty))
             in
               deref ty_params
           else
@@ -550,7 +552,7 @@ let trans_visitor
     let blk_fn = get_element_ptr self_iterator_args
       Abi.iterator_args_elt_block_fn
     in
-      ptr_cast blk_fn
+      cell_cast blk_fn
         (Il.ScalarTy (Il.AddrTy Il.CodeTy))
   in
 
@@ -3223,6 +3225,18 @@ let trans_visitor
             iter_ty_parts_full ty_params dst src ty
               (clone_ty ty_params clone_task)
 
+  and unfold_opaque_cell (c:Il.cell) (ty:Ast.ty) : Il.cell =
+    match Il.cell_referent_ty c with
+        Il.ScalarTy (Il.AddrTy _) ->
+          begin
+            match strip_mutable_or_constrained_ty ty with
+                Ast.TY_box boxed ->
+                  Il.ptr_cast c
+                    (Il.StructTy [| word_rty; referent_type cx boxed |])
+              | _ -> c
+          end
+      | _ -> c
+
   and free_ty
       (is_gc:bool)
       (ty_params:Il.cell)
@@ -3230,6 +3244,8 @@ let trans_visitor
       (cell:Il.cell)
       : unit =
     check_box_rty cell;
+    let cell = unfold_opaque_cell cell ty in
+    check_box_rty cell;
     note_drop_step ty "in free-ty";
     begin
     match strip_mutable_or_constrained_ty ty with
@@ -3464,6 +3480,8 @@ let trans_visitor
       | (Ast.TY_box ty', DEREF_one_box)
       | (Ast.TY_box ty', DEREF_all_boxes) ->
           check_box_rty cell;
+          let cell = unfold_opaque_cell cell ty in
+          check_box_rty cell;
           if initializing
           then init_box cell ty;
           let cell =
@@ -4092,7 +4110,7 @@ let trans_visitor
     in
     let pair_code_cell = get_element_ptr dst_cell Abi.fn_field_code in
     let pair_box_cell =
-      ptr_cast
+      cell_cast
         (get_element_ptr dst_cell Abi.fn_field_box)
         (Il.ScalarTy (Il.AddrTy (closure_box_rty)))
     in