From cdf67b1f2e34ceb27a922cde7edc526597200b96 Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Tue, 5 Oct 2010 18:09:49 -0700 Subject: [PATCH] Better backpointer logic. --- src/boot/be/il.ml | 13 ++++++++++++- src/boot/be/x86.ml | 6 +++--- src/boot/me/semant.ml | 39 ++++++++++++++++++++++++++++----------- src/boot/me/trans.ml | 26 ++++++++++++++++++++++---- 4 files changed, 65 insertions(+), 19 deletions(-) diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml index 0e13b4c0dd5..0888f8e8c6e 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 eb96d0ac47b..468d1ab1b5b 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 7f5e4cda684..27524573379 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 ce6f5d922f7..bb0d28a97c2 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 @@ -3463,6 +3479,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; @@ -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