aboutsummaryrefslogtreecommitdiff
path: root/src/boot/me
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/me')
-rw-r--r--src/boot/me/alias.ml5
-rw-r--r--src/boot/me/dead.ml3
-rw-r--r--src/boot/me/dwarf.ml5
-rw-r--r--src/boot/me/effect.ml3
-rw-r--r--src/boot/me/layout.ml6
-rw-r--r--src/boot/me/loop.ml4
-rw-r--r--src/boot/me/resolve.ml16
-rw-r--r--src/boot/me/semant.ml114
-rw-r--r--src/boot/me/trans.ml199
-rw-r--r--src/boot/me/type.ml65
-rw-r--r--src/boot/me/typestate.ml67
-rw-r--r--src/boot/me/walk.ml74
12 files changed, 357 insertions, 204 deletions
diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml
index d98316ef..148f1249 100644
--- a/src/boot/me/alias.ml
+++ b/src/boot/me/alias.ml
@@ -67,7 +67,7 @@ let alias_analysis_visitor
| Ast.STMT_recv (dst, _) -> alias dst
| Ast.STMT_init_port (dst) -> alias dst
| Ast.STMT_init_chan (dst, _) -> alias dst
- | Ast.STMT_init_vec (dst, _) -> alias dst
+ | Ast.STMT_init_vec (dst, _, _) -> alias dst
| Ast.STMT_init_str (dst, _) -> alias dst
| Ast.STMT_for_each sfe ->
let (slot, _) = sfe.Ast.for_each_slot in
@@ -118,7 +118,8 @@ let process_crate
Walk.empty_visitor);
|]
in
- run_passes cx "alias" path passes (log cx "%s") crate
+ run_passes cx "alias" path passes
+ cx.ctxt_sess.Session.sess_log_alias log crate
;;
(*
diff --git a/src/boot/me/dead.ml b/src/boot/me/dead.ml
index 47e56166..61aa846a 100644
--- a/src/boot/me/dead.ml
+++ b/src/boot/me/dead.ml
@@ -106,7 +106,8 @@ let process_crate
|]
in
- run_passes cx "dead" path passes (log cx "%s") crate;
+ run_passes cx "dead" path passes
+ cx.ctxt_sess.Session.sess_log_dead log crate;
()
;;
diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index cdc88da7..f1d51f16 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -1450,7 +1450,7 @@ let dwarf_visitor
let iso_stack = Stack.create () in
- let path_name _ = Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
+ let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
@@ -2547,7 +2547,8 @@ let process_crate
in
log cx "emitting DWARF records";
- run_passes cx "dwarf" path passes (log cx "%s") crate;
+ run_passes cx "dwarf" path passes
+ cx.ctxt_sess.Session.sess_log_dwarf log crate;
(* Terminate the tables. *)
{
diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml
index 3ec492c8..9ddef63d 100644
--- a/src/boot/me/effect.ml
+++ b/src/boot/me/effect.ml
@@ -328,7 +328,8 @@ let process_crate
else err (Some id) "auth clause in crate refers to non-item"
in
Hashtbl.iter auth_effect crate.node.Ast.crate_auth;
- run_passes cx "effect" path passes (log cx "%s") crate
+ run_passes cx "effect" path passes
+ cx.ctxt_sess.Session.sess_log_effect log crate
;;
(*
diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml
index 365acbf9..e1a7ff47 100644
--- a/src/boot/me/layout.ml
+++ b/src/boot/me/layout.ml
@@ -21,7 +21,8 @@ let layout_visitor
* |... |
* |... |
* +----------------------------+ <-- fp + abi_frame_base_sz
- * |task ptr (implicit arg) | + abi_implicit_args_sz
+ * |closure/obj ptr (impl. arg) | + abi_implicit_args_sz
+ * |task ptr (implicit arg) |
* |output ptr (implicit arg) |
* +----------------------------+ <-- fp + abi_frame_base_sz
* |return pc |
@@ -456,7 +457,8 @@ let process_crate
Walk.empty_visitor)
|];
in
- run_passes cx "layout" path passes (log cx "%s") crate
+ run_passes cx "layout" path passes
+ cx.ctxt_sess.Session.sess_log_layout log crate
;;
diff --git a/src/boot/me/loop.ml b/src/boot/me/loop.ml
index c23c4afd..1fbb8223 100644
--- a/src/boot/me/loop.ml
+++ b/src/boot/me/loop.ml
@@ -148,8 +148,8 @@ let process_crate
|]
in
- run_passes cx "loop" path passes (log cx "%s") crate;
- ()
+ run_passes cx "loop" path passes
+ cx.ctxt_sess.Session.sess_log_loop log crate
;;
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
index 77fdbb3b..2c2b1b4b 100644
--- a/src/boot/me/resolve.ml
+++ b/src/boot/me/resolve.ml
@@ -167,7 +167,7 @@ let all_item_collecting_visitor
Array.iter (fun p -> htab_put cx.ctxt_all_defns p.id
(DEFN_ty_param p.node)) p;
htab_put cx.ctxt_all_defns i.id (DEFN_item i.node);
- htab_put cx.ctxt_all_item_names i.id (Walk.path_to_name path);
+ htab_put cx.ctxt_all_item_names i.id (path_to_name path);
log cx "collected item #%d: %s" (int_of_node i.id) n;
begin
match i.node.Ast.decl_item with
@@ -191,14 +191,14 @@ let all_item_collecting_visitor
let visit_obj_fn_pre obj ident fn =
htab_put cx.ctxt_all_defns fn.id (DEFN_obj_fn (obj.id, fn.node));
- htab_put cx.ctxt_all_item_names fn.id (Walk.path_to_name path);
+ htab_put cx.ctxt_all_item_names fn.id (path_to_name path);
note_header fn.id fn.node.Ast.fn_input_slots;
inner.Walk.visit_obj_fn_pre obj ident fn
in
let visit_obj_drop_pre obj b =
htab_put cx.ctxt_all_defns b.id (DEFN_obj_drop obj.id);
- htab_put cx.ctxt_all_item_names b.id (Walk.path_to_name path);
+ htab_put cx.ctxt_all_item_names b.id (path_to_name path);
inner.Walk.visit_obj_drop_pre obj b
in
@@ -210,7 +210,7 @@ let all_item_collecting_visitor
htab_put cx.ctxt_all_defns id
(DEFN_loop_body (Stack.top items));
htab_put cx.ctxt_all_item_names id
- (Walk.path_to_name path);
+ (path_to_name path);
| _ -> ()
end;
inner.Walk.visit_stmt_pre s;
@@ -1035,14 +1035,14 @@ let process_crate
export_referencing_visitor cx Walk.empty_visitor
|]
in
-
+ let log_flag = cx.ctxt_sess.Session.sess_log_resolve in
log cx "running primary resolve passes";
- run_passes cx "resolve collect" path passes_0 (log cx "%s") crate;
+ run_passes cx "resolve collect" path passes_0 log_flag log crate;
resolve_recursion cx node_to_references recursive_tag_groups;
log cx "running secondary resolve passes";
- run_passes cx "resolve bind" path passes_1 (log cx "%s") crate;
+ run_passes cx "resolve bind" path passes_1 log_flag log crate;
log cx "running tertiary resolve passes";
- run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate;
+ run_passes cx "resolve patterns" path passes_2 log_flag log crate;
iflog cx
begin
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 64f2c939..434fb025 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -583,13 +583,13 @@ let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array =
;;
let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
- Array.concat (List.map (atom_slots cx) (Array.to_list az))
+ Array.concat (List.map (atom_slots cx) (Array.to_list (Array.map snd az)))
;;
let rec_inputs_slots (cx:ctxt)
(inputs:Ast.rec_input array) : node_id array =
Array.concat (List.map
- (fun (_, atom) -> atom_slots cx atom)
+ (fun (_, _, atom) -> atom_slots cx atom)
(Array.to_list inputs))
;;
@@ -1506,6 +1506,97 @@ let unreferenced_required_item_ignoring_visitor
Walk.visit_obj_drop_post = visit_obj_drop_post; }
;;
+let rec name_of ncs =
+ match ncs with
+ [] -> bug () "Walk.name_of_ncs: empty path"
+ | [(Ast.COMP_ident i)] -> Ast.NAME_base (Ast.BASE_ident i)
+ | [(Ast.COMP_app x)] -> Ast.NAME_base (Ast.BASE_app x)
+ | [(Ast.COMP_idx _)] ->
+ bug () "Walk.name_of_ncs: path-name contains COMP_idx"
+ | nc::ncs -> Ast.NAME_ext (name_of ncs, nc)
+;;
+
+let path_to_name
+ (path:Ast.name_component Stack.t)
+ : Ast.name =
+ name_of (stk_elts_from_top path)
+;;
+
+let mod_item_logging_visitor
+ (cx:ctxt)
+ (log_flag:bool)
+ (log:ctxt -> ('a, unit, string, unit) format4 -> 'a)
+ (pass:int)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.
+visitor =
+ let entering _ =
+ if log_flag
+ then
+ log cx "pass %d: entering %a"
+ pass Ast.sprintf_name (path_to_name path)
+ in
+ let entered _ =
+ if log_flag
+ then
+ log cx "pass %d: entered %a"
+ pass Ast.sprintf_name (path_to_name path)
+ in
+ let leaving _ =
+ if log_flag
+ then
+ log cx "pass %d: leaving %a"
+ pass Ast.sprintf_name (path_to_name path)
+ in
+ let left _ =
+ if log_flag
+ then
+ log cx "pass %d: left %a"
+ pass Ast.sprintf_name (path_to_name path)
+ in
+
+ let visit_mod_item_pre name params item =
+ entering();
+ inner.Walk.visit_mod_item_pre name params item;
+ entered();
+ in
+ let visit_mod_item_post name params item =
+ leaving();
+ inner.Walk.visit_mod_item_post name params item;
+ left();
+ in
+ let visit_obj_fn_pre obj ident fn =
+ entering();
+ inner.Walk.visit_obj_fn_pre obj ident fn;
+ entered();
+ in
+ let visit_obj_fn_post obj ident fn =
+ leaving();
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ left();
+ in
+ let visit_obj_drop_pre obj b =
+ entering();
+ inner.Walk.visit_obj_drop_pre obj b;
+ entered();
+ in
+ let visit_obj_drop_post obj fn =
+ leaving();
+ inner.Walk.visit_obj_drop_post obj fn;
+ left();
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post;
+ Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+ Walk.visit_obj_fn_post = visit_obj_fn_post;
+ Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+ Walk.visit_obj_drop_post = visit_obj_drop_post;
+ }
+;;
+
+
(* Generic lookup, used for slots, items, types, etc. *)
@@ -1752,14 +1843,14 @@ let run_passes
(name:string)
(path:Ast.name_component Stack.t)
(passes:Walk.visitor array)
- (log:string->unit)
+ (log_flag:bool)
+ (log:ctxt -> ('a, unit, string, unit) format4 -> 'a)
(crate:Ast.crate)
: unit =
let do_pass i pass =
- let logger s = log (Printf.sprintf "pass %d: %s" i s) in
Walk.walk_crate
(Walk.path_managing_visitor path
- (Walk.mod_item_logging_visitor logger path pass))
+ (mod_item_logging_visitor cx log_flag log i path pass))
crate
in
let sess = cx.ctxt_sess in
@@ -1936,10 +2027,10 @@ let call_args_referent_type_full
[|
out_ptr_rty; (* Abi.calltup_elt_out_ptr *)
task_ptr_rty; (* Abi.calltup_elt_task_ptr *)
+ Il.StructTy indirect_arg_rtys; (* Abi.calltup_elt_indirect_args *)
ty_param_rtys; (* Abi.calltup_elt_ty_params *)
arg_rtys; (* Abi.calltup_elt_args *)
- Il.StructTy iterator_arg_rtys; (* Abi.calltup_elt_iterator_args *)
- Il.StructTy indirect_arg_rtys (* Abi.calltup_elt_indirect_args *)
+ Il.StructTy iterator_arg_rtys (* Abi.calltup_elt_iterator_args *)
|]
;;
@@ -1950,13 +2041,12 @@ let call_args_referent_type
(closure:Il.referent_ty option)
: Il.referent_ty =
let indirect_arg_rtys =
+ (* Abi.indirect_args_elt_closure *)
match closure with
- None -> [| |]
+ None ->
+ [| word_rty cx.ctxt_abi |]
| Some c ->
- [|
- (* Abi.indirect_args_elt_closure *)
- Il.ScalarTy (Il.AddrTy c)
- |]
+ [| Il.ScalarTy (Il.AddrTy c) |]
in
let iterator_arg_rtys _ =
[|
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index f77386a9..46329a10 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -225,7 +225,7 @@ let trans_visitor
let epilogue_jumps = Stack.create() in
let path_name (_:unit) : string =
- string_of_name (Walk.path_to_name path)
+ string_of_name (path_to_name path)
in
let based (reg:Il.reg) : Il.mem =
@@ -1228,8 +1228,8 @@ let trans_visitor
(sorted_htab_keys fns))
end
- and trans_init_str (dst:Ast.lval) (s:string) : unit =
- (* Include null byte. *)
+ and trans_init_str (dst:Ast.lval) (s:string) : unit =
+ (* Include null byte. *)
let init_sz = Int64.of_int ((String.length s) + 1) in
let static = trans_static_string s in
let (dst, _) = trans_lval_init dst in
@@ -1715,49 +1715,63 @@ let trans_visitor
(code:Il.code)
(dst:Il.cell option)
(args:Il.cell array)
+ (clo:Il.cell option)
: unit =
- let inner dst =
+ let inner dst cloptr =
let scratch = next_vreg_cell Il.voidptr_t in
let pop _ = emit (Il.Pop scratch) in
for i = ((Array.length args) - 1) downto 0
do
emit (Il.Push (Il.Cell args.(i)))
done;
+ emit (Il.Push cloptr);
emit (Il.Push (Il.Cell abi.Abi.abi_tp_cell));
emit (Il.Push dst);
call_code code;
pop ();
pop ();
+ pop ();
Array.iter (fun _ -> pop()) args;
in
+ let cloptr =
+ match clo with
+ None -> zero
+ | Some cloptr -> Il.Cell cloptr
+ in
match dst with
- None -> inner zero
- | Some dst -> aliasing true dst (fun dst -> inner (Il.Cell dst))
+ None -> inner zero cloptr
+ | Some dst ->
+ aliasing true dst (fun dst -> inner (Il.Cell dst) cloptr)
and trans_call_static_glue
(callee:Il.operand)
(dst:Il.cell option)
(args:Il.cell array)
+ (clo:Il.cell option)
: unit =
- trans_call_glue (code_of_operand callee) dst args
+ trans_call_glue (code_of_operand callee) dst args clo
and trans_call_dynamic_glue
(tydesc:Il.cell)
(idx:int)
(dst:Il.cell option)
(args:Il.cell array)
+ (clo:Il.cell option)
: unit =
let fptr = get_vtbl_entry_idx tydesc idx in
- trans_call_glue (code_of_operand (Il.Cell fptr)) dst args
+ trans_call_glue (code_of_operand (Il.Cell fptr)) dst args clo
and trans_call_simple_static_glue
(fix:fixup)
(ty_params:Il.cell)
- (arg:Il.cell)
+ (args:Il.cell array)
+ (clo:Il.cell option)
: unit =
trans_call_static_glue
(code_fixup_to_ptr_operand fix)
- None [| alias ty_params; arg |]
+ None
+ (Array.append [| alias ty_params |] args)
+ clo
and get_tydesc_params
(outer_ty_params:Il.cell)
@@ -1779,7 +1793,8 @@ let trans_visitor
(ty_param:int)
(vtbl_idx:int)
(ty_params:Il.cell)
- (arg:Il.cell)
+ (args:Il.cell array)
+ (clo:Il.cell option)
: unit =
iflog (fun _ ->
annotate (Printf.sprintf "calling tydesc[%d].glue[%d]"
@@ -1787,8 +1802,11 @@ let trans_visitor
let td = get_ty_param ty_params ty_param in
let ty_params_ptr = get_tydesc_params ty_params td in
trans_call_dynamic_glue
- td vtbl_idx
- None [| ty_params_ptr; arg; |]
+ td
+ vtbl_idx
+ None
+ (Array.append [| ty_params_ptr |] args)
+ clo
(* trans_compare returns a quad number of the cjmp, which the caller
patches to the cjmp destination. *)
@@ -2453,36 +2471,41 @@ let trans_visitor
note_drop_step ty "drop_ty: obj path";
let binding = get_element_ptr cell Abi.binding_field_binding in
let null_jmp = null_check binding in
+ let rc_jmp = drop_refcount_and_cmp binding in
let obj = deref binding in
- let rc = get_element_ptr obj 0 in
- let rc_jmp = drop_refcount_and_cmp rc in
let tydesc = get_element_ptr obj 1 in
let body = get_element_ptr obj 2 in
- let ty_params =
- get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
- in
+ let ty_params = get_tydesc_params ty_params tydesc in
let dtor =
get_element_ptr (deref tydesc) Abi.tydesc_field_obj_drop_glue
in
let null_dtor_jmp = null_check dtor in
(* Call any dtor, if present. *)
- note_drop_step ty "drop_ty: calling obj dtor";
- trans_call_dynamic_glue tydesc
- Abi.tydesc_field_obj_drop_glue None [| binding |];
- patch null_dtor_jmp;
- (* Drop the body. *)
- note_drop_step ty "drop_ty: dropping obj body";
- trans_call_dynamic_glue tydesc
- Abi.tydesc_field_drop_glue None [| ty_params; alias body |];
- (* FIXME: this will fail if the user has lied about the
- * state-ness of their obj. We need to store state-ness in the
- * captured tydesc, and use that. *)
- note_drop_step ty "drop_ty: freeing obj body";
- trans_free binding (type_has_state ty);
- mov binding zero;
- patch rc_jmp;
- patch null_jmp;
- note_drop_step ty "drop_ty: done obj path";
+ note_drop_step ty "drop_ty: calling obj dtor";
+ trans_call_dynamic_glue
+ tydesc
+ Abi.tydesc_field_obj_drop_glue
+ None
+ [| binding |]
+ (Some binding);
+ patch null_dtor_jmp;
+ (* Drop the body. *)
+ note_drop_step ty "drop_ty: dropping obj body";
+ trans_call_dynamic_glue
+ tydesc
+ Abi.tydesc_field_drop_glue
+ None
+ [| ty_params; alias body |]
+ None;
+ (* FIXME: this will fail if the user has lied about the
+ * state-ness of their obj. We need to store state-ness in the
+ * captured tydesc, and use that. *)
+ note_drop_step ty "drop_ty: freeing obj body";
+ trans_free binding (type_has_state ty);
+ mov binding zero;
+ patch rc_jmp;
+ patch null_jmp;
+ note_drop_step ty "drop_ty: done obj path";
| Ast.TY_param (i, _) ->
@@ -2491,7 +2514,11 @@ let trans_visitor
begin
fun cell ->
trans_call_simple_dynamic_glue
- i Abi.tydesc_field_drop_glue ty_params cell
+ i
+ Abi.tydesc_field_drop_glue
+ ty_params
+ [| cell |]
+ None
end;
note_drop_step ty "drop_ty: done parametric-ty path";
@@ -2505,8 +2532,7 @@ let trans_visitor
let _ = check_box_rty cell in
let null_jmp = null_check cell in
- let rc = box_rc_cell cell in
- let j = drop_refcount_and_cmp rc in
+ let j = drop_refcount_and_cmp cell in
(* FIXME (issue #25): check to see that the box has
* further box members; if it doesn't we can elide the
@@ -2514,7 +2540,9 @@ let trans_visitor
trans_call_simple_static_glue
(get_free_glue ty (mctrl = MEM_gc) curr_iso)
- ty_params cell;
+ ty_params
+ [| cell |]
+ None;
(* Null the slot out to prevent double-free if the frame
* unwinds.
@@ -2525,7 +2553,7 @@ let trans_visitor
note_drop_step ty "drop_ty: done box-drop path";
| MEM_interior when type_is_structured ty ->
- note_drop_step ty "drop:ty structured-interior path";
+ note_drop_step ty "drop_ty structured-interior path";
iter_ty_parts ty_params cell ty
(drop_ty ty_params) curr_iso;
note_drop_step ty "drop_ty: done structured-interior path";
@@ -2603,7 +2631,7 @@ let trans_visitor
trans_call_static_glue
(code_fixup_to_ptr_operand glue_fix)
(Some dst)
- [| alias ty_params; src; clone_task |]
+ [| alias ty_params; src; clone_task |] None
| _ ->
iter_ty_parts_full ty_params dst src ty
(clone_ty ty_params clone_task) curr_iso
@@ -2640,7 +2668,10 @@ let trans_visitor
lea vr body_mem;
trace_word cx.ctxt_sess.Session.sess_trace_drop vr;
trans_call_simple_static_glue
- (get_drop_glue body_ty curr_iso) ty_params vr;
+ (get_drop_glue body_ty curr_iso)
+ ty_params
+ [| vr |]
+ None;
note_drop_step ty "in free-ty, calling free";
trans_free cell is_gc;
end;
@@ -2700,7 +2731,9 @@ let trans_visitor
lea tmp body_mem;
trans_call_simple_static_glue
(get_mark_glue ty curr_iso)
- ty_params tmp;
+ ty_params
+ [| tmp |]
+ None;
List.iter patch marked_jump;
| MEM_interior when type_is_structured ty ->
@@ -2714,7 +2747,9 @@ let trans_visitor
lea tmp mem;
trans_call_simple_static_glue
(get_mark_glue ty curr_iso)
- ty_params tmp
+ ty_params
+ [| tmp |]
+ None
| _ -> ()
@@ -2740,14 +2775,35 @@ let trans_visitor
emit (Il.jmp Il.JE Il.CodeNone);
j
- and drop_refcount_and_cmp (rc:Il.cell) : quad_idx =
+ and drop_refcount_and_cmp (boxed:Il.cell) : quad_idx =
iflog (fun _ -> annotate "drop refcount and maybe free");
+ let rc = box_rc_cell boxed in
+ if cx.ctxt_sess.Session.sess_trace_gc ||
+ cx.ctxt_sess.Session.sess_trace_drop
+ then
+ begin
+ trace_str true "refcount--";
+ trace_word true boxed;
+ trace_word true rc
+ end;
emit (Il.binary Il.SUB rc (Il.Cell rc) one);
emit (Il.cmp (Il.Cell rc) zero);
let j = mark () in
emit (Il.jmp Il.JNE Il.CodeNone);
j
+ and incr_refcount (boxed:Il.cell) : unit =
+ let rc = box_rc_cell boxed in
+ if cx.ctxt_sess.Session.sess_trace_gc ||
+ cx.ctxt_sess.Session.sess_trace_drop
+ then
+ begin
+ trace_str true "refcount++";
+ trace_word true boxed;
+ trace_word true rc
+ end;
+ add_to rc one
+
and drop_slot
(ty_params:Il.cell)
(cell:Il.cell)
@@ -2917,7 +2973,7 @@ let trans_visitor
| (MEM_rc_struct, MEM_rc_struct) ->
(* Lightweight copy: twiddle refcounts, move pointer. *)
anno "refcounted light";
- add_to (box_rc_cell src) one;
+ incr_refcount src;
if not initializing
then
drop_ty ty_params dst dst_ty None;
@@ -3012,7 +3068,9 @@ let trans_visitor
let ty_params_ptr = get_tydesc_params ty_params td in
trans_call_dynamic_glue
td Abi.tydesc_field_copy_glue
- (Some dst) [| ty_params_ptr; src; |]
+ (Some dst)
+ [| ty_params_ptr; src; |]
+ None
end
| Ast.TY_fn _
@@ -3186,13 +3244,13 @@ let trans_visitor
(dst:Il.cell)
(dst_tys:Ast.ty array)
(trec:Ast.ty_rec)
- (atab:(Ast.ident * Ast.atom) array)
+ (atab:(Ast.ident * Ast.mutability * Ast.atom) array)
(base:Ast.lval)
: unit =
Array.iteri
begin
fun i (fml_ident, _) ->
- let fml_entry _ (act_ident, atom) =
+ let fml_entry _ (act_ident, _, atom) =
if act_ident = fml_ident then Some atom else None
in
let dst_ty = dst_tys.(i) in
@@ -3537,6 +3595,9 @@ let trans_visitor
let callee_task_cell =
get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr
in
+ let callee_indirect_args =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_indirect_args
+ in
let callee_ty_params =
get_element_ptr all_callee_args_cell Abi.calltup_elt_ty_params
in
@@ -3548,10 +3609,6 @@ let trans_visitor
get_element_ptr_dyn_in_current_frame
all_callee_args_cell Abi.calltup_elt_iterator_args
in
- let callee_indirect_args =
- get_element_ptr_dyn_in_current_frame
- all_callee_args_cell Abi.calltup_elt_indirect_args
- in
let n_args = Array.length call.call_args in
let n_iterators = Array.length call.call_iterator_args in
@@ -3611,9 +3668,9 @@ let trans_visitor
end
call.call_callee_ty_params;
- trans_arg1 callee_task_cell;
+ trans_arg1 callee_task_cell;
- trans_arg0 callee_output_cell initializing_arg0 call
+ trans_arg0 callee_output_cell initializing_arg0 call
@@ -4002,10 +4059,9 @@ let trans_visitor
let dst_slot_id = (fst (fo.Ast.for_slot)).id in
let dst_slot = get_slot cx dst_slot_id in
let dst_cell = cell_of_block_slot dst_slot_id in
- let (head_stmts, seq) = fo.Ast.for_seq in
+ let seq = fo.Ast.for_seq in
let (seq_cell, seq_ty) = trans_lval seq in
let unit_ty = seq_unit_ty seq_ty in
- Array.iter trans_stmt head_stmts;
iter_seq_parts ty_params seq_cell seq_cell unit_ty
begin
fun _ src_cell unit_ty _ ->
@@ -4070,7 +4126,11 @@ let trans_visitor
let fp = get_iter_outer_frame_ptr_for_current_frame () in
let vr = next_vreg_cell Il.voidptr_t in
mov vr zero;
- trans_call_glue (code_of_operand block_fptr) None [| vr; fp |]
+ trans_call_glue
+ (code_of_operand block_fptr)
+ None
+ [| vr; fp |]
+ None
and trans_vec_append dst_cell dst_ty src_oper src_ty =
let elt_ty = seq_unit_ty dst_ty in
@@ -4255,7 +4315,7 @@ let trans_visitor
begin
match base with
None ->
- let atoms = Array.map snd atab in
+ let atoms = Array.map (fun (_, _, atom) -> atom) atab in
trans_init_structural_from_atoms
dst_cell dst_tys atoms
| Some base_lval ->
@@ -4263,7 +4323,7 @@ let trans_visitor
dst_cell dst_tys trec atab base_lval
end
- | Ast.STMT_init_tup (dst, atoms) ->
+ | Ast.STMT_init_tup (dst, elems) ->
let (slot_cell, ty) = trans_lval_init dst in
let dst_tys =
match ty with
@@ -4272,6 +4332,7 @@ let trans_visitor
bugi cx stmt.id
"non-tup destination type in stmt_init_tup"
in
+ let atoms = Array.map snd elems in
let (dst_cell, _) = deref_ty DEREF_none true slot_cell ty in
trans_init_structural_from_atoms dst_cell dst_tys atoms
@@ -4279,7 +4340,7 @@ let trans_visitor
| Ast.STMT_init_str (dst, s) ->
trans_init_str dst s
- | Ast.STMT_init_vec (dst, atoms) ->
+ | Ast.STMT_init_vec (dst, _, atoms) ->
trans_init_vec dst atoms
| Ast.STMT_init_port dst ->
@@ -4297,7 +4358,7 @@ let trans_visitor
trans_init_chan dst p
end
- | Ast.STMT_init_box (dst, src) ->
+ | Ast.STMT_init_box (dst, _, src) ->
trans_init_box dst src
| Ast.STMT_block block ->
@@ -4614,7 +4675,7 @@ let trans_visitor
trans_crate_rel_static_string_frag (string_of_name_component nc)
in
trans_crate_rel_data_operand
- (DATA_name (Walk.name_of ncs))
+ (DATA_name (name_of ncs))
(fun _ -> Asm.SEQ (Array.append
(Array.map f (Array.of_list ncs))
[| Asm.WORD (word_ty_mach, Asm.IMM 0L) |]))
@@ -5012,7 +5073,7 @@ let fixup_assigning_visitor
: Walk.visitor =
let path_name (_:unit) : string =
- Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
+ Fmt.fmt_to_str Ast.fmt_name (path_to_name path)
in
let enter_file_for id =
@@ -5110,11 +5171,8 @@ let process_crate
(fixup_assigning_visitor cx path
Walk.empty_visitor));
(unreferenced_required_item_ignoring_visitor cx
- (Walk.mod_item_logging_visitor
- (log cx "translation pass: %s")
- path
- (trans_visitor cx path
- Walk.empty_visitor)))
+ (trans_visitor cx path
+ Walk.empty_visitor))
|];
in
log cx "translating crate";
@@ -5123,7 +5181,8 @@ let process_crate
None -> ()
| Some m -> log cx "with main fn %s" m
end;
- run_passes cx "trans" path passes (log cx "%s") crate;
+ run_passes cx "trans" path passes
+ cx.ctxt_sess.Session.sess_log_trans log crate;
;;
(*
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index b27e68dc..45570708 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -216,6 +216,20 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
in
let retval_tvs = Stack.create () in
+ let fns = Stack.create () in
+
+ let push_fn fn =
+ Stack.push fn fns
+ in
+
+ let pop_fn _ =
+ ignore (Stack.pop fns)
+ in
+
+ let fn_is_iter() =
+ (Stack.top fns).Ast.fn_aux.Ast.fn_is_iter
+ in
+
let push_retval_tv tv =
Stack.push tv retval_tvs
in
@@ -1130,7 +1144,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
| Ast.STMT_init_rec (dst, fields, Some base) ->
let dct = Hashtbl.create 10 in
let tvrec = ref (TYSPEC_record dct) in
- let add_field (ident, atom) =
+ let add_field (ident, _, atom) =
let tv = any() in
unify_atom arg_pass_ctx atom tv;
Hashtbl.add dct ident tv
@@ -1143,7 +1157,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
| Ast.STMT_init_rec (dst, fields, None) ->
let dct = Hashtbl.create 10 in
- let add_field (ident, atom) =
+ let add_field (ident, _, atom) =
let tv = any() in
unify_atom arg_pass_ctx atom tv;
Hashtbl.add dct ident tv
@@ -1152,7 +1166,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
unify_lval init_ctx dst (ref (TYSPEC_record dct))
| Ast.STMT_init_tup (dst, members) ->
- let member_to_tv atom =
+ let member_to_tv (_, atom) =
let tv = any() in
unify_atom arg_pass_ctx atom tv;
tv
@@ -1160,7 +1174,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
let member_tvs = Array.map member_to_tv members in
unify_lval init_ctx dst (ref (TYSPEC_tuple member_tvs))
- | Ast.STMT_init_vec (dst, atoms) ->
+ | Ast.STMT_init_vec (dst, _, atoms) ->
let tv = any() in
let unify_with_tv atom = unify_atom arg_pass_ctx atom tv in
Array.iter unify_with_tv atoms;
@@ -1215,13 +1229,27 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
| Ast.STMT_if { Ast.if_test = if_test } ->
unify_expr rval_ctx if_test (ty Ast.TY_bool);
- | Ast.STMT_ret atom_opt
- | Ast.STMT_put atom_opt ->
+ | Ast.STMT_ret atom_opt ->
begin
+ if fn_is_iter()
+ then
+ match atom_opt with
+ | None -> ()
+ | Some _ -> err None "Iter returning value"
+ else
+ match atom_opt with
+ | None -> unify_ty arg_pass_ctx Ast.TY_nil (retval_tv())
+ | Some atom -> unify_atom arg_pass_ctx atom (retval_tv())
+ end
+
+ | Ast.STMT_put atom_opt ->
+ if fn_is_iter()
+ then
match atom_opt with
- None -> unify_ty arg_pass_ctx Ast.TY_nil (retval_tv())
+ | None -> unify_ty arg_pass_ctx Ast.TY_nil (retval_tv())
| Some atom -> unify_atom arg_pass_ctx atom (retval_tv())
- end
+ else
+ err None "Non-iter function with 'put'"
| Ast.STMT_be (callee, args) ->
check_callable (retval_tv()) callee args
@@ -1263,7 +1291,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
let mem_tv = ref TYSPEC_all in
let seq_tv = ref (TYSPEC_collection mem_tv) in
let (si, _) = fo.Ast.for_slot in
- let (_, seq) = fo.Ast.for_seq in
+ let seq = fo.Ast.for_seq in
unify_lval rval_ctx seq seq_tv;
unify_slot lval_ctx si.node (Some si.id) mem_tv
@@ -1276,7 +1304,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
| Ast.STMT_join lval ->
unify_lval rval_ctx lval (ty Ast.TY_task);
- | Ast.STMT_init_box (dst, v) ->
+ | Ast.STMT_init_box (dst, _, v) ->
let in_tv = any() in
let tv = ref (TYSPEC_mutable (ref (TYSPEC_box in_tv))) in
unify_lval strict_ctx dst tv;
@@ -1344,11 +1372,17 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
in
let enter_fn fn retspec =
+ push_fn fn;
let out = fn.Ast.fn_output_slot in
push_retval_tv (ref retspec);
unify_slot arg_pass_ctx out.node (Some out.id) (retval_tv())
in
+ let leave_fn _ =
+ pop_retval_tv ();
+ pop_fn ();
+ in
+
let visit_obj_fn_pre obj ident fn =
enter_fn fn.node TYSPEC_all;
inner.Walk.visit_obj_fn_pre obj ident fn
@@ -1356,7 +1390,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
let visit_obj_fn_post obj ident fn =
inner.Walk.visit_obj_fn_post obj ident fn;
- pop_retval_tv ();
+ leave_fn ();
in
let visit_mod_item_pre n p mod_item =
@@ -1374,7 +1408,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
in
let path_name (_:unit) : string =
- string_of_name (Walk.path_to_name path)
+ string_of_name (path_to_name path)
in
let visit_mod_item_post n p mod_item =
@@ -1382,7 +1416,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
match mod_item.node.Ast.decl_item with
| Ast.MOD_ITEM_fn _ ->
- pop_retval_tv ();
+ leave_fn ();
if (Some (path_name())) = cx.ctxt_main_name
then
begin
@@ -1528,9 +1562,8 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
Hashtbl.iter init_mod_dict cx.ctxt_all_defns;
Walk.walk_crate
(Walk.path_managing_visitor path
- (Walk.mod_item_logging_visitor
- (log cx "typechecking pass: %s")
- path
+ (mod_item_logging_visitor cx
+ cx.ctxt_sess.Session.sess_log_type log 0 path
(visitor cx Walk.empty_visitor)))
crate;
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index 3a13561a..cca548b8 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -434,7 +434,7 @@ let condition_assigning_visitor
raise_pre_post_cond s.id precond;
raise_postcondition s.id postcond
- | Ast.STMT_init_vec (dst, atoms) ->
+ | Ast.STMT_init_vec (dst, _, atoms) ->
let precond = slot_inits (atoms_slots cx atoms) in
let postcond = slot_inits (lval_slots cx dst) in
raise_pre_post_cond s.id precond;
@@ -454,7 +454,7 @@ let condition_assigning_visitor
raise_pre_post_cond s.id precond;
raise_postcondition s.id postcond
- | Ast.STMT_init_box (dst, src) ->
+ | Ast.STMT_init_box (dst, _, src) ->
let precond = slot_inits (atom_slots cx src) in
let postcond = slot_inits (lval_slots cx dst) in
raise_pre_post_cond s.id precond;
@@ -533,7 +533,7 @@ let condition_assigning_visitor
| Ast.STMT_for fo ->
let (si, _) = fo.Ast.for_slot in
- let (_, lval) = fo.Ast.for_seq in
+ let lval = fo.Ast.for_seq in
let precond = slot_inits (lval_slots cx lval) in
let block_entry_state = [| Constr_init si.id |] in
raise_pre_post_cond s.id precond;
@@ -988,23 +988,30 @@ let lifecycle_visitor
* used later on in translation.
*)
- let (live_block_slots:(node_id Stack.t) Stack.t) = Stack.create () in
+ let (live_block_slots:(node_id, unit) Hashtbl.t) = Hashtbl.create 0 in
+ let (block_slots:(node_id Stack.t) Stack.t) = Stack.create () in
let (implicit_init_block_slots:(node_id,node_id) Hashtbl.t) =
Hashtbl.create 0
in
+ let push_slot sl =
+ Stack.push sl (Stack.top block_slots)
+ in
+
let mark_slot_init sl =
- Stack.push sl (Stack.top live_block_slots)
+ Hashtbl.replace live_block_slots sl ()
in
let visit_block_pre b =
- Stack.push (Stack.create()) live_block_slots;
+ Stack.push (Stack.create()) block_slots;
begin
match htab_search implicit_init_block_slots b.id with
None -> ()
- | Some slot -> mark_slot_init slot
+ | Some slot ->
+ push_slot slot;
+ mark_slot_init slot
end;
inner.Walk.visit_block_pre b
in
@@ -1026,7 +1033,7 @@ let lifecycle_visitor
let visit_block_post b =
inner.Walk.visit_block_post b;
- let blk_live = Stack.pop live_block_slots in
+ let blk_slots = Stack.pop block_slots in
let stmts = b.node in
let len = Array.length stmts in
if len > 0
@@ -1037,9 +1044,22 @@ let lifecycle_visitor
Ast.STMT_ret _
| Ast.STMT_be _ ->
() (* Taken care of in visit_stmt_post below. *)
- | _ ->
- let slots = stk_elts_from_top blk_live in
- note_drops s slots
+ | _ ->
+ (* The blk_slots stack we have has accumulated slots in
+ * declaration order as we walked the block; the top of the
+ * stack is the last-declared slot. We want to generate
+ * slot-drop obligations here for the slots in top-down order
+ * (starting with the last-declared) but only hitting those
+ * slots that actually got initialized (went live) at some
+ * point in the block.
+ *)
+ let slots = stk_elts_from_top blk_slots in
+ let live =
+ List.filter
+ (fun i -> Hashtbl.mem live_block_slots i)
+ slots
+ in
+ note_drops s live
end;
in
@@ -1081,13 +1101,16 @@ let lifecycle_visitor
init_lval lv_dst
end;
+ | Ast.STMT_decl (Ast.DECL_slot (_, sloti)) ->
+ push_slot sloti.id
+
| Ast.STMT_init_rec (lv_dst, _, _)
| Ast.STMT_init_tup (lv_dst, _)
- | Ast.STMT_init_vec (lv_dst, _)
+ | Ast.STMT_init_vec (lv_dst, _, _)
| Ast.STMT_init_str (lv_dst, _)
| Ast.STMT_init_port lv_dst
| Ast.STMT_init_chan (lv_dst, _)
- | Ast.STMT_init_box (lv_dst, _) ->
+ | Ast.STMT_init_box (lv_dst, _, _) ->
init_lval lv_dst
| Ast.STMT_for f ->
@@ -1107,7 +1130,7 @@ let lifecycle_visitor
(fst f.Ast.for_each_slot).id
- | _ -> ()
+ | _ -> ()
end;
inner.Walk.visit_stmt_pre s
in
@@ -1117,9 +1140,14 @@ let lifecycle_visitor
match s.node with
Ast.STMT_ret _
| Ast.STMT_be _ ->
- let stks = stk_elts_from_top live_block_slots in
+ let stks = stk_elts_from_top block_slots in
let slots = List.concat (List.map stk_elts_from_top stks) in
- note_drops s slots
+ let live =
+ List.filter
+ (fun i -> Hashtbl.mem live_block_slots i)
+ slots
+ in
+ note_drops s live
| _ -> ()
in
@@ -1171,10 +1199,11 @@ let process_crate
Walk.empty_visitor)
|]
in
- run_passes cx "typestate setup" path setup_passes (log cx "%s") crate;
+ let log_flag = cx.ctxt_sess.Session.sess_log_typestate in
+ run_passes cx "typestate setup" path setup_passes log_flag log crate;
run_dataflow cx constr_id graph;
- run_passes cx "typestate verify" path verify_passes (log cx "%s") crate;
- run_passes cx "typestate aux" path aux_passes (log cx "%s") crate
+ run_passes cx "typestate verify" path verify_passes log_flag log crate;
+ run_passes cx "typestate aux" path aux_passes log_flag log crate
;;
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
index 0b60c832..fac44170 100644
--- a/src/boot/me/walk.ml
+++ b/src/boot/me/walk.ml
@@ -123,69 +123,6 @@ let path_managing_visitor
}
;;
-let rec name_of ncs =
- match ncs with
- [] -> bug () "Walk.name_of_ncs: empty path"
- | [(Ast.COMP_ident i)] -> Ast.NAME_base (Ast.BASE_ident i)
- | [(Ast.COMP_app x)] -> Ast.NAME_base (Ast.BASE_app x)
- | [(Ast.COMP_idx _)] ->
- bug () "Walk.name_of_ncs: path-name contains COMP_idx"
- | nc::ncs -> Ast.NAME_ext (name_of ncs, nc)
-;;
-
-let path_to_name
- (path:Ast.name_component Stack.t)
- : Ast.name =
- name_of (stk_elts_from_top path)
-;;
-
-
-let mod_item_logging_visitor
- (logfn:string->unit)
- (path:Ast.name_component Stack.t)
- (inner:visitor)
- : visitor =
- let path_name _ = Fmt.fmt_to_str Ast.fmt_name (path_to_name path) in
- let visit_mod_item_pre name params item =
- logfn (Printf.sprintf "entering %s" (path_name()));
- inner.visit_mod_item_pre name params item;
- logfn (Printf.sprintf "entered %s" (path_name()));
- in
- let visit_mod_item_post name params item =
- logfn (Printf.sprintf "leaving %s" (path_name()));
- inner.visit_mod_item_post name params item;
- logfn (Printf.sprintf "left %s" (path_name()));
- in
- let visit_obj_fn_pre obj ident fn =
- logfn (Printf.sprintf "entering %s" (path_name()));
- inner.visit_obj_fn_pre obj ident fn;
- logfn (Printf.sprintf "entered %s" (path_name()));
- in
- let visit_obj_fn_post obj ident fn =
- logfn (Printf.sprintf "leaving %s" (path_name()));
- inner.visit_obj_fn_post obj ident fn;
- logfn (Printf.sprintf "left %s" (path_name()));
- in
- let visit_obj_drop_pre obj b =
- logfn (Printf.sprintf "entering %s" (path_name()));
- inner.visit_obj_drop_pre obj b;
- logfn (Printf.sprintf "entered %s" (path_name()));
- in
- let visit_obj_drop_post obj fn =
- logfn (Printf.sprintf "leaving %s" (path_name()));
- inner.visit_obj_drop_post obj fn;
- logfn (Printf.sprintf "left %s" (path_name()));
- in
- { inner with
- visit_mod_item_pre = visit_mod_item_pre;
- visit_mod_item_post = visit_mod_item_post;
- visit_obj_fn_pre = visit_obj_fn_pre;
- visit_obj_fn_post = visit_obj_fn_post;
- visit_obj_drop_pre = visit_obj_drop_pre;
- visit_obj_drop_post = visit_obj_drop_post;
- }
-;;
-
let walk_bracketed
(pre:'a -> unit)
@@ -419,9 +356,8 @@ and walk_stmt
(s:Ast.stmt_for)
: unit =
let (si,_) = s.Ast.for_slot in
- let (ss,lv) = s.Ast.for_seq in
+ let lv = s.Ast.for_seq in
walk_slot_identified v si;
- Array.iter (walk_stmt v) ss;
walk_lval v lv;
walk_block v s.Ast.for_body
in
@@ -450,16 +386,16 @@ and walk_stmt
| Ast.STMT_init_rec (lv, atab, base) ->
walk_lval v lv;
- Array.iter (fun (_, a) -> walk_atom v a) atab;
+ Array.iter (fun (_, _, a) -> walk_atom v a) atab;
walk_option (walk_lval v) base;
- | Ast.STMT_init_vec (lv, atoms) ->
+ | Ast.STMT_init_vec (lv, _, atoms) ->
walk_lval v lv;
Array.iter (walk_atom v) atoms
| Ast.STMT_init_tup (lv, mut_atoms) ->
walk_lval v lv;
- Array.iter (walk_atom v) mut_atoms
+ Array.iter (fun (_, atom) -> walk_atom v atom) mut_atoms
| Ast.STMT_init_str (lv, _) ->
walk_lval v lv
@@ -471,7 +407,7 @@ and walk_stmt
walk_option (walk_lval v) port;
walk_lval v chan;
- | Ast.STMT_init_box (dst, src) ->
+ | Ast.STMT_init_box (dst, _, src) ->
walk_lval v dst;
walk_atom v src
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-26 19:31:48 +0000