aboutsummaryrefslogtreecommitdiff
path: root/src/boot/me
diff options
context:
space:
mode:
authorGraydon Hoare <[email protected]>2010-06-23 21:03:09 -0700
committerGraydon Hoare <[email protected]>2010-06-23 21:03:09 -0700
commitd6b7c96c3eb29b9244ece0c046d3f372ff432d04 (patch)
treeb425187e232966063ffc2f0d14c04a55d8f004ef /src/boot/me
parentInitial git commit. (diff)
downloadrust-d6b7c96c3eb29b9244ece0c046d3f372ff432d04.tar.xz
rust-d6b7c96c3eb29b9244ece0c046d3f372ff432d04.zip
Populate tree.
Diffstat (limited to 'src/boot/me')
-rw-r--r--src/boot/me/alias.ml134
-rw-r--r--src/boot/me/dead.ml121
-rw-r--r--src/boot/me/dwarf.ml3019
-rw-r--r--src/boot/me/effect.ml313
-rw-r--r--src/boot/me/layout.ml470
-rw-r--r--src/boot/me/loop.ml163
-rw-r--r--src/boot/me/resolve.ml959
-rw-r--r--src/boot/me/semant.ml1969
-rw-r--r--src/boot/me/trans.ml5031
-rw-r--r--src/boot/me/transutil.ml238
-rw-r--r--src/boot/me/type.ml1294
-rw-r--r--src/boot/me/typestate.ml1089
-rw-r--r--src/boot/me/walk.ml687
13 files changed, 15487 insertions, 0 deletions
diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml
new file mode 100644
index 00000000..7009fe10
--- /dev/null
+++ b/src/boot/me/alias.ml
@@ -0,0 +1,134 @@
+open Semant;;
+open Common;;
+
+let log cx = Session.log "alias"
+ cx.ctxt_sess.Session.sess_log_alias
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let alias_analysis_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let curr_stmt = Stack.create () in
+
+ let alias_slot (slot_id:node_id) : unit =
+ begin
+ log cx "noting slot #%d as aliased" (int_of_node slot_id);
+ Hashtbl.replace cx.ctxt_slot_aliased slot_id ()
+ end
+ in
+
+ let alias lval =
+ match lval with
+ Ast.LVAL_base nb ->
+ let referent = Hashtbl.find cx.ctxt_lval_to_referent nb.id in
+ if (referent_is_slot cx referent)
+ then alias_slot referent
+ | _ -> err None "unhandled form of lval %a in alias analysis"
+ Ast.sprintf_lval lval
+ in
+
+ let alias_atom at =
+ match at with
+ Ast.ATOM_lval lv -> alias lv
+ | _ -> err None "aliasing literal"
+ in
+
+ let alias_call_args dst callee args =
+ alias dst;
+ let callee_ty = lval_ty cx callee in
+ match callee_ty with
+ Ast.TY_fn (tsig,_) ->
+ Array.iteri
+ begin
+ fun i slot ->
+ match slot.Ast.slot_mode with
+ Ast.MODE_alias _ ->
+ alias_atom args.(i)
+ | _ -> ()
+ end
+ tsig.Ast.sig_input_slots
+ | _ -> ()
+ in
+
+ let visit_stmt_pre s =
+ Stack.push s.id curr_stmt;
+ begin
+ try
+ match s.node with
+ (* FIXME (issue #26): actually all these *existing* cases
+ * can probably go now that we're using Trans.aliasing to
+ * form short-term spill-based aliases. Only aliases that
+ * survive 'into' a sub-block (those formed during iteration)
+ * need to be handled in this module. *)
+ Ast.STMT_call (dst, callee, args)
+ | Ast.STMT_spawn (dst, _, callee, args)
+ -> alias_call_args dst callee args
+
+ | Ast.STMT_send (_, src) -> alias src
+ | 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_str (dst, _) -> alias dst
+ | Ast.STMT_for_each sfe ->
+ let (slot, _) = sfe.Ast.for_each_slot in
+ alias_slot slot.id
+ | _ -> () (* FIXME (issue #29): plenty more to handle here. *)
+ with
+ Semant_err (None, msg) ->
+ raise (Semant_err ((Some s.id), msg))
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+ let visit_stmt_post s =
+ inner.Walk.visit_stmt_post s;
+ ignore (Stack.pop curr_stmt);
+ in
+
+ let visit_lval_pre lv =
+ let slot_id = lval_to_referent cx (lval_base_id lv) in
+ if (not (Stack.is_empty curr_stmt)) && (referent_is_slot cx slot_id)
+ then
+ begin
+ let slot_depth = get_slot_depth cx slot_id in
+ let stmt_depth = get_stmt_depth cx (Stack.top curr_stmt) in
+ if slot_depth <> stmt_depth
+ then
+ begin
+ let _ = assert (slot_depth < stmt_depth) in
+ alias_slot slot_id
+ end
+ end
+ in
+
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_stmt_post = visit_stmt_post;
+ Walk.visit_lval_pre = visit_lval_pre
+ }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (alias_analysis_visitor cx
+ Walk.empty_visitor);
+ |]
+ in
+ run_passes cx "alias" path passes (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/dead.ml b/src/boot/me/dead.ml
new file mode 100644
index 00000000..47e56166
--- /dev/null
+++ b/src/boot/me/dead.ml
@@ -0,0 +1,121 @@
+(*
+ * A simple dead-code analysis that rejects code following unconditional
+ * 'ret' or 'be'.
+ *)
+
+open Semant;;
+open Common;;
+
+let log cx = Session.log "dead"
+ cx.ctxt_sess.Session.sess_log_dead
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let dead_code_visitor
+ ((*cx*)_:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ (* FIXME: create separate table for each fn body for less garbage *)
+ let must_exit = Hashtbl.create 100 in
+
+ let all_must_exit ids =
+ arr_for_all (fun _ id -> Hashtbl.mem must_exit id) ids
+ in
+
+ let visit_block_post block =
+ let stmts = block.node in
+ let len = Array.length stmts in
+ if len > 0 then
+ Array.iteri
+ begin
+ fun i s ->
+ if (i < (len - 1)) && (Hashtbl.mem must_exit s.id) then
+ err (Some stmts.(i + 1).id) "dead statement"
+ end
+ stmts;
+ inner.Walk.visit_block_post block
+ in
+
+ let visit_stmt_post s =
+ begin
+ match s.node with
+ | Ast.STMT_block block ->
+ if Hashtbl.mem must_exit block.id then
+ Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_while { Ast.while_body = body }
+ | Ast.STMT_do_while { Ast.while_body = body }
+ | Ast.STMT_for_each { Ast.for_each_body = body }
+ | Ast.STMT_for { Ast.for_body = body } ->
+ if (Hashtbl.mem must_exit body.id) then
+ Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_if { Ast.if_then = b1; Ast.if_else = Some b2 } ->
+ if (Hashtbl.mem must_exit b1.id) && (Hashtbl.mem must_exit b2.id)
+ then Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_if _ -> ()
+
+ | Ast.STMT_ret _
+ | Ast.STMT_be _ ->
+ Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms } ->
+ let arm_ids =
+ Array.map (fun { node = (_, block) } -> block.id) arms
+ in
+ if all_must_exit arm_ids
+ then Hashtbl.add must_exit s.id ()
+
+ | Ast.STMT_alt_type { Ast.alt_type_arms = arms;
+ Ast.alt_type_else = alt_type_else } ->
+ let arm_ids = Array.map (fun (_, _, block) -> block.id) arms in
+ let else_ids =
+ begin
+ match alt_type_else with
+ Some stmt -> [| stmt.id |]
+ | None -> [| |]
+ end
+ in
+ if all_must_exit (Array.append arm_ids else_ids) then
+ Hashtbl.add must_exit s.id ()
+
+ (* FIXME: figure this one out *)
+ | Ast.STMT_alt_port _ -> ()
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_post s
+
+ in
+ { inner with
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_stmt_post = visit_stmt_post }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (dead_code_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+
+ run_passes cx "dead" path passes (log cx "%s") crate;
+ ()
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
new file mode 100644
index 00000000..9423d4ee
--- /dev/null
+++ b/src/boot/me/dwarf.ml
@@ -0,0 +1,3019 @@
+(*
+ * Walk crate and generate DWARF-3 records. This file might also go in
+ * the be/ directory; it's half-middle-end, half-back-end. Debug info is
+ * like that.
+ *
+ * Some notes about DWARF:
+ *
+ * - Records form an ownership tree. The tree is serialized in
+ * depth-first pre-order with child lists ending with null
+ * records. When a node type is defined to have no children, no null
+ * child record is provided; it's implied.
+ *
+ * [parent]
+ * / \
+ * [child1] [child2]
+ * |
+ * [grandchild1]
+ *
+ * serializes as:
+ *
+ * [parent][child1][grandchild1][null][child2][null][null]
+ *
+ * - Sometimes you want to make it possible to scan through a sibling
+ * list quickly while skipping the sub-children of each (such as
+ * skipping the 'grandchild' above); this can be done with a
+ * DW_AT_sibling attribute that points forward to the next same-level
+ * sibling.
+ *
+ * - A DWARF consumer contains a little stack-machine interpreter for
+ * a micro-language that you can embed in DWARF records to compute
+ * values algorithmically.
+ *
+ * - DWARF is not "officially" supported by any Microsoft tools in
+ * PE files, but the Microsoft debugging information formats are
+ * proprietary and ever-shifting, and not clearly sufficient for
+ * our needs; by comparison DWARF is widely supported, stable,
+ * flexible, and required everywhere *else*. We are using DWARF to
+ * support major components of the rust runtime (reflection,
+ * unwinding, profiling) so it's helpful to not have to span
+ * technologies, just focus on DWARF. Luckily the MINGW/Cygwin
+ * communities have worked out a convention for PE, and taught BFD
+ * (thus most tools) how to digest DWARF sections trailing after
+ * the .idata section of a normal PE file. Seems to work fine.
+ *
+ * - DWARF supports variable-length coding using LEB128, and in the
+ * cases where these are symbolic or self-contained numbers, we
+ * support them in the assembler. Inter-DWARF-record references
+ * can be done via fixed-size DW_FORM_ref{1,2,4,8} or
+ * DW_FORM_ref_addr; or else via variable-size (LEB128)
+ * DW_FORM_ref_udata. It is hazardous to use the LEB128 form in
+ * our implementation of references, since we use a generic 2-pass
+ * (+ relaxation) fixup mechanism in our assembler which in
+ * general may present an information-dependency cycle for LEB128
+ * coding of offsets: you need to know the offset before you can
+ * work out the LEB128 size, and you may need to know several
+ * LEB128-sizes before you can work out the offsets of other
+ * LEB128s (possibly even the one you're currently coding). In
+ * general the assembler makes no attempt to resolve such
+ * cycles. It'll just throw if it can't handle what you ask
+ * for. So it's best to pay a little extra space and use
+ * DW_FORM_ref_addr or DW_FORM_ref{1,2,4,8} values, in all cases.
+ *)
+
+open Semant;;
+open Common;;
+open Asm;;
+
+let log cx = Session.log "dwarf"
+ cx.ctxt_sess.Session.sess_log_dwarf
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+type dw_tag =
+ DW_TAG_array_type
+ | DW_TAG_class_type
+ | DW_TAG_entry_point
+ | DW_TAG_enumeration_type
+ | DW_TAG_formal_parameter
+ | DW_TAG_imported_declaration
+ | DW_TAG_label
+ | DW_TAG_lexical_block
+ | DW_TAG_member
+ | DW_TAG_pointer_type
+ | DW_TAG_reference_type
+ | DW_TAG_compile_unit
+ | DW_TAG_string_type
+ | DW_TAG_structure_type
+ | DW_TAG_subroutine_type
+ | DW_TAG_typedef
+ | DW_TAG_union_type
+ | DW_TAG_unspecified_parameters
+ | DW_TAG_variant
+ | DW_TAG_common_block
+ | DW_TAG_common_inclusion
+ | DW_TAG_inheritance
+ | DW_TAG_inlined_subroutine
+ | DW_TAG_module
+ | DW_TAG_ptr_to_member_type
+ | DW_TAG_set_type
+ | DW_TAG_subrange_type
+ | DW_TAG_with_stmt
+ | DW_TAG_access_declaration
+ | DW_TAG_base_type
+ | DW_TAG_catch_block
+ | DW_TAG_const_type
+ | DW_TAG_constant
+ | DW_TAG_enumerator
+ | DW_TAG_file_type
+ | DW_TAG_friend
+ | DW_TAG_namelist
+ | DW_TAG_namelist_item
+ | DW_TAG_packed_type
+ | DW_TAG_subprogram
+ | DW_TAG_template_type_parameter
+ | DW_TAG_template_value_parameter
+ | DW_TAG_thrown_type
+ | DW_TAG_try_block
+ | DW_TAG_variant_part
+ | DW_TAG_variable
+ | DW_TAG_volatile_type
+ | DW_TAG_dwarf_procedure
+ | DW_TAG_restrict_type
+ | DW_TAG_interface_type
+ | DW_TAG_namespace
+ | DW_TAG_imported_module
+ | DW_TAG_unspecified_type
+ | DW_TAG_partial_unit
+ | DW_TAG_imported_unit
+ | DW_TAG_condition
+ | DW_TAG_shared_type
+ | DW_TAG_lo_user
+ | DW_TAG_rust_meta
+ | DW_TAG_hi_user
+;;
+
+
+let dw_tag_to_int (tag:dw_tag) : int =
+ match tag with
+ DW_TAG_array_type -> 0x01
+ | DW_TAG_class_type -> 0x02
+ | DW_TAG_entry_point -> 0x03
+ | DW_TAG_enumeration_type -> 0x04
+ | DW_TAG_formal_parameter -> 0x05
+ | DW_TAG_imported_declaration -> 0x08
+ | DW_TAG_label -> 0x0a
+ | DW_TAG_lexical_block -> 0x0b
+ | DW_TAG_member -> 0x0d
+ | DW_TAG_pointer_type -> 0x0f
+ | DW_TAG_reference_type -> 0x10
+ | DW_TAG_compile_unit -> 0x11
+ | DW_TAG_string_type -> 0x12
+ | DW_TAG_structure_type -> 0x13
+ | DW_TAG_subroutine_type -> 0x15
+ | DW_TAG_typedef -> 0x16
+ | DW_TAG_union_type -> 0x17
+ | DW_TAG_unspecified_parameters -> 0x18
+ | DW_TAG_variant -> 0x19
+ | DW_TAG_common_block -> 0x1a
+ | DW_TAG_common_inclusion -> 0x1b
+ | DW_TAG_inheritance -> 0x1c
+ | DW_TAG_inlined_subroutine -> 0x1d
+ | DW_TAG_module -> 0x1e
+ | DW_TAG_ptr_to_member_type -> 0x1f
+ | DW_TAG_set_type -> 0x20
+ | DW_TAG_subrange_type -> 0x21
+ | DW_TAG_with_stmt -> 0x22
+ | DW_TAG_access_declaration -> 0x23
+ | DW_TAG_base_type -> 0x24
+ | DW_TAG_catch_block -> 0x25
+ | DW_TAG_const_type -> 0x26
+ | DW_TAG_constant -> 0x27
+ | DW_TAG_enumerator -> 0x28
+ | DW_TAG_file_type -> 0x29
+ | DW_TAG_friend -> 0x2a
+ | DW_TAG_namelist -> 0x2b
+ | DW_TAG_namelist_item -> 0x2c
+ | DW_TAG_packed_type -> 0x2d
+ | DW_TAG_subprogram -> 0x2e
+ | DW_TAG_template_type_parameter -> 0x2f
+ | DW_TAG_template_value_parameter -> 0x30
+ | DW_TAG_thrown_type -> 0x31
+ | DW_TAG_try_block -> 0x32
+ | DW_TAG_variant_part -> 0x33
+ | DW_TAG_variable -> 0x34
+ | DW_TAG_volatile_type -> 0x35
+ | DW_TAG_dwarf_procedure -> 0x36
+ | DW_TAG_restrict_type -> 0x37
+ | DW_TAG_interface_type -> 0x38
+ | DW_TAG_namespace -> 0x39
+ | DW_TAG_imported_module -> 0x3a
+ | DW_TAG_unspecified_type -> 0x3b
+ | DW_TAG_partial_unit -> 0x3c
+ | DW_TAG_imported_unit -> 0x3d
+ | DW_TAG_condition -> 0x3f
+ | DW_TAG_shared_type -> 0x40
+ | DW_TAG_lo_user -> 0x4080
+ | DW_TAG_rust_meta -> 0x4300
+ | DW_TAG_hi_user -> 0xffff
+;;
+
+let dw_tag_of_int (i:int) : dw_tag =
+ match i with
+ 0x01 -> DW_TAG_array_type
+ | 0x02 -> DW_TAG_class_type
+ | 0x03 -> DW_TAG_entry_point
+ | 0x04 -> DW_TAG_enumeration_type
+ | 0x05 -> DW_TAG_formal_parameter
+ | 0x08 -> DW_TAG_imported_declaration
+ | 0x0a -> DW_TAG_label
+ | 0x0b -> DW_TAG_lexical_block
+ | 0x0d -> DW_TAG_member
+ | 0x0f -> DW_TAG_pointer_type
+ | 0x10 -> DW_TAG_reference_type
+ | 0x11 -> DW_TAG_compile_unit
+ | 0x12 -> DW_TAG_string_type
+ | 0x13 -> DW_TAG_structure_type
+ | 0x15 -> DW_TAG_subroutine_type
+ | 0x16 -> DW_TAG_typedef
+ | 0x17 -> DW_TAG_union_type
+ | 0x18 -> DW_TAG_unspecified_parameters
+ | 0x19 -> DW_TAG_variant
+ | 0x1a -> DW_TAG_common_block
+ | 0x1b -> DW_TAG_common_inclusion
+ | 0x1c -> DW_TAG_inheritance
+ | 0x1d -> DW_TAG_inlined_subroutine
+ | 0x1e -> DW_TAG_module
+ | 0x1f -> DW_TAG_ptr_to_member_type
+ | 0x20 -> DW_TAG_set_type
+ | 0x21 -> DW_TAG_subrange_type
+ | 0x22 -> DW_TAG_with_stmt
+ | 0x23 -> DW_TAG_access_declaration
+ | 0x24 -> DW_TAG_base_type
+ | 0x25 -> DW_TAG_catch_block
+ | 0x26 -> DW_TAG_const_type
+ | 0x27 -> DW_TAG_constant
+ | 0x28 -> DW_TAG_enumerator
+ | 0x29 -> DW_TAG_file_type
+ | 0x2a -> DW_TAG_friend
+ | 0x2b -> DW_TAG_namelist
+ | 0x2c -> DW_TAG_namelist_item
+ | 0x2d -> DW_TAG_packed_type
+ | 0x2e -> DW_TAG_subprogram
+ | 0x2f -> DW_TAG_template_type_parameter
+ | 0x30 -> DW_TAG_template_value_parameter
+ | 0x31 -> DW_TAG_thrown_type
+ | 0x32 -> DW_TAG_try_block
+ | 0x33 -> DW_TAG_variant_part
+ | 0x34 -> DW_TAG_variable
+ | 0x35 -> DW_TAG_volatile_type
+ | 0x36 -> DW_TAG_dwarf_procedure
+ | 0x37 -> DW_TAG_restrict_type
+ | 0x38 -> DW_TAG_interface_type
+ | 0x39 -> DW_TAG_namespace
+ | 0x3a -> DW_TAG_imported_module
+ | 0x3b -> DW_TAG_unspecified_type
+ | 0x3c -> DW_TAG_partial_unit
+ | 0x3d -> DW_TAG_imported_unit
+ | 0x3f -> DW_TAG_condition
+ | 0x40 -> DW_TAG_shared_type
+ | 0x4080 -> DW_TAG_lo_user
+ | 0x4300 -> DW_TAG_rust_meta
+ | 0xffff -> DW_TAG_hi_user
+ | _ -> bug () "bad DWARF tag code: %d" i
+;;
+
+
+let dw_tag_to_string (tag:dw_tag) : string =
+ match tag with
+ DW_TAG_array_type -> "DW_TAG_array_type"
+ | DW_TAG_class_type -> "DW_TAG_class_type"
+ | DW_TAG_entry_point -> "DW_TAG_entry_point"
+ | DW_TAG_enumeration_type -> "DW_TAG_enumeration_type"
+ | DW_TAG_formal_parameter -> "DW_TAG_formal_parameter"
+ | DW_TAG_imported_declaration -> "DW_TAG_imported_declaration"
+ | DW_TAG_label -> "DW_TAG_label"
+ | DW_TAG_lexical_block -> "DW_TAG_lexical_block"
+ | DW_TAG_member -> "DW_TAG_member"
+ | DW_TAG_pointer_type -> "DW_TAG_pointer_type"
+ | DW_TAG_reference_type -> "DW_TAG_reference_type"
+ | DW_TAG_compile_unit -> "DW_TAG_compile_unit"
+ | DW_TAG_string_type -> "DW_TAG_string_type"
+ | DW_TAG_structure_type -> "DW_TAG_structure_type"
+ | DW_TAG_subroutine_type -> "DW_TAG_subroutine_type"
+ | DW_TAG_typedef -> "DW_TAG_typedef"
+ | DW_TAG_union_type -> "DW_TAG_union_type"
+ | DW_TAG_unspecified_parameters -> "DW_TAG_unspecified_parameters"
+ | DW_TAG_variant -> "DW_TAG_variant"
+ | DW_TAG_common_block -> "DW_TAG_common_block"
+ | DW_TAG_common_inclusion -> "DW_TAG_common_inclusion"
+ | DW_TAG_inheritance -> "DW_TAG_inheritance"
+ | DW_TAG_inlined_subroutine -> "DW_TAG_inlined_subroutine"
+ | DW_TAG_module -> "DW_TAG_module"
+ | DW_TAG_ptr_to_member_type -> "DW_TAG_ptr_to_member_type"
+ | DW_TAG_set_type -> "DW_TAG_set_type"
+ | DW_TAG_subrange_type -> "DW_TAG_subrange_type"
+ | DW_TAG_with_stmt -> "DW_TAG_with_stmt"
+ | DW_TAG_access_declaration -> "DW_TAG_access_declaration"
+ | DW_TAG_base_type -> "DW_TAG_base_type"
+ | DW_TAG_catch_block -> "DW_TAG_catch_block"
+ | DW_TAG_const_type -> "DW_TAG_const_type"
+ | DW_TAG_constant -> "DW_TAG_constant"
+ | DW_TAG_enumerator -> "DW_TAG_enumerator"
+ | DW_TAG_file_type -> "DW_TAG_file_type"
+ | DW_TAG_friend -> "DW_TAG_friend"
+ | DW_TAG_namelist -> "DW_TAG_namelist"
+ | DW_TAG_namelist_item -> "DW_TAG_namelist_item"
+ | DW_TAG_packed_type -> "DW_TAG_packed_type"
+ | DW_TAG_subprogram -> "DW_TAG_subprogram"
+ | DW_TAG_template_type_parameter -> "DW_TAG_template_type_parameter"
+ | DW_TAG_template_value_parameter -> "DW_TAG_template_value_parameter"
+ | DW_TAG_thrown_type -> "DW_TAG_thrown_type"
+ | DW_TAG_try_block -> "DW_TAG_try_block"
+ | DW_TAG_variant_part -> "DW_TAG_variant_part"
+ | DW_TAG_variable -> "DW_TAG_variable"
+ | DW_TAG_volatile_type -> "DW_TAG_volatile_type"
+ | DW_TAG_dwarf_procedure -> "DW_TAG_dwarf_procedure"
+ | DW_TAG_restrict_type -> "DW_TAG_restrict_type"
+ | DW_TAG_interface_type -> "DW_TAG_interface_type"
+ | DW_TAG_namespace -> "DW_TAG_namespace"
+ | DW_TAG_imported_module -> "DW_TAG_imported_module"
+ | DW_TAG_unspecified_type -> "DW_TAG_unspecified_type"
+ | DW_TAG_partial_unit -> "DW_TAG_partial_unit"
+ | DW_TAG_imported_unit -> "DW_TAG_imported_unit"
+ | DW_TAG_condition -> "DW_TAG_condition"
+ | DW_TAG_shared_type -> "DW_TAG_shared_type"
+ | DW_TAG_lo_user -> "DW_TAG_lo_user"
+ | DW_TAG_rust_meta -> "DW_TAG_rust_meta"
+ | DW_TAG_hi_user -> "DW_TAG_hi_user"
+;;
+
+
+type dw_children =
+ DW_CHILDREN_no
+ | DW_CHILDREN_yes
+;;
+
+
+let dw_children_to_int (ch:dw_children) : int =
+ match ch with
+ DW_CHILDREN_no -> 0x00
+ | DW_CHILDREN_yes -> 0x01
+;;
+
+let dw_children_of_int (i:int) : dw_children =
+ match i with
+ 0 -> DW_CHILDREN_no
+ | 1 -> DW_CHILDREN_yes
+ | _ -> bug () "bad DWARF children code: %d" i
+;;
+
+type dw_at =
+ DW_AT_sibling
+ | DW_AT_location
+ | DW_AT_name
+ | DW_AT_ordering
+ | DW_AT_byte_size
+ | DW_AT_bit_offset
+ | DW_AT_bit_size
+ | DW_AT_stmt_list
+ | DW_AT_low_pc
+ | DW_AT_high_pc
+ | DW_AT_language
+ | DW_AT_discr
+ | DW_AT_discr_value
+ | DW_AT_visibility
+ | DW_AT_import
+ | DW_AT_string_length
+ | DW_AT_common_reference
+ | DW_AT_comp_dir
+ | DW_AT_const_value
+ | DW_AT_containing_type
+ | DW_AT_default_value
+ | DW_AT_inline
+ | DW_AT_is_optional
+ | DW_AT_lower_bound
+ | DW_AT_producer
+ | DW_AT_prototyped
+ | DW_AT_return_addr
+ | DW_AT_start_scope
+ | DW_AT_bit_stride
+ | DW_AT_upper_bound
+ | DW_AT_abstract_origin
+ | DW_AT_accessibility
+ | DW_AT_address_class
+ | DW_AT_artificial
+ | DW_AT_base_types
+ | DW_AT_calling_convention
+ | DW_AT_count
+ | DW_AT_data_member_location
+ | DW_AT_decl_column
+ | DW_AT_decl_file
+ | DW_AT_decl_line
+ | DW_AT_declaration
+ | DW_AT_discr_list
+ | DW_AT_encoding
+ | DW_AT_external
+ | DW_AT_frame_base
+ | DW_AT_friend
+ | DW_AT_identifier_case
+ | DW_AT_macro_info
+ | DW_AT_namelist_item
+ | DW_AT_priority
+ | DW_AT_segment
+ | DW_AT_specification
+ | DW_AT_static_link
+ | DW_AT_type
+ | DW_AT_use_location
+ | DW_AT_variable_parameter
+ | DW_AT_virtuality
+ | DW_AT_vtable_elem_location
+ | DW_AT_allocated
+ | DW_AT_associated
+ | DW_AT_data_location
+ | DW_AT_byte_stride
+ | DW_AT_entry_pc
+ | DW_AT_use_UTF8
+ | DW_AT_extension
+ | DW_AT_ranges
+ | DW_AT_trampoline
+ | DW_AT_call_column
+ | DW_AT_call_file
+ | DW_AT_call_line
+ | DW_AT_description
+ | DW_AT_binary_scale
+ | DW_AT_decimal_scale
+ | DW_AT_small
+ | DW_AT_decimal_sign
+ | DW_AT_digit_count
+ | DW_AT_picture_string
+ | DW_AT_mutable
+ | DW_AT_threads_scaled
+ | DW_AT_explicit
+ | DW_AT_object_pointer
+ | DW_AT_endianity
+ | DW_AT_elemental
+ | DW_AT_pure
+ | DW_AT_recursive
+ | DW_AT_lo_user
+ | DW_AT_rust_type_code
+ | DW_AT_rust_type_param_index
+ | DW_AT_rust_iterator
+ | DW_AT_rust_native_type_id
+ | DW_AT_hi_user
+;;
+
+
+let dw_at_to_int (a:dw_at) : int =
+ match a with
+ DW_AT_sibling -> 0x01
+ | DW_AT_location -> 0x02
+ | DW_AT_name -> 0x03
+ | DW_AT_ordering -> 0x09
+ | DW_AT_byte_size -> 0x0b
+ | DW_AT_bit_offset -> 0x0c
+ | DW_AT_bit_size -> 0x0d
+ | DW_AT_stmt_list -> 0x10
+ | DW_AT_low_pc -> 0x11
+ | DW_AT_high_pc -> 0x12
+ | DW_AT_language -> 0x13
+ | DW_AT_discr -> 0x15
+ | DW_AT_discr_value -> 0x16
+ | DW_AT_visibility -> 0x17
+ | DW_AT_import -> 0x18
+ | DW_AT_string_length -> 0x19
+ | DW_AT_common_reference -> 0x1a
+ | DW_AT_comp_dir -> 0x1b
+ | DW_AT_const_value -> 0x1c
+ | DW_AT_containing_type -> 0x1d
+ | DW_AT_default_value -> 0x1e
+ | DW_AT_inline -> 0x20
+ | DW_AT_is_optional -> 0x21
+ | DW_AT_lower_bound -> 0x22
+ | DW_AT_producer -> 0x25
+ | DW_AT_prototyped -> 0x27
+ | DW_AT_return_addr -> 0x2a
+ | DW_AT_start_scope -> 0x2c
+ | DW_AT_bit_stride -> 0x2e
+ | DW_AT_upper_bound -> 0x2f
+ | DW_AT_abstract_origin -> 0x31
+ | DW_AT_accessibility -> 0x32
+ | DW_AT_address_class -> 0x33
+ | DW_AT_artificial -> 0x34
+ | DW_AT_base_types -> 0x35
+ | DW_AT_calling_convention -> 0x36
+ | DW_AT_count -> 0x37
+ | DW_AT_data_member_location -> 0x38
+ | DW_AT_decl_column -> 0x39
+ | DW_AT_decl_file -> 0x3a
+ | DW_AT_decl_line -> 0x3b
+ | DW_AT_declaration -> 0x3c
+ | DW_AT_discr_list -> 0x3d
+ | DW_AT_encoding -> 0x3e
+ | DW_AT_external -> 0x3f
+ | DW_AT_frame_base -> 0x40
+ | DW_AT_friend -> 0x41
+ | DW_AT_identifier_case -> 0x42
+ | DW_AT_macro_info -> 0x43
+ | DW_AT_namelist_item -> 0x44
+ | DW_AT_priority -> 0x45
+ | DW_AT_segment -> 0x46
+ | DW_AT_specification -> 0x47
+ | DW_AT_static_link -> 0x48
+ | DW_AT_type -> 0x49
+ | DW_AT_use_location -> 0x4a
+ | DW_AT_variable_parameter -> 0x4b
+ | DW_AT_virtuality -> 0x4c
+ | DW_AT_vtable_elem_location -> 0x4d
+ | DW_AT_allocated -> 0x4e
+ | DW_AT_associated -> 0x4f
+ | DW_AT_data_location -> 0x50
+ | DW_AT_byte_stride -> 0x51
+ | DW_AT_entry_pc -> 0x52
+ | DW_AT_use_UTF8 -> 0x53
+ | DW_AT_extension -> 0x54
+ | DW_AT_ranges -> 0x55
+ | DW_AT_trampoline -> 0x56
+ | DW_AT_call_column -> 0x57
+ | DW_AT_call_file -> 0x58
+ | DW_AT_call_line -> 0x59
+ | DW_AT_description -> 0x5a
+ | DW_AT_binary_scale -> 0x5b
+ | DW_AT_decimal_scale -> 0x5c
+ | DW_AT_small -> 0x5d
+ | DW_AT_decimal_sign -> 0x5e
+ | DW_AT_digit_count -> 0x5f
+ | DW_AT_picture_string -> 0x60
+ | DW_AT_mutable -> 0x61
+ | DW_AT_threads_scaled -> 0x62
+ | DW_AT_explicit -> 0x63
+ | DW_AT_object_pointer -> 0x64
+ | DW_AT_endianity -> 0x65
+ | DW_AT_elemental -> 0x66
+ | DW_AT_pure -> 0x67
+ | DW_AT_recursive -> 0x68
+ | DW_AT_lo_user -> 0x2000
+ | DW_AT_rust_type_code -> 0x2300
+ | DW_AT_rust_type_param_index -> 0x2301
+ | DW_AT_rust_iterator -> 0x2302
+ | DW_AT_rust_native_type_id -> 0x2303
+ | DW_AT_hi_user -> 0x3fff
+;;
+
+let dw_at_of_int (i:int) : dw_at =
+ match i with
+ 0x01 -> DW_AT_sibling
+ | 0x02 -> DW_AT_location
+ | 0x03 -> DW_AT_name
+ | 0x09 -> DW_AT_ordering
+ | 0x0b -> DW_AT_byte_size
+ | 0x0c -> DW_AT_bit_offset
+ | 0x0d -> DW_AT_bit_size
+ | 0x10 -> DW_AT_stmt_list
+ | 0x11 -> DW_AT_low_pc
+ | 0x12 -> DW_AT_high_pc
+ | 0x13 -> DW_AT_language
+ | 0x15 -> DW_AT_discr
+ | 0x16 -> DW_AT_discr_value
+ | 0x17 -> DW_AT_visibility
+ | 0x18 -> DW_AT_import
+ | 0x19 -> DW_AT_string_length
+ | 0x1a -> DW_AT_common_reference
+ | 0x1b -> DW_AT_comp_dir
+ | 0x1c -> DW_AT_const_value
+ | 0x1d -> DW_AT_containing_type
+ | 0x1e -> DW_AT_default_value
+ | 0x20 -> DW_AT_inline
+ | 0x21 -> DW_AT_is_optional
+ | 0x22 -> DW_AT_lower_bound
+ | 0x25 -> DW_AT_producer
+ | 0x27 -> DW_AT_prototyped
+ | 0x2a -> DW_AT_return_addr
+ | 0x2c -> DW_AT_start_scope
+ | 0x2e -> DW_AT_bit_stride
+ | 0x2f -> DW_AT_upper_bound
+ | 0x31 -> DW_AT_abstract_origin
+ | 0x32 -> DW_AT_accessibility
+ | 0x33 -> DW_AT_address_class
+ | 0x34 -> DW_AT_artificial
+ | 0x35 -> DW_AT_base_types
+ | 0x36 -> DW_AT_calling_convention
+ | 0x37 -> DW_AT_count
+ | 0x38 -> DW_AT_data_member_location
+ | 0x39 -> DW_AT_decl_column
+ | 0x3a -> DW_AT_decl_file
+ | 0x3b -> DW_AT_decl_line
+ | 0x3c -> DW_AT_declaration
+ | 0x3d -> DW_AT_discr_list
+ | 0x3e -> DW_AT_encoding
+ | 0x3f -> DW_AT_external
+ | 0x40 -> DW_AT_frame_base
+ | 0x41 -> DW_AT_friend
+ | 0x42 -> DW_AT_identifier_case
+ | 0x43 -> DW_AT_macro_info
+ | 0x44 -> DW_AT_namelist_item
+ | 0x45 -> DW_AT_priority
+ | 0x46 -> DW_AT_segment
+ | 0x47 -> DW_AT_specification
+ | 0x48 -> DW_AT_static_link
+ | 0x49 -> DW_AT_type
+ | 0x4a -> DW_AT_use_location
+ | 0x4b -> DW_AT_variable_parameter
+ | 0x4c -> DW_AT_virtuality
+ | 0x4d -> DW_AT_vtable_elem_location
+ | 0x4e -> DW_AT_allocated
+ | 0x4f -> DW_AT_associated
+ | 0x50 -> DW_AT_data_location
+ | 0x51 -> DW_AT_byte_stride
+ | 0x52 -> DW_AT_entry_pc
+ | 0x53 -> DW_AT_use_UTF8
+ | 0x54 -> DW_AT_extension
+ | 0x55 -> DW_AT_ranges
+ | 0x56 -> DW_AT_trampoline
+ | 0x57 -> DW_AT_call_column
+ | 0x58 -> DW_AT_call_file
+ | 0x59 -> DW_AT_call_line
+ | 0x5a -> DW_AT_description
+ | 0x5b -> DW_AT_binary_scale
+ | 0x5c -> DW_AT_decimal_scale
+ | 0x5d -> DW_AT_small
+ | 0x5e -> DW_AT_decimal_sign
+ | 0x5f -> DW_AT_digit_count
+ | 0x60 -> DW_AT_picture_string
+ | 0x61 -> DW_AT_mutable
+ | 0x62 -> DW_AT_threads_scaled
+ | 0x63 -> DW_AT_explicit
+ | 0x64 -> DW_AT_object_pointer
+ | 0x65 -> DW_AT_endianity
+ | 0x66 -> DW_AT_elemental
+ | 0x67 -> DW_AT_pure
+ | 0x68 -> DW_AT_recursive
+ | 0x2000 -> DW_AT_lo_user
+ | 0x2300 -> DW_AT_rust_type_code
+ | 0x2301 -> DW_AT_rust_type_param_index
+ | 0x2302 -> DW_AT_rust_iterator
+ | 0x2303 -> DW_AT_rust_native_type_id
+ | 0x3fff -> DW_AT_hi_user
+ | _ -> bug () "bad DWARF attribute code: 0x%x" i
+;;
+
+let dw_at_to_string (a:dw_at) : string =
+ match a with
+ DW_AT_sibling -> "DW_AT_sibling"
+ | DW_AT_location -> "DW_AT_location"
+ | DW_AT_name -> "DW_AT_name"
+ | DW_AT_ordering -> "DW_AT_ordering"
+ | DW_AT_byte_size -> "DW_AT_byte_size"
+ | DW_AT_bit_offset -> "DW_AT_bit_offset"
+ | DW_AT_bit_size -> "DW_AT_bit_size"
+ | DW_AT_stmt_list -> "DW_AT_stmt_list"
+ | DW_AT_low_pc -> "DW_AT_low_pc"
+ | DW_AT_high_pc -> "DW_AT_high_pc"
+ | DW_AT_language -> "DW_AT_language"
+ | DW_AT_discr -> "DW_AT_discr"
+ | DW_AT_discr_value -> "DW_AT_discr_value"
+ | DW_AT_visibility -> "DW_AT_visibility"
+ | DW_AT_import -> "DW_AT_import"
+ | DW_AT_string_length -> "DW_AT_string_length"
+ | DW_AT_common_reference -> "DW_AT_common_reference"
+ | DW_AT_comp_dir -> "DW_AT_comp_dir"
+ | DW_AT_const_value -> "DW_AT_const_value"
+ | DW_AT_containing_type -> "DW_AT_containing_type"
+ | DW_AT_default_value -> "DW_AT_default_value"
+ | DW_AT_inline -> "DW_AT_inline"
+ | DW_AT_is_optional -> "DW_AT_is_optional"
+ | DW_AT_lower_bound -> "DW_AT_lower_bound"
+ | DW_AT_producer -> "DW_AT_producer"
+ | DW_AT_prototyped -> "DW_AT_prototyped"
+ | DW_AT_return_addr -> "DW_AT_return_addr"
+ | DW_AT_start_scope -> "DW_AT_start_scope"
+ | DW_AT_bit_stride -> "DW_AT_bit_stride"
+ | DW_AT_upper_bound -> "DW_AT_upper_bound"
+ | DW_AT_abstract_origin -> "DW_AT_abstract_origin"
+ | DW_AT_accessibility -> "DW_AT_accessibility"
+ | DW_AT_address_class -> "DW_AT_address_class"
+ | DW_AT_artificial -> "DW_AT_artificial"
+ | DW_AT_base_types -> "DW_AT_base_types"
+ | DW_AT_calling_convention -> "DW_AT_calling_convention"
+ | DW_AT_count -> "DW_AT_count"
+ | DW_AT_data_member_location -> "DW_AT_data_member_location"
+ | DW_AT_decl_column -> "DW_AT_decl_column"
+ | DW_AT_decl_file -> "DW_AT_decl_file"
+ | DW_AT_decl_line -> "DW_AT_decl_line"
+ | DW_AT_declaration -> "DW_AT_declaration"
+ | DW_AT_discr_list -> "DW_AT_discr_list"
+ | DW_AT_encoding -> "DW_AT_encoding"
+ | DW_AT_external -> "DW_AT_external"
+ | DW_AT_frame_base -> "DW_AT_frame_base"
+ | DW_AT_friend -> "DW_AT_friend"
+ | DW_AT_identifier_case -> "DW_AT_identifier_case"
+ | DW_AT_macro_info -> "DW_AT_macro_info"
+ | DW_AT_namelist_item -> "DW_AT_namelist_item"
+ | DW_AT_priority -> "DW_AT_priority"
+ | DW_AT_segment -> "DW_AT_segment"
+ | DW_AT_specification -> "DW_AT_specification"
+ | DW_AT_static_link -> "DW_AT_static_link"
+ | DW_AT_type -> "DW_AT_type"
+ | DW_AT_use_location -> "DW_AT_use_location"
+ | DW_AT_variable_parameter -> "DW_AT_variable_parameter"
+ | DW_AT_virtuality -> "DW_AT_virtuality"
+ | DW_AT_vtable_elem_location -> "DW_AT_vtable_elem_location"
+ | DW_AT_allocated -> "DW_AT_allocated"
+ | DW_AT_associated -> "DW_AT_associated"
+ | DW_AT_data_location -> "DW_AT_data_location"
+ | DW_AT_byte_stride -> "DW_AT_byte_stride"
+ | DW_AT_entry_pc -> "DW_AT_entry_pc"
+ | DW_AT_use_UTF8 -> "DW_AT_use_UTF8"
+ | DW_AT_extension -> "DW_AT_extension"
+ | DW_AT_ranges -> "DW_AT_ranges"
+ | DW_AT_trampoline -> "DW_AT_trampoline"
+ | DW_AT_call_column -> "DW_AT_call_column"
+ | DW_AT_call_file -> "DW_AT_call_file"
+ | DW_AT_call_line -> "DW_AT_call_line"
+ | DW_AT_description -> "DW_AT_description"
+ | DW_AT_binary_scale -> "DW_AT_binary_scale"
+ | DW_AT_decimal_scale -> "DW_AT_decimal_scale"
+ | DW_AT_small -> "DW_AT_small"
+ | DW_AT_decimal_sign -> "DW_AT_decimal_sign"
+ | DW_AT_digit_count -> "DW_AT_digit_count"
+ | DW_AT_picture_string -> "DW_AT_picture_string"
+ | DW_AT_mutable -> "DW_AT_mutable"
+ | DW_AT_threads_scaled -> "DW_AT_threads_scaled"
+ | DW_AT_explicit -> "DW_AT_explicit"
+ | DW_AT_object_pointer -> "DW_AT_object_pointer"
+ | DW_AT_endianity -> "DW_AT_endianity"
+ | DW_AT_elemental -> "DW_AT_elemental"
+ | DW_AT_pure -> "DW_AT_pure"
+ | DW_AT_recursive -> "DW_AT_recursive"
+ | DW_AT_lo_user -> "DW_AT_lo_user"
+ | DW_AT_rust_type_code -> "DW_AT_rust_type_code"
+ | DW_AT_rust_type_param_index -> "DW_AT_rust_type_param_index"
+ | DW_AT_rust_iterator -> "DW_AT_rust_iterator"
+ | DW_AT_rust_native_type_id -> "DW_AT_native_type_id"
+ | DW_AT_hi_user -> "DW_AT_hi_user"
+;;
+
+(*
+ * We encode our 'built-in types' using DW_TAG_pointer_type and various
+ * DW_AT_pointer_type_codes. This seems to be more gdb-compatible than
+ * the DWARF-recommended way of using DW_TAG_unspecified_type.
+ *)
+type dw_rust_type =
+ DW_RUST_type_param
+ | DW_RUST_nil
+ | DW_RUST_vec
+ | DW_RUST_chan
+ | DW_RUST_port
+ | DW_RUST_task
+ | DW_RUST_tag
+ | DW_RUST_iso
+ | DW_RUST_type
+ | DW_RUST_native
+;;
+
+let dw_rust_type_to_int (pt:dw_rust_type) : int =
+ match pt with
+ DW_RUST_type_param -> 0x1
+ | DW_RUST_nil -> 0x2
+ | DW_RUST_vec -> 0x3
+ | DW_RUST_chan -> 0x4
+ | DW_RUST_port -> 0x5
+ | DW_RUST_task -> 0x6
+ | DW_RUST_tag -> 0x7
+ | DW_RUST_iso -> 0x8
+ | DW_RUST_type -> 0x9
+ | DW_RUST_native -> 0xa
+;;
+
+let dw_rust_type_of_int (i:int) : dw_rust_type =
+ match i with
+ 0x1 -> DW_RUST_type_param
+ | 0x2 -> DW_RUST_nil
+ | 0x3 -> DW_RUST_vec
+ | 0x4 -> DW_RUST_chan
+ | 0x5 -> DW_RUST_port
+ | 0x6 -> DW_RUST_task
+ | 0x7 -> DW_RUST_tag
+ | 0x8 -> DW_RUST_iso
+ | 0x9 -> DW_RUST_type
+ | 0xa -> DW_RUST_native
+ | _ -> bug () "bad DWARF rust-pointer-type code: %d" i
+;;
+
+type dw_ate =
+ DW_ATE_address
+ | DW_ATE_boolean
+ | DW_ATE_complex_float
+ | DW_ATE_float
+ | DW_ATE_signed
+ | DW_ATE_signed_char
+ | DW_ATE_unsigned
+ | DW_ATE_unsigned_char
+ | DW_ATE_imaginary_float
+ | DW_ATE_packed_decimal
+ | DW_ATE_numeric_string
+ | DW_ATE_edited
+ | DW_ATE_signed_fixed
+ | DW_ATE_unsigned_fixed
+ | DW_ATE_decimal_float
+ | DW_ATE_lo_user
+ | DW_ATE_hi_user
+;;
+
+let dw_ate_to_int (ate:dw_ate) : int =
+ match ate with
+ DW_ATE_address -> 0x01
+ | DW_ATE_boolean -> 0x02
+ | DW_ATE_complex_float -> 0x03
+ | DW_ATE_float -> 0x04
+ | DW_ATE_signed -> 0x05
+ | DW_ATE_signed_char -> 0x06
+ | DW_ATE_unsigned -> 0x07
+ | DW_ATE_unsigned_char -> 0x08
+ | DW_ATE_imaginary_float -> 0x09
+ | DW_ATE_packed_decimal -> 0x0a
+ | DW_ATE_numeric_string -> 0x0b
+ | DW_ATE_edited -> 0x0c
+ | DW_ATE_signed_fixed -> 0x0d
+ | DW_ATE_unsigned_fixed -> 0x0e
+ | DW_ATE_decimal_float -> 0x0f
+ | DW_ATE_lo_user -> 0x80
+ | DW_ATE_hi_user -> 0xff
+;;
+
+let dw_ate_of_int (i:int) : dw_ate =
+ match i with
+ 0x01 -> DW_ATE_address
+ | 0x02 -> DW_ATE_boolean
+ | 0x03 -> DW_ATE_complex_float
+ | 0x04 -> DW_ATE_float
+ | 0x05 -> DW_ATE_signed
+ | 0x06 -> DW_ATE_signed_char
+ | 0x07 -> DW_ATE_unsigned
+ | 0x08 -> DW_ATE_unsigned_char
+ | 0x09 -> DW_ATE_imaginary_float
+ | 0x0a -> DW_ATE_packed_decimal
+ | 0x0b -> DW_ATE_numeric_string
+ | 0x0c -> DW_ATE_edited
+ | 0x0d -> DW_ATE_signed_fixed
+ | 0x0e -> DW_ATE_unsigned_fixed
+ | 0x0f -> DW_ATE_decimal_float
+ | 0x80 -> DW_ATE_lo_user
+ | 0xff -> DW_ATE_hi_user
+ | _ -> bug () "bad DWARF attribute-encoding code: %d" i
+;;
+
+type dw_form =
+ | DW_FORM_addr
+ | DW_FORM_block2
+ | DW_FORM_block4
+ | DW_FORM_data2
+ | DW_FORM_data4
+ | DW_FORM_data8
+ | DW_FORM_string
+ | DW_FORM_block
+ | DW_FORM_block1
+ | DW_FORM_data1
+ | DW_FORM_flag
+ | DW_FORM_sdata
+ | DW_FORM_strp
+ | DW_FORM_udata
+ | DW_FORM_ref_addr
+ | DW_FORM_ref1
+ | DW_FORM_ref2
+ | DW_FORM_ref4
+ | DW_FORM_ref8
+ | DW_FORM_ref_udata
+ | DW_FORM_indirect
+;;
+
+
+let dw_form_to_int (f:dw_form) : int =
+ match f with
+ | DW_FORM_addr -> 0x01
+ | DW_FORM_block2 -> 0x03
+ | DW_FORM_block4 -> 0x04
+ | DW_FORM_data2 -> 0x05
+ | DW_FORM_data4 -> 0x06
+ | DW_FORM_data8 -> 0x07
+ | DW_FORM_string -> 0x08
+ | DW_FORM_block -> 0x09
+ | DW_FORM_block1 -> 0x0a
+ | DW_FORM_data1 -> 0x0b
+ | DW_FORM_flag -> 0x0c
+ | DW_FORM_sdata -> 0x0d
+ | DW_FORM_strp -> 0x0e
+ | DW_FORM_udata -> 0x0f
+ | DW_FORM_ref_addr -> 0x10
+ | DW_FORM_ref1 -> 0x11
+ | DW_FORM_ref2 -> 0x12
+ | DW_FORM_ref4 -> 0x13
+ | DW_FORM_ref8 -> 0x14
+ | DW_FORM_ref_udata -> 0x15
+ | DW_FORM_indirect -> 0x16
+;;
+
+let dw_form_of_int (i:int) : dw_form =
+ match i with
+ | 0x01 -> DW_FORM_addr
+ | 0x03 -> DW_FORM_block2
+ | 0x04 -> DW_FORM_block4
+ | 0x05 -> DW_FORM_data2
+ | 0x06 -> DW_FORM_data4
+ | 0x07 -> DW_FORM_data8
+ | 0x08 -> DW_FORM_string
+ | 0x09 -> DW_FORM_block
+ | 0x0a -> DW_FORM_block1
+ | 0x0b -> DW_FORM_data1
+ | 0x0c -> DW_FORM_flag
+ | 0x0d -> DW_FORM_sdata
+ | 0x0e -> DW_FORM_strp
+ | 0x0f -> DW_FORM_udata
+ | 0x10 -> DW_FORM_ref_addr
+ | 0x11 -> DW_FORM_ref1
+ | 0x12 -> DW_FORM_ref2
+ | 0x13 -> DW_FORM_ref4
+ | 0x14 -> DW_FORM_ref8
+ | 0x15 -> DW_FORM_ref_udata
+ | 0x16 -> DW_FORM_indirect
+ | _ -> bug () "bad DWARF form code: 0x%x" i
+;;
+
+let dw_form_to_string (f:dw_form) : string =
+ match f with
+ | DW_FORM_addr -> "DW_FORM_addr"
+ | DW_FORM_block2 -> "DW_FORM_block2"
+ | DW_FORM_block4 -> "DW_FORM_block4"
+ | DW_FORM_data2 -> "DW_FORM_data2"
+ | DW_FORM_data4 -> "DW_FORM_data4"
+ | DW_FORM_data8 -> "DW_FORM_data8"
+ | DW_FORM_string -> "DW_FORM_string"
+ | DW_FORM_block -> "DW_FORM_block"
+ | DW_FORM_block1 -> "DW_FORM_block1"
+ | DW_FORM_data1 -> "DW_FORM_data1"
+ | DW_FORM_flag -> "DW_FORM_flag"
+ | DW_FORM_sdata -> "DW_FORM_sdata"
+ | DW_FORM_strp -> "DW_FORM_strp"
+ | DW_FORM_udata -> "DW_FORM_udata"
+ | DW_FORM_ref_addr -> "DW_FORM_ref_addr"
+ | DW_FORM_ref1 -> "DW_FORM_ref1"
+ | DW_FORM_ref2 -> "DW_FORM_ref2"
+ | DW_FORM_ref4 -> "DW_FORM_ref4"
+ | DW_FORM_ref8 -> "DW_FORM_ref8"
+ | DW_FORM_ref_udata -> "DW_FORM_ref_udata"
+ | DW_FORM_indirect -> "DW_FORM_indirect"
+;;
+
+type dw_op =
+ DW_OP_lit of int
+ | DW_OP_addr of Asm.expr64
+ | DW_OP_const1u of Asm.expr64
+ | DW_OP_const1s of Asm.expr64
+ | DW_OP_const2u of Asm.expr64
+ | DW_OP_const2s of Asm.expr64
+ | DW_OP_const4u of Asm.expr64
+ | DW_OP_const4s of Asm.expr64
+ | DW_OP_const8u of Asm.expr64
+ | DW_OP_const8s of Asm.expr64
+ | DW_OP_constu of Asm.expr64
+ | DW_OP_consts of Asm.expr64
+ | DW_OP_fbreg of Asm.expr64
+ | DW_OP_reg of int
+ | DW_OP_regx of Asm.expr64
+ | DW_OP_breg of (int * Asm.expr64)
+ | DW_OP_bregx of (Asm.expr64 * Asm.expr64)
+ | DW_OP_dup
+ | DW_OP_drop
+ | DW_OP_pick of Asm.expr64
+ | DW_OP_over
+ | DW_OP_swap
+ | DW_OP_rot
+ | DW_OP_piece of Asm.expr64
+ | DW_OP_bit_piece of (Asm.expr64 * Asm.expr64)
+ | DW_OP_deref
+ | DW_OP_deref_size of Asm.expr64
+ | DW_OP_xderef
+ | DW_OP_xderef_size of Asm.expr64
+ | DW_OP_push_object_address
+ | DW_OP_form_tls_address
+ | DW_OP_call_frame_cfa
+ | DW_OP_abs
+ | DW_OP_and
+ | DW_OP_div
+ | DW_OP_minus
+ | DW_OP_mod
+ | DW_OP_mul
+ | DW_OP_neg
+ | DW_OP_not
+ | DW_OP_or
+ | DW_OP_plus
+ | DW_OP_plus_uconst of Asm.expr64
+ | DW_OP_shl
+ | DW_OP_shr
+ | DW_OP_shra
+ | DW_OP_xor
+ | DW_OP_le
+ | DW_OP_ge
+ | DW_OP_eq
+ | DW_OP_lt
+ | DW_OP_gt
+ | DW_OP_ne
+ | DW_OP_skip of Asm.expr64
+ | DW_OP_bra of Asm.expr64
+ | DW_OP_call2 of Asm.expr64
+ | DW_OP_call4 of Asm.expr64
+ | DW_OP_call_ref of Asm.expr64
+ | DW_OP_nop
+;;
+
+let dw_op_to_frag (abi:Abi.abi) (op:dw_op) : Asm.frag =
+ match op with
+
+ DW_OP_addr e -> SEQ [| BYTE 0x03; WORD (abi.Abi.abi_word_ty, e) |]
+ | DW_OP_deref -> BYTE 0x06
+ | DW_OP_const1u e -> SEQ [| BYTE 0x08; WORD (TY_u8, e) |]
+ | DW_OP_const1s e -> SEQ [| BYTE 0x09; WORD (TY_i8, e) |]
+ | DW_OP_const2u e -> SEQ [| BYTE 0x0a; WORD (TY_u16, e) |]
+ | DW_OP_const2s e -> SEQ [| BYTE 0x0b; WORD (TY_i16, e) |]
+ | DW_OP_const4u e -> SEQ [| BYTE 0x0c; WORD (TY_u32, e) |]
+ | DW_OP_const4s e -> SEQ [| BYTE 0x0d; WORD (TY_i32, e) |]
+ | DW_OP_const8u e -> SEQ [| BYTE 0x0e; WORD (TY_u64, e) |]
+ | DW_OP_const8s e -> SEQ [| BYTE 0x0f; WORD (TY_i64, e) |]
+ | DW_OP_constu e -> SEQ [| BYTE 0x10; ULEB128 e |]
+ | DW_OP_consts e -> SEQ [| BYTE 0x11; SLEB128 e |]
+ | DW_OP_dup -> BYTE 0x12
+ | DW_OP_drop -> BYTE 0x13
+ | DW_OP_over -> BYTE 0x14
+ | DW_OP_pick e -> SEQ [| BYTE 0x15; WORD (TY_u8, e) |]
+ | DW_OP_swap -> BYTE 0x16
+ | DW_OP_rot -> BYTE 0x17
+ | DW_OP_xderef -> BYTE 0x18
+ | DW_OP_abs -> BYTE 0x19
+ | DW_OP_and -> BYTE 0x1a
+ | DW_OP_div -> BYTE 0x1b
+ | DW_OP_minus -> BYTE 0x1c
+ | DW_OP_mod -> BYTE 0x1d
+ | DW_OP_mul -> BYTE 0x1e
+ | DW_OP_neg -> BYTE 0x1f
+ | DW_OP_not -> BYTE 0x20
+ | DW_OP_or -> BYTE 0x21
+ | DW_OP_plus -> BYTE 0x22
+ | DW_OP_plus_uconst e -> SEQ [| BYTE 0x23; ULEB128 e |]
+ | DW_OP_shl -> BYTE 0x24
+ | DW_OP_shr -> BYTE 0x25
+ | DW_OP_shra -> BYTE 0x26
+ | DW_OP_xor -> BYTE 0x27
+ | DW_OP_skip e -> SEQ [| BYTE 0x2f; WORD (TY_i16, e) |]
+ | DW_OP_bra e -> SEQ [| BYTE 0x28; WORD (TY_i16, e) |]
+ | DW_OP_eq -> BYTE 0x29
+ | DW_OP_ge -> BYTE 0x2a
+ | DW_OP_gt -> BYTE 0x2b
+ | DW_OP_le -> BYTE 0x2c
+ | DW_OP_lt -> BYTE 0x2d
+ | DW_OP_ne -> BYTE 0x2e
+
+ | DW_OP_lit i ->
+ assert (0 <= i && i < 32);
+ BYTE (i + 0x30)
+
+ | DW_OP_reg i ->
+ assert (0 <= i && i < 32);
+ BYTE (i + 0x50)
+
+ | DW_OP_breg (i, e) ->
+ assert (0 <= i && i < 32);
+ SEQ [| BYTE (i + 0x70); SLEB128 e |]
+
+ | DW_OP_regx e -> SEQ [| BYTE 0x90; ULEB128 e|]
+ | DW_OP_fbreg e -> SEQ [| BYTE 0x91; SLEB128 e |]
+ | DW_OP_bregx (r, off) -> SEQ [| BYTE 0x92; ULEB128 r; SLEB128 off |]
+ | DW_OP_piece e -> SEQ [| BYTE 0x93; ULEB128 e |]
+ | DW_OP_deref_size e -> SEQ [| BYTE 0x94; WORD (TY_u8, e) |]
+ | DW_OP_xderef_size e -> SEQ [| BYTE 0x95; WORD (TY_u8, e) |]
+ | DW_OP_nop -> BYTE 0x96
+ | DW_OP_push_object_address -> BYTE 0x97
+ | DW_OP_call2 e -> SEQ [| BYTE 0x98; WORD (TY_u16, e) |]
+ | DW_OP_call4 e -> SEQ [| BYTE 0x99; WORD (TY_u32, e) |]
+ | DW_OP_call_ref e -> SEQ [| BYTE 0x9a; WORD (abi.Abi.abi_word_ty, e) |]
+ | DW_OP_form_tls_address -> BYTE 0x9b
+ | DW_OP_call_frame_cfa -> BYTE 0x9c
+ | DW_OP_bit_piece (sz, off) ->
+ SEQ [| BYTE 0x9d; ULEB128 sz; ULEB128 off |]
+;;
+
+type dw_lns =
+ DW_LNS_copy
+ | DW_LNS_advance_pc
+ | DW_LNS_advance_line
+ | DW_LNS_set_file
+ | DW_LNS_set_column
+ | DW_LNS_negage_stmt
+ | DW_LNS_set_basic_block
+ | DW_LNS_const_add_pc
+ | DW_LNS_fixed_advance_pc
+ | DW_LNS_set_prologue_end
+ | DW_LNS_set_epilogue_begin
+ | DW_LNS_set_isa
+;;
+
+let int_to_dw_lns i =
+ match i with
+ 1 -> DW_LNS_copy
+ | 2 -> DW_LNS_advance_pc
+ | 3 -> DW_LNS_advance_line
+ | 4 -> DW_LNS_set_file
+ | 5 -> DW_LNS_set_column
+ | 6 -> DW_LNS_negage_stmt
+ | 7 -> DW_LNS_set_basic_block
+ | 8 -> DW_LNS_const_add_pc
+ | 9 -> DW_LNS_fixed_advance_pc
+ | 10 -> DW_LNS_set_prologue_end
+ | 11 -> DW_LNS_set_epilogue_begin
+ | 12 -> DW_LNS_set_isa
+ | _ -> bug () "Internal logic error: (Dwarf.int_to_dw_lns %d)" i
+;;
+
+let dw_lns_to_int lns =
+ match lns with
+ DW_LNS_copy -> 1
+ | DW_LNS_advance_pc -> 2
+ | DW_LNS_advance_line -> 3
+ | DW_LNS_set_file -> 4
+ | DW_LNS_set_column -> 5
+ | DW_LNS_negage_stmt -> 6
+ | DW_LNS_set_basic_block -> 7
+ | DW_LNS_const_add_pc -> 8
+ | DW_LNS_fixed_advance_pc -> 9
+ | DW_LNS_set_prologue_end -> 10
+ | DW_LNS_set_epilogue_begin -> 11
+ | DW_LNS_set_isa -> 12
+;;
+
+let max_dw_lns = 12;;
+
+let dw_lns_arity lns =
+ match lns with
+ DW_LNS_copy -> 0
+ | DW_LNS_advance_pc -> 1
+ | DW_LNS_advance_line -> 1
+ | DW_LNS_set_file -> 1
+ | DW_LNS_set_column -> 1
+ | DW_LNS_negage_stmt -> 0
+ | DW_LNS_set_basic_block -> 0
+ | DW_LNS_const_add_pc -> 0
+ | DW_LNS_fixed_advance_pc -> 1
+ | DW_LNS_set_prologue_end -> 0
+ | DW_LNS_set_epilogue_begin -> 0
+ | DW_LNS_set_isa -> 1
+;;
+
+type debug_records =
+ {
+ debug_aranges: Asm.frag;
+ debug_pubnames: Asm.frag;
+ debug_info: Asm.frag;
+ debug_abbrev: Asm.frag;
+ debug_line: Asm.frag;
+ debug_frame: Asm.frag;
+ }
+
+type abbrev = (dw_tag * dw_children * ((dw_at * dw_form) array));;
+
+let (abbrev_crate_cu:abbrev) =
+ (DW_TAG_compile_unit, DW_CHILDREN_yes,
+ [|
+ (DW_AT_producer, DW_FORM_string);
+ (DW_AT_language, DW_FORM_data4);
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_comp_dir, DW_FORM_string);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ (DW_AT_use_UTF8, DW_FORM_flag)
+ |])
+ ;;
+
+let (abbrev_meta:abbrev) =
+ (DW_TAG_rust_meta, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_const_value, DW_FORM_string)
+ |])
+;;
+
+let (abbrev_srcfile_cu:abbrev) =
+ (DW_TAG_compile_unit, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_comp_dir, DW_FORM_string);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ |])
+;;
+
+
+let (abbrev_module:abbrev) =
+ (DW_TAG_module, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ |])
+;;
+
+let (abbrev_subprogram:abbrev) =
+ (DW_TAG_subprogram, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ (DW_AT_frame_base, DW_FORM_block1);
+ (DW_AT_return_addr, DW_FORM_block1);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_typedef:abbrev) =
+ (DW_TAG_typedef, DW_CHILDREN_yes,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_lexical_block:abbrev) =
+ (DW_TAG_lexical_block, DW_CHILDREN_yes,
+ [|
+ (DW_AT_low_pc, DW_FORM_addr);
+ (DW_AT_high_pc, DW_FORM_addr);
+ |])
+;;
+
+let (abbrev_variable:abbrev) =
+ (DW_TAG_variable, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_location, DW_FORM_block1);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+(* NB: must have same abbrev-body as abbrev_variable. *)
+let (abbrev_formal:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_location, DW_FORM_block1);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_unspecified_anon_structure_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_declaration, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_unspecified_structure_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_declaration, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_unspecified_pointer_type:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_declaration, DW_FORM_flag);
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+let (abbrev_native_pointer_type:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_rust_native_type_id, DW_FORM_data4)
+ |])
+;;
+
+let (abbrev_rust_type_param:abbrev) =
+ (DW_TAG_pointer_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_rust_type_param_index, DW_FORM_data4);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_rust_type_param_decl:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_rust_type_code, DW_FORM_data1);
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_rust_type_param_index, DW_FORM_data4);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_base_type:abbrev) =
+ (DW_TAG_base_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_encoding, DW_FORM_data1);
+ (DW_AT_byte_size, DW_FORM_data1)
+ |])
+;;
+
+let (abbrev_alias_slot:abbrev) =
+ (DW_TAG_reference_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_exterior_slot:abbrev) =
+ (DW_TAG_reference_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_data_location, DW_FORM_block1);
+ |])
+;;
+
+let (abbrev_struct_type:abbrev) =
+ (DW_TAG_structure_type, DW_CHILDREN_yes,
+ [|
+ (DW_AT_byte_size, DW_FORM_block4)
+ |])
+;;
+
+let (abbrev_struct_type_member:abbrev) =
+ (DW_TAG_member, DW_CHILDREN_no,
+ [|
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr);
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_data_member_location, DW_FORM_block4);
+ (DW_AT_byte_size, DW_FORM_block4)
+ |])
+;;
+
+let (abbrev_subroutine_type:abbrev) =
+ (DW_TAG_subroutine_type, DW_CHILDREN_yes,
+ [|
+ (* FIXME: model effects properly. *)
+ (DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ (DW_AT_rust_iterator, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_formal_type:abbrev) =
+ (DW_TAG_formal_parameter, DW_CHILDREN_no,
+ [|
+ (DW_AT_type, DW_FORM_ref_addr)
+ |])
+;;
+
+
+let (abbrev_obj_subroutine_type:abbrev) =
+ (DW_TAG_subroutine_type, DW_CHILDREN_yes,
+ [|
+ (* FIXME: model effects properly. *)
+ (DW_AT_name, DW_FORM_string);
+ (DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ (DW_AT_rust_iterator, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_obj_type:abbrev) =
+ (DW_TAG_interface_type, DW_CHILDREN_yes,
+ [|
+ (DW_AT_mutable, DW_FORM_flag);
+ (DW_AT_pure, DW_FORM_flag);
+ |])
+;;
+
+let (abbrev_string_type:abbrev) =
+ (DW_TAG_string_type, DW_CHILDREN_no,
+ [|
+ (DW_AT_string_length, DW_FORM_block1);
+ (DW_AT_data_location, DW_FORM_block1);
+ |])
+;;
+
+
+let prepend lref x = lref := x :: (!lref)
+;;
+
+
+let dwarf_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ (path:Ast.name_component Stack.t)
+ (cu_info_section_fixup:fixup)
+ (cu_aranges:(frag list) ref)
+ (cu_pubnames:(frag list) ref)
+ (cu_infos:(frag list) ref)
+ (cu_abbrevs:(frag list) ref)
+ (cu_lines:(frag list) ref)
+ (cu_frames:(frag list) ref)
+ : Walk.visitor =
+
+ let (abi:Abi.abi) = cx.ctxt_abi in
+ let (word_sz:int64) = abi.Abi.abi_word_sz in
+ let (word_sz_int:int) = Int64.to_int word_sz in
+ let (word_bits:Il.bits) = abi.Abi.abi_word_bits in
+ let (word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_u8
+ | Il.Bits16 -> TY_u16
+ | Il.Bits32 -> TY_u32
+ | Il.Bits64 -> TY_u64
+ in
+ let (signed_word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_i8
+ | Il.Bits16 -> TY_i16
+ | Il.Bits32 -> TY_i32
+ | Il.Bits64 -> TY_i64
+ in
+
+ let path_name _ = Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path) in
+
+ let (abbrev_table:(abbrev, int) Hashtbl.t) = Hashtbl.create 0 in
+
+ let uleb i = ULEB128 (IMM (Int64.of_int i)) in
+
+ let get_abbrev_code
+ (ab:abbrev)
+ : int =
+ if Hashtbl.mem abbrev_table ab
+ then Hashtbl.find abbrev_table ab
+ else
+ let n = (Hashtbl.length abbrev_table) + 1 in
+ let (tag, children, attrs) = ab in
+ let attr_ulebs = Array.create ((Array.length attrs) * 2) MARK in
+ for i = 0 to (Array.length attrs) - 1 do
+ let (attr, form) = attrs.(i) in
+ attr_ulebs.(2*i) <- uleb (dw_at_to_int attr);
+ attr_ulebs.((2*i)+1) <- uleb (dw_form_to_int form)
+ done;
+ let ab_frag =
+ (SEQ [|
+ uleb n;
+ uleb (dw_tag_to_int tag);
+ BYTE (dw_children_to_int children);
+ SEQ attr_ulebs;
+ uleb 0; uleb 0;
+ |])
+ in
+ prepend cu_abbrevs ab_frag;
+ htab_put abbrev_table ab n;
+ n
+ in
+
+ let (curr_cu_aranges:(frag list) ref) = ref [] in
+ let (curr_cu_pubnames:(frag list) ref) = ref [] in
+ let (curr_cu_infos:(frag list) ref) = ref [] in
+ let (curr_cu_line:(frag list) ref) = ref [] in
+ let (curr_cu_frame:(frag list) ref) = ref [] in
+
+ let emit_die die = prepend curr_cu_infos die in
+ let emit_null_die _ = emit_die (BYTE 0) in
+
+ let dw_form_block1 (ops:dw_op array) : Asm.frag =
+ let frag = SEQ (Array.map (dw_op_to_frag abi) ops) in
+ let block_fixup = new_fixup "DW_FORM_block1 fixup" in
+ SEQ [| WORD (TY_u8, F_SZ block_fixup);
+ DEF (block_fixup, frag) |]
+ in
+
+ let dw_form_ref_addr (fix:fixup) : Asm.frag =
+ WORD (signed_word_ty_mach,
+ SUB ((M_POS fix), M_POS cu_info_section_fixup))
+ in
+
+ let encode_effect eff =
+ (* Note: weird encoding: mutable+pure = unsafe. *)
+ let mut_byte, pure_byte =
+ match eff with
+ Ast.UNSAFE -> (1,1)
+ | Ast.STATE -> (1,0)
+ | Ast.IO -> (0,0)
+ | Ast.PURE -> (0,1)
+ in
+ SEQ [|
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE mut_byte;
+ (* DW_AT_pure: DW_FORM_flag *)
+ BYTE pure_byte;
+ |]
+ in
+
+ (* Type-param DIEs. *)
+
+ let type_param_die (p:(ty_param_idx * Ast.effect)) =
+ let (idx, eff) = p in
+ SEQ [|
+ uleb (get_abbrev_code abbrev_rust_type_param);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_type_param);
+ (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int idx));
+ encode_effect eff;
+ |]
+ in
+
+ (* Type DIEs. *)
+
+ let (emitted_types:(Ast.ty, Asm.frag) Hashtbl.t) = Hashtbl.create 0 in
+ let (emitted_slots:(Ast.slot, Asm.frag) Hashtbl.t) = Hashtbl.create 0 in
+
+ let rec ref_slot_die
+ (slot:Ast.slot)
+ : frag =
+ if Hashtbl.mem emitted_slots slot
+ then Hashtbl.find emitted_slots slot
+ else
+ let ref_addr_for_fix fix =
+ let res = dw_form_ref_addr fix in
+ Hashtbl.add emitted_slots slot res;
+ res
+ in
+
+ match slot.Ast.slot_mode with
+ Ast.MODE_exterior ->
+ let fix = new_fixup "exterior DIE" in
+ let body_off =
+ word_sz_int * Abi.exterior_rc_slot_field_body
+ in
+ emit_die (DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_exterior_slot);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die (slot_ty slot));
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable
+ then 1 else 0);
+ (* DW_AT_data_location: DW_FORM_block1 *)
+ (* This is a DWARF expression for moving
+ from the address of an exterior
+ allocation to the address of its
+ body. *)
+ dw_form_block1
+ [| DW_OP_push_object_address;
+ DW_OP_lit body_off;
+ DW_OP_plus;
+ DW_OP_deref |]
+ |]));
+ ref_addr_for_fix fix
+
+ (* FIXME: encode mutable-ness of interiors. *)
+ | Ast.MODE_interior -> ref_type_die (slot_ty slot)
+
+ | Ast.MODE_alias ->
+ let fix = new_fixup "alias DIE" in
+ emit_die (DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_alias_slot);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die (slot_ty slot));
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable then 1 else 0)
+ |]));
+ ref_addr_for_fix fix
+
+
+ and size_block4 (sz:size) (add_to_base:bool) : frag =
+ (* NB: typarams = "words following implicit args" by convention in
+ * ABI/x86.
+ *)
+ let abi = cx.ctxt_abi in
+ let typarams =
+ Int64.add abi.Abi.abi_frame_base_sz abi.Abi.abi_implicit_args_sz
+ in
+ let word_n n = Int64.mul abi.Abi.abi_word_sz (Int64.of_int n) in
+ let param_n n = Int64.add typarams (word_n n) in
+ let param_n_field_k n k =
+ [ DW_OP_fbreg (IMM (param_n n));
+ DW_OP_deref;
+ DW_OP_constu (IMM (word_n k));
+ DW_OP_plus;
+ DW_OP_deref ]
+ in
+ let rec sz_ops (sz:size) : dw_op list =
+ match sz with
+ SIZE_fixed i ->
+ [ DW_OP_constu (IMM i) ]
+
+ | SIZE_fixup_mem_sz fix ->
+ [ DW_OP_constu (M_SZ fix) ]
+
+ | SIZE_fixup_mem_pos fix ->
+ [ DW_OP_constu (M_POS fix) ]
+
+ | SIZE_param_size i ->
+ param_n_field_k i Abi.tydesc_field_size
+
+ | SIZE_param_align i ->
+ param_n_field_k i Abi.tydesc_field_align
+
+ | SIZE_rt_neg s ->
+ (sz_ops s) @ [ DW_OP_neg ]
+
+ | SIZE_rt_add (a, b) ->
+ (sz_ops a) @ (sz_ops b) @ [ DW_OP_plus ]
+
+ | SIZE_rt_mul (a, b) ->
+ (sz_ops a) @ (sz_ops b) @ [ DW_OP_mul ]
+
+ | SIZE_rt_max (a, b) ->
+ (sz_ops a) @ (sz_ops b) @
+ [ DW_OP_over; (* ... a b a *)
+ DW_OP_over; (* ... a b a b *)
+ DW_OP_ge; (* ... a b (a>=b?1:0) *)
+
+ (* jump +1 byte of dwarf ops if 1 *)
+ DW_OP_bra (IMM 1L);
+
+ (* do this if 0, when b is max. *)
+ DW_OP_swap; (* ... b a *)
+
+ (* jump to here when a is max. *)
+ DW_OP_drop; (* ... max *)
+ ]
+
+ | SIZE_rt_align (align, off) ->
+ (*
+ * calculate off + pad where:
+ *
+ * pad = (align - (off mod align)) mod align
+ *
+ * In our case it's always a power of two,
+ * so we can just do:
+ *
+ * mask = align-1
+ * off += mask
+ * off &= ~mask
+ *
+ *)
+ (sz_ops off) @ (sz_ops align) @
+ [
+ DW_OP_lit 1; (* ... off align 1 *)
+ DW_OP_minus; (* ... off mask *)
+ DW_OP_dup; (* ... off mask mask *)
+ DW_OP_not; (* ... off mask ~mask *)
+ DW_OP_rot; (* ... ~mask off mask *)
+ DW_OP_plus; (* ... ~mask (off+mask) *)
+ DW_OP_and; (* ... aligned *)
+ ]
+ in
+ let ops = sz_ops sz in
+ let ops =
+ if add_to_base
+ then ops @ [ DW_OP_plus ]
+ else ops
+ in
+ let frag = SEQ (Array.map (dw_op_to_frag abi) (Array.of_list ops)) in
+ let block_fixup = new_fixup "DW_FORM_block4 fixup" in
+ SEQ [| WORD (TY_u32, F_SZ block_fixup);
+ DEF (block_fixup, frag) |]
+
+
+ and ref_type_die
+ (ty:Ast.ty)
+ : frag =
+ (* Returns a DW_FORM_ref_addr to the type. *)
+ if Hashtbl.mem emitted_types ty
+ then Hashtbl.find emitted_types ty
+ else
+ let ref_addr_for_fix fix =
+ let res = dw_form_ref_addr fix in
+ Hashtbl.add emitted_types ty res;
+ res
+ in
+
+ let record trec =
+ let rty = referent_type abi (Ast.TY_rec trec) in
+ let rty_sz = Il.referent_ty_size abi.Abi.abi_word_bits in
+ let fix = new_fixup "record type DIE" in
+ let die = DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_struct_type);
+ (* DW_AT_byte_size: DW_FORM_block4 *)
+ size_block4 (rty_sz rty) false
+ |]);
+ in
+ let rtys =
+ match rty with
+ Il.StructTy rtys -> rtys
+ | _ -> bug () "record type became non-struct referent_ty"
+ in
+ emit_die die;
+ Array.iteri
+ begin
+ fun i (ident, slot) ->
+ emit_die (SEQ [|
+ uleb (get_abbrev_code abbrev_struct_type_member);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die slot);
+ (* DW_AT_mutable: DW_FORM_flag *)
+ BYTE (if slot.Ast.slot_mutable then 1 else 0);
+ (* DW_AT_data_member_location: DW_FORM_block4 *)
+ size_block4
+ (Il.get_element_offset word_bits rtys i)
+ true;
+ (* DW_AT_byte_size: DW_FORM_block4 *)
+ size_block4 (rty_sz rtys.(i)) false |]);
+ end
+ trec;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let string_type _ =
+ (*
+ * Strings, like vecs, are &[rc,alloc,fill,data...]
+ *)
+ let fix = new_fixup "string type DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_string_type);
+ (* (DW_AT_byte_size, DW_FORM_block1); *)
+ dw_form_block1 [| DW_OP_push_object_address;
+ DW_OP_deref;
+ DW_OP_lit (word_sz_int * 2);
+ DW_OP_plus; |];
+ (* (DW_AT_data_location, DW_FORM_block1); *)
+ dw_form_block1 [| DW_OP_push_object_address;
+ DW_OP_deref;
+ DW_OP_lit (word_sz_int * 3);
+ DW_OP_plus |]
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let base (name, encoding, byte_size) =
+ let fix = new_fixup ("base type DIE: " ^ name) in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_base_type);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING name;
+ (* DW_AT_encoding: DW_FORM_data1 *)
+ BYTE (dw_ate_to_int encoding);
+ (* DW_AT_byte_size: DW_FORM_data1 *)
+ BYTE byte_size
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_anon_struct _ =
+ let fix = new_fixup "unspecified-anon-struct DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code
+ abbrev_unspecified_anon_structure_type);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_struct rust_ty =
+ let fix = new_fixup "unspecified-struct DIE" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_unspecified_structure_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int rust_ty);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let rust_type_param (p:(ty_param_idx * Ast.effect)) =
+ let fix = new_fixup "rust-type-param DIE" in
+ let die = DEF (fix, type_param_die p) in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_ptr_with_ref rust_ty ref_addr =
+ let fix = new_fixup ("unspecified-pointer-type-with-ref DIE") in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_unspecified_pointer_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int rust_ty);
+ (* DW_AT_declaration: DW_FORM_flag *)
+ BYTE 1;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_addr
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let formal_type slot =
+ let fix = new_fixup "formal type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_formal_type);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die slot);
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ let fn_type tfn =
+ let (tsig, taux) = tfn in
+ let fix = new_fixup "fn type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_subroutine_type);
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die tsig.Ast.sig_output_slot);
+ encode_effect taux.Ast.fn_effect;
+ (* DW_AT_rust_iterator: DW_FORM_flag *)
+ BYTE (if taux.Ast.fn_is_iter then 1 else 0)
+ |])
+ in
+ emit_die die;
+ Array.iter
+ (fun s -> ignore (formal_type s))
+ tsig.Ast.sig_input_slots;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let obj_fn_type ident tfn =
+ let (tsig, taux) = tfn in
+ let fix = new_fixup "fn type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_obj_subroutine_type);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_slot_die tsig.Ast.sig_output_slot);
+ encode_effect taux.Ast.fn_effect;
+ (* DW_AT_rust_iterator: DW_FORM_flag *)
+ BYTE (if taux.Ast.fn_is_iter then 1 else 0)
+ |])
+ in
+ emit_die die;
+ Array.iter
+ (fun s -> ignore (formal_type s))
+ tsig.Ast.sig_input_slots;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let obj_type (eff,ob) =
+ let fix = new_fixup "object type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_obj_type);
+ encode_effect eff;
+ |])
+ in
+ emit_die die;
+ Hashtbl.iter (fun k v -> ignore (obj_fn_type k v)) ob;
+ emit_null_die ();
+ ref_addr_for_fix fix
+ in
+
+ let unspecified_ptr_with_ref_ty rust_ty ty =
+ unspecified_ptr_with_ref rust_ty (ref_type_die ty)
+ in
+
+ let unspecified_ptr_with_ref_slot rust_ty slot =
+ unspecified_ptr_with_ref rust_ty (ref_slot_die slot)
+ in
+
+ let unspecified_ptr rust_ty =
+ unspecified_ptr_with_ref rust_ty (unspecified_anon_struct ())
+ in
+
+ let native_ptr_type oid =
+ let fix = new_fixup "native type" in
+ let die =
+ DEF (fix, SEQ [|
+ uleb (get_abbrev_code abbrev_native_pointer_type);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_native);
+ (* DW_AT_rust_native_type_id: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int (int_of_opaque oid)));
+ |])
+ in
+ emit_die die;
+ ref_addr_for_fix fix
+ in
+
+ match ty with
+ Ast.TY_nil -> unspecified_struct DW_RUST_nil
+ | Ast.TY_bool -> base ("bool", DW_ATE_boolean, 1)
+ | Ast.TY_mach (TY_u8) -> base ("u8", DW_ATE_unsigned, 1)
+ | Ast.TY_mach (TY_u16) -> base ("u16", DW_ATE_unsigned, 2)
+ | Ast.TY_mach (TY_u32) -> base ("u32", DW_ATE_unsigned, 4)
+ | Ast.TY_mach (TY_u64) -> base ("u64", DW_ATE_unsigned, 8)
+ | Ast.TY_mach (TY_i8) -> base ("i8", DW_ATE_signed, 1)
+ | Ast.TY_mach (TY_i16) -> base ("i16", DW_ATE_signed, 2)
+ | Ast.TY_mach (TY_i32) -> base ("i32", DW_ATE_signed, 4)
+ | Ast.TY_mach (TY_i64) -> base ("i64", DW_ATE_signed, 8)
+ | Ast.TY_int -> base ("int", DW_ATE_signed, word_sz_int)
+ | Ast.TY_uint -> base ("uint", DW_ATE_unsigned, word_sz_int)
+ | Ast.TY_char -> base ("char", DW_ATE_unsigned_char, 4)
+ | Ast.TY_str -> string_type ()
+ | Ast.TY_rec trec -> record trec
+ | Ast.TY_tup ttup ->
+ record (Array.mapi (fun i s ->
+ ("_" ^ (string_of_int i), s))
+ ttup)
+
+ | Ast.TY_vec s -> unspecified_ptr_with_ref_slot DW_RUST_vec s
+ | Ast.TY_chan t -> unspecified_ptr_with_ref_ty DW_RUST_chan t
+ | Ast.TY_port t -> unspecified_ptr_with_ref_ty DW_RUST_port t
+ | Ast.TY_task -> unspecified_ptr DW_RUST_task
+ | Ast.TY_fn fn -> fn_type fn
+ | Ast.TY_tag _ -> unspecified_ptr DW_RUST_tag
+ | Ast.TY_iso _ -> unspecified_ptr DW_RUST_iso
+ | Ast.TY_type -> unspecified_ptr DW_RUST_type
+ | Ast.TY_native i -> native_ptr_type i
+ | Ast.TY_param p -> rust_type_param p
+ | Ast.TY_obj ob -> obj_type ob
+ | _ ->
+ bug () "unimplemented dwarf encoding for type %a"
+ Ast.sprintf_ty ty
+ in
+
+ let finish_crate_cu_and_compose_headers _ =
+
+ let pubnames_header_and_curr_pubnames =
+ SEQ [| (BYTE 0) |]
+ in
+
+ let aranges_header_and_curr_aranges =
+ SEQ [| (BYTE 0) |]
+ in
+
+ let cu_info_fixup = new_fixup "CU debug_info fixup" in
+ let info_header_fixup = new_fixup "CU debug_info header" in
+ let info_header_and_curr_infos =
+ SEQ
+ [|
+ WORD (TY_u32, (* unit_length: *)
+ (ADD
+ ((F_SZ cu_info_fixup), (* including this header,*)
+ (F_SZ info_header_fixup)))); (* excluding this word. *)
+ DEF (info_header_fixup,
+ (SEQ [|
+ WORD (TY_u16, IMM 2L); (* DWARF version *)
+ (* Since we share abbrevs across all CUs,
+ * offset is always 0.
+ *)
+ WORD (TY_u32, IMM 0L); (* CU-abbrev offset. *)
+ BYTE 4; (* Size of an address. *)
+ |]));
+ DEF (cu_info_fixup,
+ SEQ (Array.of_list (List.rev (!curr_cu_infos))));
+ |]
+ in
+
+ let cu_line_fixup = new_fixup "CU debug_line fixup" in
+ let cu_line_header_fixup = new_fixup "CU debug_line header" in
+ let line_header_fixup = new_fixup "CU debug_line header" in
+ let line_header_and_curr_line =
+ SEQ
+ [|
+ WORD
+ (TY_u32, (* unit_length: *)
+ (ADD
+ ((F_SZ cu_line_fixup), (* including this header,*)
+ (F_SZ cu_line_header_fixup)))); (* excluding this word. *)
+ DEF (cu_line_header_fixup,
+ (SEQ [|
+ WORD (TY_u16, IMM 2L); (* DWARF version. *)
+ WORD
+ (TY_u32,
+ (F_SZ line_header_fixup)); (* Another header-length.*)
+ DEF (line_header_fixup,
+ SEQ [|
+ BYTE 1; (* Minimum insn length. *)
+ BYTE 1; (* default_is_stmt *)
+ BYTE 0; (* line_base *)
+ BYTE 0; (* line_range *)
+ BYTE (max_dw_lns + 1); (* opcode_base *)
+ BYTES (* opcode arity array. *)
+ (Array.init max_dw_lns
+ (fun i ->
+ (dw_lns_arity
+ (int_to_dw_lns
+ (i+1)))));
+ (BYTE 0); (* List of include dirs. *)
+ (BYTE 0); (* List of file entries. *)
+ |])|]));
+ DEF (cu_line_fixup,
+ SEQ (Array.of_list (List.rev (!curr_cu_line))));
+ |]
+ in
+ let frame_header_and_curr_frame =
+ SEQ [| (BYTE 0) |]
+ in
+ let prepend_and_reset (curr_ref, accum_ref, header_and_curr) =
+ prepend accum_ref header_and_curr;
+ curr_ref := []
+ in
+ List.iter prepend_and_reset
+ [ (curr_cu_aranges, cu_aranges, aranges_header_and_curr_aranges);
+ (curr_cu_pubnames, cu_pubnames, pubnames_header_and_curr_pubnames);
+ (curr_cu_infos, cu_infos, info_header_and_curr_infos);
+ (curr_cu_line, cu_lines, line_header_and_curr_line);
+ (curr_cu_frame, cu_frames, frame_header_and_curr_frame) ]
+ in
+
+ let image_base_rel (fix:fixup) : expr64 =
+ SUB (M_POS (fix), M_POS (cx.ctxt_image_base_fixup))
+ in
+
+ let addr_ranges (fix:fixup) : frag =
+ let image_is_relocated =
+ match cx.ctxt_sess.Session.sess_targ with
+ Win32_x86_pe ->
+ cx.ctxt_sess.Session.sess_library_mode
+ | _ -> true
+ in
+ let lo =
+ if image_is_relocated
+ then image_base_rel fix
+ else M_POS fix
+ in
+ SEQ [|
+ (* DW_AT_low_pc, DW_FORM_addr *)
+ WORD (word_ty_mach, lo);
+ (* DW_AT_high_pc, DW_FORM_addr *)
+ WORD (word_ty_mach, ADD ((lo),
+ (M_SZ fix)))
+ |]
+ in
+
+ let emit_srcfile_cu_die
+ (name:string)
+ (cu_text_fixup:fixup)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_srcfile_cu in
+ let srcfile_cu_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename name);
+ (* DW_AT_comp_dir: DW_FORM_string *)
+ ZSTRING (Filename.concat (Sys.getcwd()) (Filename.dirname name));
+ addr_ranges cu_text_fixup;
+ |])
+ in
+ emit_die srcfile_cu_die
+ in
+
+ let emit_meta_die
+ (meta:(Ast.ident * string))
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_meta in
+ let die =
+ SEQ [| uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (fst meta);
+ (* DW_AT_const_value: DW_FORM_string *)
+ ZSTRING (snd meta);
+ |]
+ in
+ emit_die die
+ in
+
+ let begin_crate_cu_and_emit_cu_die
+ (name:string)
+
+ (cu_text_fixup:fixup)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_crate_cu in
+ let crate_cu_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_producer: DW_FORM_string *)
+ ZSTRING "Rustboot pre-release";
+ (* DW_AT_language: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM 0x2L); (* DW_LANG_C *)
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename name);
+ (* DW_AT_comp_dir: DW_FORM_string *)
+ ZSTRING (Filename.concat (Sys.getcwd()) (Filename.dirname name));
+ addr_ranges cu_text_fixup;
+ (* DW_AT_use_UTF8, DW_FORM_flag *)
+ BYTE 1
+ |])
+ in
+ curr_cu_infos := [crate_cu_die];
+ curr_cu_line := []
+ in
+
+ let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.effect))) =
+ let (ident, (idx, eff)) = p in
+ SEQ [|
+ uleb (get_abbrev_code abbrev_rust_type_param_decl);
+ (* DW_AT_rust_type_code: DW_FORM_data1 *)
+ BYTE (dw_rust_type_to_int DW_RUST_type_param);
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING (Filename.basename ident);
+ (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
+ WORD (word_ty_mach, IMM (Int64.of_int idx));
+ encode_effect eff;
+ |]
+ in
+
+ let emit_type_param_decl_dies
+ (params:(Ast.ty_param identified) array)
+ : unit =
+ Array.iter
+ (fun p ->
+ emit_die (type_param_decl_die p.node))
+ params;
+ in
+
+ let emit_module_die
+ (id:Ast.ident)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_module in
+ let module_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name *)
+ ZSTRING id;
+ |])
+ in
+ emit_die module_die;
+ in
+
+ let emit_subprogram_die
+ (id:Ast.ident)
+ (ret_slot:Ast.slot)
+ (effect:Ast.effect)
+ (fix:fixup)
+ : unit =
+ (* NB: retpc = "top word of frame-base" by convention in ABI/x86. *)
+ let abi = cx.ctxt_abi in
+ let retpc = Int64.sub abi.Abi.abi_frame_base_sz abi.Abi.abi_word_sz in
+ let abbrev_code = get_abbrev_code abbrev_subprogram in
+ let subprogram_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name *)
+ ZSTRING id;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_slot_die ret_slot;
+ addr_ranges fix;
+ (* DW_AT_frame_base *)
+ dw_form_block1 [| DW_OP_reg abi.Abi.abi_dwarf_fp_reg |];
+ (* DW_AT_return_addr *)
+ dw_form_block1 [| DW_OP_fbreg (Asm.IMM retpc); |];
+ encode_effect effect;
+ |])
+ in
+ emit_die subprogram_die
+ in
+
+ let emit_typedef_die
+ (id:Ast.ident)
+ (ty:Ast.ty)
+ : unit =
+ let abbrev_code = get_abbrev_code abbrev_typedef in
+ let typedef_die =
+ (SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING id;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ (ref_type_die ty);
+ |])
+ in
+ emit_die typedef_die
+ in
+
+ let visit_crate_pre
+ (crate:Ast.crate)
+ : unit =
+ let filename = (Hashtbl.find cx.ctxt_item_files crate.id) in
+ log cx "walking crate CU '%s'" filename;
+ begin_crate_cu_and_emit_cu_die filename
+ (Hashtbl.find cx.ctxt_file_fixups crate.id);
+ Array.iter emit_meta_die crate.node.Ast.crate_meta;
+ inner.Walk.visit_crate_pre crate
+ in
+
+ let visit_mod_item_pre
+ (id:Ast.ident)
+ (params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ if Hashtbl.mem cx.ctxt_item_files item.id
+ then
+ begin
+ let filename = (Hashtbl.find cx.ctxt_item_files item.id) in
+ log cx "walking srcfile CU '%s'" filename;
+ emit_srcfile_cu_die filename
+ (Hashtbl.find cx.ctxt_file_fixups item.id);
+ end
+ else
+ ();
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod _ ->
+ begin
+ log cx "walking module '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_module_die id;
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | Ast.MOD_ITEM_fn _ ->
+ begin
+ let ty = Hashtbl.find cx.ctxt_all_item_types item.id in
+ let (tsig,taux) =
+ match ty with
+ Ast.TY_fn tfn -> tfn
+ | _ ->
+ bug ()
+ "non-fn type when emitting dwarf for MOD_ITEM_fn"
+ in
+ log cx "walking function '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_subprogram_die
+ id tsig.Ast.sig_output_slot taux.Ast.fn_effect
+ (Hashtbl.find cx.ctxt_fn_fixups item.id);
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | Ast.MOD_ITEM_type _ ->
+ begin
+ log cx "walking typedef '%s' with %d type params"
+ (path_name())
+ (Array.length item.node.Ast.decl_params);
+ emit_typedef_die
+ id (Hashtbl.find cx.ctxt_all_type_items item.id);
+ emit_type_param_decl_dies item.node.Ast.decl_params;
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre id params item
+ in
+
+ let visit_crate_post
+ (crate:Ast.crate)
+ : unit =
+ inner.Walk.visit_crate_post crate;
+ assert (Hashtbl.mem cx.ctxt_item_files crate.id);
+ emit_null_die();
+ log cx
+ "finishing crate CU and composing headers (%d DIEs collected)"
+ (List.length (!curr_cu_infos));
+ finish_crate_cu_and_compose_headers ()
+ in
+
+ let visit_mod_item_post
+ (id:Ast.ident)
+ (params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ inner.Walk.visit_mod_item_post id params item;
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod _
+ | Ast.MOD_ITEM_fn _
+ | Ast.MOD_ITEM_type _ -> emit_null_die ()
+ | _ -> ()
+ end;
+ if Hashtbl.mem cx.ctxt_item_files item.id
+ then emit_null_die()
+ in
+
+ let visit_block_pre (b:Ast.block) : unit =
+ log cx "entering lexical block";
+ let fix = Hashtbl.find cx.ctxt_block_fixups b.id in
+ let abbrev_code = get_abbrev_code abbrev_lexical_block in
+ let block_die =
+ SEQ [|
+ uleb abbrev_code;
+ addr_ranges fix;
+ |]
+ in
+ emit_die block_die;
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_block_post (b:Ast.block) : unit =
+ inner.Walk.visit_block_post b;
+ log cx "leaving lexical block, terminating with NULL DIE";
+ emit_null_die ()
+ in
+
+ let visit_slot_identified_pre (s:Ast.slot identified) : unit =
+ begin
+ match htab_search cx.ctxt_slot_keys s.id with
+ None
+ | Some Ast.KEY_temp _ -> ()
+ | Some Ast.KEY_ident ident ->
+ begin
+ let abbrev_code =
+ if Hashtbl.mem cx.ctxt_slot_is_arg s.id
+ then get_abbrev_code abbrev_formal
+ else get_abbrev_code abbrev_variable
+ in
+ let resolved_slot = referent_to_slot cx s.id in
+ let emit_var_die slot_loc =
+ let var_die =
+ SEQ [|
+ uleb abbrev_code;
+ (* DW_AT_name: DW_FORM_string *)
+ ZSTRING ident;
+ (* DW_AT_location: DW_FORM_block1 *)
+ dw_form_block1 slot_loc;
+ (* DW_AT_type: DW_FORM_ref_addr *)
+ ref_slot_die resolved_slot
+ |]
+ in
+ emit_die var_die;
+ in
+ match htab_search cx.ctxt_slot_offsets s.id with
+ Some off ->
+ begin
+ match Il.size_to_expr64 off with
+ (* FIXME: handle dynamic-size slots. *)
+ None -> ()
+ | Some off ->
+ emit_var_die
+ [| DW_OP_fbreg off |]
+ end
+ | None ->
+ (* FIXME (issue #28): handle slots assigned to
+ * vregs.
+ *)
+ ()
+ end
+ end;
+ inner.Walk.visit_slot_identified_pre s
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post;
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post;
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre
+ }
+;;
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : debug_records =
+
+ let cu_aranges = ref [] in
+ let cu_pubnames = ref [] in
+ let cu_infos = ref [] in
+ let cu_abbrevs = ref [] in
+ let cu_lines = ref [] in
+ let cu_frames = ref [] in
+
+ let path = Stack.create () in
+
+ let passes =
+ [|
+ dwarf_visitor cx Walk.empty_visitor path
+ cx.ctxt_debug_info_fixup
+ cu_aranges cu_pubnames
+ cu_infos cu_abbrevs
+ cu_lines cu_frames
+ |];
+ in
+
+ log cx "emitting DWARF records";
+ run_passes cx "dwarf" path passes (log cx "%s") crate;
+
+ (* Terminate the tables. *)
+ {
+ debug_aranges = SEQ (Array.of_list (List.rev (!cu_aranges)));
+ debug_pubnames = SEQ (Array.of_list (List.rev (!cu_pubnames)));
+ debug_info = SEQ (Array.of_list (List.rev (!cu_infos)));
+ debug_abbrev = SEQ (Array.of_list (List.rev (!cu_abbrevs)));
+ debug_line = SEQ (Array.of_list (List.rev (!cu_lines)));
+ debug_frame = SEQ (Array.of_list (List.rev (!cu_frames)));
+ }
+;;
+
+(*
+ * Support for reconstituting a DWARF tree from a file, and various
+ * artifacts we can distill back from said DWARF.
+ *)
+
+let log sess = Session.log "dwarf"
+ sess.Session.sess_log_dwarf
+ sess.Session.sess_log_out
+;;
+
+
+let iflog (sess:Session.sess) (thunk:(unit -> unit)) : unit =
+ if sess.Session.sess_log_dwarf
+ then thunk ()
+ else ()
+;;
+
+let read_abbrevs
+ (sess:Session.sess)
+ (ar:asm_reader)
+ ((off:int),(sz:int))
+ : (int,abbrev) Hashtbl.t =
+ ar.asm_seek off;
+ let abs = Hashtbl.create 0 in
+ let rec read_abbrevs _ =
+ if ar.asm_get_off() >= (off + sz)
+ then abs
+ else
+ begin
+ let n = ar.asm_get_uleb() in
+ let tag = ar.asm_get_uleb() in
+ let has_children = ar.asm_get_u8() in
+ let pairs = ref [] in
+ let _ =
+ log sess "abbrev: %d, tag: %d, has_children: %d"
+ n tag has_children
+ in
+ let rec read_pairs _ =
+ let attr = ar.asm_get_uleb() in
+ let form = ar.asm_get_uleb() in
+ let _ = log sess "attr: %d, form: %d" attr form in
+ match (attr,form) with
+ (0,0) -> Array.of_list (List.rev (!pairs))
+ | _ ->
+ begin
+ pairs := (dw_at_of_int attr,
+ dw_form_of_int form) :: (!pairs);
+ read_pairs()
+ end
+ in
+ let pairs = read_pairs() in
+ Hashtbl.add abs n (dw_tag_of_int tag,
+ dw_children_of_int has_children,
+ pairs);
+ read_abbrevs()
+ end;
+ in
+ read_abbrevs()
+;;
+
+type data =
+ DATA_str of string
+ | DATA_num of int
+ | DATA_other
+;;
+
+type die =
+ { die_off: int;
+ die_tag: dw_tag;
+ die_attrs: (dw_at * (dw_form * data)) array;
+ die_children: die array; }
+;;
+
+type rooted_dies = (int * (int,die) Hashtbl.t)
+;;
+
+let fmt_dies
+ (ff:Format.formatter)
+ (dies:rooted_dies)
+ : unit =
+ let ((root:int),(dies:(int,die) Hashtbl.t)) = dies in
+ let rec fmt_die die =
+ Ast.fmt ff "@\nDIE <0x%x> %s" die.die_off (dw_tag_to_string die.die_tag);
+ Array.iter
+ begin
+ fun (at,(form,data)) ->
+ Ast.fmt ff "@\n %s = " (dw_at_to_string at);
+ begin
+ match data with
+ DATA_num n -> Ast.fmt ff "0x%x" n
+ | DATA_str s -> Ast.fmt ff "\"%s\"" s
+ | DATA_other -> Ast.fmt ff "<other>"
+ end;
+ Ast.fmt ff " (%s)" (dw_form_to_string form)
+ end
+ die.die_attrs;
+ if (Array.length die.die_children) != 0
+ then
+ begin
+ Ast.fmt ff "@\n";
+ Ast.fmt_obox ff;
+ Ast.fmt ff " children: ";
+ Ast.fmt_obr ff;
+ Array.iter fmt_die die.die_children;
+ Ast.fmt_cbb ff
+ end;
+ in
+ fmt_die (Hashtbl.find dies root)
+;;
+
+let read_dies
+ (sess:Session.sess)
+ (ar:asm_reader)
+ ((off:int),(sz:int))
+ (abbrevs:(int,abbrev) Hashtbl.t)
+ : (int * ((int,die) Hashtbl.t)) =
+ ar.asm_seek off;
+ let cu_len = ar.asm_get_u32() in
+ let _ = log sess "debug_info cu_len: %d, section size %d" cu_len sz in
+ let _ = assert ((cu_len + 4) = sz) in
+ let dwarf_vers = ar.asm_get_u16() in
+ let _ = assert (dwarf_vers >= 2) in
+ let cu_abbrev_off = ar.asm_get_u32() in
+ let _ = assert (cu_abbrev_off = 0) in
+ let sizeof_addr = ar.asm_get_u8() in
+ let _ = assert (sizeof_addr = 4) in
+
+ let adv_block1 _ =
+ let len = ar.asm_get_u8() in
+ ar.asm_adv len
+ in
+
+ let adv_block4 _ =
+ let len = ar.asm_get_u32() in
+ ar.asm_adv len
+ in
+
+ let all_dies = Hashtbl.create 0 in
+ let root = (ar.asm_get_off()) - off in
+
+ let rec read_dies (dies:(die list) ref) =
+ let die_arr _ = Array.of_list (List.rev (!dies)) in
+ if ar.asm_get_off() >= (off + sz)
+ then die_arr()
+ else
+ begin
+ let die_off = (ar.asm_get_off()) - off in
+ let abbrev_num = ar.asm_get_uleb() in
+ if abbrev_num = 0
+ then die_arr()
+ else
+ let _ =
+ log sess "DIE at off <%d> with abbrev %d"
+ die_off abbrev_num
+ in
+ let abbrev = Hashtbl.find abbrevs abbrev_num in
+ let (tag, children, attrs) = abbrev in
+ let attrs =
+ Array.map
+ begin
+ fun (attr,form) ->
+ let data =
+ match form with
+ DW_FORM_string -> DATA_str (ar.asm_get_zstr())
+ | DW_FORM_addr -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_ref_addr -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_data1 -> DATA_num (ar.asm_get_u8())
+ | DW_FORM_data4 -> DATA_num (ar.asm_get_u32())
+ | DW_FORM_flag -> DATA_num (ar.asm_get_u8())
+ | DW_FORM_block1 -> (adv_block1(); DATA_other)
+ | DW_FORM_block4 -> (adv_block4(); DATA_other)
+ | _ ->
+ bug () "unknown DWARF form %d"
+ (dw_form_to_int form)
+ in
+ (attr, (form, data))
+ end
+ attrs;
+ in
+ let children =
+ match children with
+ DW_CHILDREN_yes -> read_dies (ref [])
+ | DW_CHILDREN_no -> [| |]
+ in
+ let die = { die_off = die_off;
+ die_tag = tag;
+ die_attrs = attrs;
+ die_children = children }
+ in
+ prepend dies die;
+ htab_put all_dies die_off die;
+ read_dies dies
+ end
+ in
+ ignore (read_dies (ref []));
+ iflog sess
+ begin
+ fun _ ->
+ log sess "read DIEs:";
+ log sess "%s" (Ast.fmt_to_str fmt_dies (root, all_dies));
+ end;
+ (root, all_dies)
+;;
+
+let rec extract_meta
+ ((i:int),(dies:(int,die) Hashtbl.t))
+ : (Ast.ident * string) array =
+ let meta = Queue.create () in
+
+ let get_attr die attr =
+ atab_find die.die_attrs attr
+ in
+
+ let get_str die attr =
+ match get_attr die attr with
+ (_, DATA_str s) -> s
+ | _ -> bug () "unexpected num form for %s" (dw_at_to_string attr)
+ in
+
+ let die = Hashtbl.find dies i in
+ begin
+ match die.die_tag with
+ DW_TAG_rust_meta ->
+ let n = get_str die DW_AT_name in
+ let v = get_str die DW_AT_const_value in
+ Queue.add (n,v) meta
+
+ | DW_TAG_compile_unit ->
+ Array.iter
+ (fun child ->
+ Array.iter (fun m -> Queue.add m meta)
+ (extract_meta (child.die_off,dies)))
+ die.die_children
+
+ | _ -> ()
+ end;
+ queue_to_arr meta
+;;
+
+
+let rec extract_mod_items
+ (nref:node_id ref)
+ (oref:opaque_id ref)
+ (abi:Abi.abi)
+ (mis:Ast.mod_items)
+ ((i:int),(dies:(int,die) Hashtbl.t))
+ : unit =
+
+ let next_node_id _ : node_id =
+ let id = !nref in
+ nref:= Node ((int_of_node id)+1);
+ id
+ in
+
+ let next_opaque_id _ : opaque_id =
+ let id = !oref in
+ oref:= Opaque ((int_of_opaque id)+1);
+ id
+ in
+
+ let external_opaques = Hashtbl.create 0 in
+ let get_opaque_of o =
+ htab_search_or_add external_opaques o
+ (fun _ -> next_opaque_id())
+ in
+
+
+ let (word_sz:int64) = abi.Abi.abi_word_sz in
+ let (word_sz_int:int) = Int64.to_int word_sz in
+
+ let get_die i =
+ Hashtbl.find dies i
+ in
+
+ let get_attr die attr =
+ atab_find die.die_attrs attr
+ in
+
+ let get_str die attr =
+ match get_attr die attr with
+ (_, DATA_str s) -> s
+ | _ -> bug () "unexpected num form for %s" (dw_at_to_string attr)
+ in
+
+ let get_num die attr =
+ match get_attr die attr with
+ (_, DATA_num n) -> n
+ | _ -> bug () "unexpected str form for %s" (dw_at_to_string attr)
+ in
+
+ let get_flag die attr =
+ match get_attr die attr with
+ (_, DATA_num 0) -> false
+ | (_, DATA_num 1) -> true
+ | _ -> bug () "unexpected non-flag form for %s" (dw_at_to_string attr)
+ in
+
+ let get_effect die =
+ match (get_flag die DW_AT_mutable, get_flag die DW_AT_pure) with
+ (* Note: weird encoding: mutable+pure = unsafe. *)
+ (true, true) -> Ast.UNSAFE
+ | (true, false) -> Ast.STATE
+ | (false, false) -> Ast.IO
+ | (false, true) -> Ast.PURE
+ in
+
+ let get_name die = get_str die DW_AT_name in
+
+ let get_type_param die =
+ let idx = get_num die DW_AT_rust_type_param_index in
+ let e = get_effect die in
+ (idx, e)
+ in
+
+ let get_native_id die =
+ get_num die DW_AT_rust_native_type_id
+ in
+
+ let get_type_param_decl die =
+ ((get_str die DW_AT_name), (get_type_param die))
+ in
+
+ let is_rust_type die t =
+ match atab_search die.die_attrs DW_AT_rust_type_code with
+ Some (_, DATA_num n) -> (dw_rust_type_of_int n) = t
+ | _ -> false
+ in
+
+ let rec get_ty die : Ast.ty =
+ match die.die_tag with
+
+ DW_TAG_structure_type
+ when is_rust_type die DW_RUST_nil ->
+ Ast.TY_nil
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_task ->
+ Ast.TY_task
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_type ->
+ Ast.TY_type
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_port ->
+ Ast.TY_port (get_referenced_ty die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_chan ->
+ Ast.TY_chan (get_referenced_ty die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_vec ->
+ Ast.TY_vec (get_referenced_slot die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_type_param ->
+ Ast.TY_param (get_type_param die)
+
+ | DW_TAG_pointer_type
+ when is_rust_type die DW_RUST_native ->
+ Ast.TY_native (get_opaque_of (get_native_id die))
+
+ | DW_TAG_string_type -> Ast.TY_str
+
+ | DW_TAG_base_type ->
+ begin
+ match ((get_name die),
+ (dw_ate_of_int (get_num die DW_AT_encoding)),
+ (get_num die DW_AT_byte_size)) with
+ ("bool", DW_ATE_boolean, 1) -> Ast.TY_bool
+ | ("u8", DW_ATE_unsigned, 1) -> Ast.TY_mach TY_u8
+ | ("u16", DW_ATE_unsigned, 2) -> Ast.TY_mach TY_u16
+ | ("u32", DW_ATE_unsigned, 4) -> Ast.TY_mach TY_u32
+ | ("u64", DW_ATE_unsigned, 8) -> Ast.TY_mach TY_u64
+ | ("i8", DW_ATE_signed, 1) -> Ast.TY_mach TY_i8
+ | ("i16", DW_ATE_signed, 2) -> Ast.TY_mach TY_i16
+ | ("i32", DW_ATE_signed, 4) -> Ast.TY_mach TY_i32
+ | ("i64", DW_ATE_signed, 8) -> Ast.TY_mach TY_i64
+ | ("char", DW_ATE_unsigned_char, 4) -> Ast.TY_char
+ | ("int", DW_ATE_signed, sz)
+ when sz = word_sz_int -> Ast.TY_int
+ | ("uint", DW_ATE_unsigned, sz)
+ when sz = word_sz_int -> Ast.TY_uint
+ | _ -> bug () "unexpected type of DW_TAG_base_type"
+ end
+
+ | DW_TAG_structure_type ->
+ begin
+ let is_num_idx s =
+ let len = String.length s in
+ if len >= 2 && s.[0] = '_'
+ then
+ let ok = ref true in
+ String.iter
+ (fun c -> ok := (!ok) && '0' <= c && c <= '9')
+ (String.sub s 1 (len-1));
+ !ok
+ else
+ false
+ in
+ let members = arr_map_partial
+ die.die_children
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_member
+ then Some child
+ else None
+ end
+ in
+ assert ((Array.length members) > 0);
+ if is_num_idx (get_name members.(0))
+ then
+ let slots = Array.map get_referenced_slot members in
+ Ast.TY_tup slots
+ else
+ let entries =
+ Array.map
+ (fun member_die -> ((get_name member_die),
+ (get_referenced_slot member_die)))
+ members
+ in
+ Ast.TY_rec entries
+ end
+
+ | DW_TAG_interface_type ->
+ let eff = get_effect die in
+ let fns = Hashtbl.create 0 in
+ Array.iter
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_subroutine_type
+ then
+ Hashtbl.add fns (get_name child) (get_ty_fn child)
+ end
+ die.die_children;
+ Ast.TY_obj (eff,fns)
+
+ | DW_TAG_subroutine_type ->
+ Ast.TY_fn (get_ty_fn die)
+
+ | _ ->
+ bug () "unexpected tag in get_ty: %s"
+ (dw_tag_to_string die.die_tag)
+
+ and get_slot die : Ast.slot =
+ match die.die_tag with
+ DW_TAG_reference_type ->
+ let ty = get_referenced_ty die in
+ let mut = get_flag die DW_AT_mutable in
+ let mode =
+ (* Exterior slots have a 'data_location' attr. *)
+ match atab_search die.die_attrs DW_AT_data_location with
+ Some _ -> Ast.MODE_exterior
+ | None -> Ast.MODE_alias
+ in
+ { Ast.slot_mode = mode;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+ | _ ->
+ let ty = get_ty die in
+ (* FIXME: encode mutability of interior slots properly. *)
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = Some ty }
+
+ and get_referenced_ty die =
+ match get_attr die DW_AT_type with
+ (DW_FORM_ref_addr, DATA_num n) -> get_ty (get_die n)
+ | _ -> bug () "unexpected form of DW_AT_type in get_referenced_ty"
+
+ and get_referenced_slot die =
+ match get_attr die DW_AT_type with
+ (DW_FORM_ref_addr, DATA_num n) -> get_slot (get_die n)
+ | _ -> bug () "unexpected form of DW_AT_type in get_referenced_slot"
+
+ and get_ty_fn die =
+ let out = get_referenced_slot die in
+ let ins =
+ arr_map_partial
+ die.die_children
+ begin
+ fun child ->
+ if child.die_tag = DW_TAG_formal_parameter
+ then Some (get_referenced_slot child)
+ else None
+ end
+ in
+ let effect = get_effect die in
+ let iter = get_flag die DW_AT_rust_iterator in
+ let tsig =
+ { Ast.sig_input_slots = ins;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = out; }
+ in
+ let taux =
+ { Ast.fn_is_iter = iter;
+ Ast.fn_effect = effect }
+ in
+ (tsig, taux)
+ in
+
+ let wrap n =
+ { id = next_node_id ();
+ node = n }
+ in
+
+ let decl p i =
+ wrap { Ast.decl_params = p;
+ Ast.decl_item = i; }
+ in
+
+ let get_formals die =
+ let islots = Queue.create () in
+ let params = Queue.create () in
+ Array.iter
+ begin
+ fun child ->
+ match child.die_tag with
+ DW_TAG_formal_parameter ->
+ if (is_rust_type child DW_RUST_type_param)
+ then Queue.push (wrap (get_type_param_decl child)) params
+ else Queue.push (get_referenced_slot child) islots
+ | _ -> ()
+ end
+ die.die_children;
+ (queue_to_arr params, queue_to_arr islots)
+ in
+
+ let extract_children mis die =
+ Array.iter
+ (fun child ->
+ extract_mod_items nref oref abi mis (child.die_off,dies))
+ die.die_children
+ in
+
+ let get_mod_items die =
+ let len = Array.length die.die_children in
+ let mis = Hashtbl.create len in
+ extract_children mis die;
+ mis
+ in
+
+ let form_header_slots slots =
+ Array.mapi
+ (fun i slot -> (wrap slot, "_" ^ (string_of_int i)))
+ slots
+ in
+
+ let die = Hashtbl.find dies i in
+ match die.die_tag with
+ DW_TAG_typedef ->
+ let ident = get_name die in
+ let ty = get_referenced_ty die in
+ let tyi = Ast.MOD_ITEM_type ty in
+ let (params, islots) = get_formals die in
+ assert ((Array.length islots) = 0);
+ htab_put mis ident (decl params tyi)
+
+ | DW_TAG_compile_unit ->
+ extract_children mis die
+
+ | DW_TAG_module ->
+ let ident = get_name die in
+ let sub_mis = get_mod_items die in
+ let exports = Hashtbl.create 0 in
+ let _ = Hashtbl.add exports Ast.EXPORT_all_decls () in
+ let view = { Ast.view_imports = Hashtbl.create 0;
+ Ast.view_exports = exports }
+ in
+ let mi = Ast.MOD_ITEM_mod (view, sub_mis) in
+ htab_put mis ident (decl [||] mi)
+
+ | DW_TAG_subprogram ->
+ (* FIXME: finish this. *)
+ let ident = get_name die in
+ let oslot = get_referenced_slot die in
+ let effect = get_effect die in
+ let (params, islots) = get_formals die in
+ let taux = { Ast.fn_effect = effect;
+ Ast.fn_is_iter = false }
+ in
+ let tfn = { Ast.fn_input_slots = form_header_slots islots;
+ Ast.fn_input_constrs = [| |];
+ Ast.fn_output_slot = wrap oslot;
+ Ast.fn_aux = taux;
+ Ast.fn_body = (wrap [||]); }
+ in
+ let fn = Ast.MOD_ITEM_fn tfn in
+ htab_put mis ident (decl params fn)
+
+ | _ -> ()
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml
new file mode 100644
index 00000000..515cfa21
--- /dev/null
+++ b/src/boot/me/effect.ml
@@ -0,0 +1,313 @@
+open Semant;;
+open Common;;
+
+let log cx = Session.log "effect"
+ cx.ctxt_sess.Session.sess_log_effect
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_effect
+ then thunk ()
+ else ()
+;;
+
+let mutability_checking_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor enforces the following rules:
+ *
+ * - A channel type carrying a mutable type is illegal.
+ *
+ * - Writing to an immutable slot is illegal.
+ *
+ * - Forming a mutable alias to an immutable slot is illegal.
+ *
+ *)
+ let visit_ty_pre t =
+ match t with
+ Ast.TY_chan t' when type_has_state t' ->
+ err None "channel of mutable type: %a " Ast.sprintf_ty t'
+ | _ -> ()
+ in
+
+ let check_write id dst =
+ let dst_slot = lval_slot cx dst in
+ if (dst_slot.Ast.slot_mutable or
+ (Hashtbl.mem cx.ctxt_copy_stmt_is_init id))
+ then ()
+ else err (Some id) "writing to non-mutable slot"
+ in
+ (* FIXME: enforce the no-write-alias-to-immutable-slot rule. *)
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_copy (dst, _) -> check_write s.id dst
+ | Ast.STMT_copy_binop (dst, _, _) -> check_write s.id dst
+ | Ast.STMT_call (dst, _, _) -> check_write s.id dst
+ | Ast.STMT_recv (dst, _) -> check_write s.id dst
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ { inner with
+ Walk.visit_ty_pre = visit_ty_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let function_effect_propagation_visitor
+ (item_effect:(node_id, Ast.effect) Hashtbl.t)
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor calculates the effect of each function according to
+ * its statements:
+ *
+ * - Communication lowers to 'io'
+ * - Native calls lower to 'unsafe'
+ * - Calling a function with effect e lowers to e.
+ *)
+ let curr_fn = Stack.create () in
+ let visit_mod_item_pre n p i =
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn _ -> Stack.push i.id curr_fn
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn _ -> ignore (Stack.pop curr_fn)
+ | _ -> ()
+ in
+ let visit_obj_drop_pre o b =
+ Stack.push b.id curr_fn;
+ inner.Walk.visit_obj_drop_pre o b
+ in
+ let visit_obj_drop_post o b =
+ inner.Walk.visit_obj_drop_post o b;
+ ignore (Stack.pop curr_fn);
+ in
+
+ let lower_to s ne =
+ let fn_id = Stack.top curr_fn in
+ let e =
+ match htab_search item_effect fn_id with
+ None -> Ast.PURE
+ | Some e -> e
+ in
+ let ne = lower_effect_of ne e in
+ if ne <> e
+ then
+ begin
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names fn_id in
+ log cx "lowering calculated effect on '%a': '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect e
+ Ast.sprintf_effect ne;
+ log cx "at stmt %a" Ast.sprintf_stmt s
+ end;
+ Hashtbl.replace item_effect fn_id ne
+ end;
+ in
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_send _
+ | Ast.STMT_recv _ -> lower_to s Ast.IO
+
+ | Ast.STMT_call (_, fn, _) ->
+ let lower_to_callee_ty t =
+ match t with
+ Ast.TY_fn (_, taux) ->
+ lower_to s taux.Ast.fn_effect;
+ | _ -> bug () "non-fn callee"
+ in
+ if lval_is_slot cx fn
+ then
+ let t = lval_slot cx fn in
+ lower_to_callee_ty (slot_ty t)
+ else
+ begin
+ let item = lval_item cx fn in
+ let t = Hashtbl.find cx.ctxt_all_item_types item.id in
+ lower_to_callee_ty t;
+ match htab_search cx.ctxt_required_items item.id with
+ None -> ()
+ | Some (REQUIRED_LIB_rust _, _) -> ()
+ | Some _ -> lower_to s Ast.UNSAFE
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post;
+ Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+ Walk.visit_obj_drop_post = visit_obj_drop_post;
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let binding_effect_propagation_visitor
+ ((*cx*)_:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (* This visitor lowers the effect of an object or binding according
+ * to its slots: holding a 'state' slot lowers any obj item, or
+ * bind-stmt LHS, to 'state'.
+ *
+ * Binding (or implicitly just making a native 1st-class) makes the LHS
+ * unsafe.
+ *)
+ inner
+;;
+
+let effect_checking_visitor
+ (item_auth:(node_id, Ast.effect) Hashtbl.t)
+ (item_effect:(node_id, Ast.effect) Hashtbl.t)
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * This visitor checks that each type, item and obj declares
+ * effects consistent with what we calculated.
+ *)
+ let auth_stack = Stack.create () in
+ let visit_mod_item_pre n p i =
+ begin
+ match htab_search item_auth i.id with
+ None -> ()
+ | Some e ->
+ let curr =
+ if Stack.is_empty auth_stack
+ then Ast.PURE
+ else Stack.top auth_stack
+ in
+ let next = lower_effect_of e curr in
+ Stack.push next auth_stack;
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ log cx
+ "entering '%a', adjusting auth effect: '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect curr
+ Ast.sprintf_effect next
+ end
+ end;
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let e =
+ match htab_search item_effect i.id with
+ None -> Ast.PURE
+ | Some e -> e
+ in
+ let fe = f.Ast.fn_aux.Ast.fn_effect in
+ let ae =
+ if Stack.is_empty auth_stack
+ then None
+ else Some (Stack.top auth_stack)
+ in
+ if e <> fe && (ae <> (Some e))
+ then
+ begin
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ err (Some i.id)
+ "%a claims effect '%a' but calculated effect is '%a'%s"
+ Ast.sprintf_name name
+ Ast.sprintf_effect fe
+ Ast.sprintf_effect e
+ begin
+ match ae with
+ Some ae when ae <> fe ->
+ Printf.sprintf " (auth effect is '%a')"
+ Ast.sprintf_effect ae
+ | _ -> ""
+ end
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ match htab_search item_auth i.id with
+ None -> ()
+ | Some _ ->
+ let curr = Stack.pop auth_stack in
+ let next =
+ if Stack.is_empty auth_stack
+ then Ast.PURE
+ else Stack.top auth_stack
+ in
+ iflog cx
+ begin
+ fun _ ->
+ let name = Hashtbl.find cx.ctxt_all_item_names i.id in
+ log cx
+ "leaving '%a', restoring auth effect: '%a' -> '%a'"
+ Ast.sprintf_name name
+ Ast.sprintf_effect curr
+ Ast.sprintf_effect next
+ end
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_mod_item_post = visit_mod_item_post; }
+;;
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let item_auth = Hashtbl.create 0 in
+ let item_effect = Hashtbl.create 0 in
+ let passes =
+ [|
+ (mutability_checking_visitor cx
+ Walk.empty_visitor);
+ (function_effect_propagation_visitor item_effect cx
+ Walk.empty_visitor);
+ (binding_effect_propagation_visitor cx
+ Walk.empty_visitor);
+ (effect_checking_visitor item_auth item_effect cx
+ Walk.empty_visitor);
+ |]
+ in
+ let root_scope = [ SCOPE_crate crate ] in
+ let auth_effect name eff =
+ match lookup_by_name cx root_scope name with
+ None -> ()
+ | Some (_, id) ->
+ if referent_is_item cx id
+ then htab_put item_auth id eff
+ 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
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml
new file mode 100644
index 00000000..6c4567fd
--- /dev/null
+++ b/src/boot/me/layout.ml
@@ -0,0 +1,470 @@
+open Semant;;
+open Common;;
+
+let log cx = Session.log "layout"
+ cx.ctxt_sess.Session.sess_log_layout
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+type slot_stack = Il.referent_ty Stack.t;;
+type frame_blocks = slot_stack Stack.t;;
+
+let layout_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ (*
+ * - Frames look, broadly, like this (growing downward):
+ *
+ * +----------------------------+ <-- Rewind tail calls to here.
+ * |caller args |
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp + abi_frame_base_sz
+ * |task ptr (implicit arg) | + abi_implicit_args_sz
+ * |output ptr (implicit arg) |
+ * +----------------------------+ <-- fp + abi_frame_base_sz
+ * |return pc |
+ * |callee-save registers |
+ * |... |
+ * +----------------------------+ <-- fp
+ * |crate ptr |
+ * |crate-rel frame info disp |
+ * +----------------------------+ <-- fp - abi_frame_info_sz
+ * |spills determined in ra |
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - (abi_frame_info_sz
+ * |... | + spillsz)
+ * |frame-allocated stuff |
+ * |determined in resolve |
+ * |laid out in layout |
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - framesz
+ * |call space | == sp + callsz
+ * |... |
+ * |... |
+ * +----------------------------+ <-- fp - (framesz + callsz) == sp
+ *
+ * - Slot offsets fall into three classes:
+ *
+ * #1 frame-locals are negative offsets from fp
+ * (beneath the frame-info and spills)
+ *
+ * #2 incoming arg slots are positive offsets from fp
+ * (above the frame-base)
+ *
+ * #3 outgoing arg slots are positive offsets from sp
+ *
+ * - Slots are split into two classes:
+ *
+ * #1 those that are never aliased and fit in a word, so are
+ * vreg-allocated
+ *
+ * #2 all others
+ *
+ * - Non-aliased, word-fitting slots consume no frame space
+ * *yet*; they are given a generic value that indicates "try a
+ * vreg". The register allocator may spill them later, if it
+ * needs to, but that's not our concern.
+ *
+ * - Aliased / too-big slots are frame-allocated, need to be
+ * laid out in the frame at fixed offsets.
+ *
+ * - The frame size is the maximum of all the block sizes contained
+ * within it. Though at the moment it's the sum of them, due to
+ * the blood-curdling hack we use to ensure proper unwind/drop
+ * behavior in absence of CFI or similar precise frame-evolution
+ * tracking. See visit_block_post below (issue #27).
+ *
+ * - Each call is examined and the size of the call tuple required
+ * for that call is calculated. The call size is the maximum of all
+ * such call tuples.
+ *
+ * - In frames that have a tail call (in fact, currently, all frames
+ * because we're lazy) we double the call size in order to handle
+ * the possible need to *execute* a call (to drop glue) while
+ * destroying the frame, after we've built the outgoing args. This is
+ * done in the backend though; the logic in this file is ignorant of the
+ * doubling (some platforms may not require it? Hard to guess)
+ *
+ *)
+
+ let force_slot_to_mem (slot:Ast.slot) : bool =
+ (* FIXME (issue #26): For the time being we force any slot that
+ * points into memory or is of opaque/code type to be stored in the
+ * frame rather than in a vreg. This can probably be relaxed in the
+ * future.
+ *)
+ let rec st_in_mem st =
+ match st with
+ Il.ValTy _ -> false
+ | Il.AddrTy _ -> true
+
+ and rt_in_mem rt =
+ match rt with
+ Il.ScalarTy st -> st_in_mem st
+ | Il.StructTy rts
+ | Il.UnionTy rts -> List.exists rt_in_mem (Array.to_list rts)
+ | Il.OpaqueTy
+ | Il.ParamTy _
+ | Il.CodeTy -> true
+ | Il.NilTy -> false
+ in
+ rt_in_mem (slot_referent_type cx.ctxt_abi slot)
+ in
+
+ let rty_sz rty = Il.referent_ty_size cx.ctxt_abi.Abi.abi_word_bits rty in
+ let rty_layout rty =
+ Il.referent_ty_layout cx.ctxt_abi.Abi.abi_word_bits rty
+ in
+
+ let is_subword_size sz =
+ match sz with
+ SIZE_fixed i -> i64_le i cx.ctxt_abi.Abi.abi_word_sz
+ | _ -> false
+ in
+
+ let iflog thunk =
+ if cx.ctxt_sess.Session.sess_log_layout
+ then thunk ()
+ else ()
+ in
+
+ let layout_slot_ids
+ (slot_accum:slot_stack)
+ (upwards:bool)
+ (vregs_ok:bool)
+ (offset:size)
+ (slots:node_id array)
+ : unit =
+ let accum (off,align) id : (size * size) =
+ let slot = referent_to_slot cx id in
+ let rt = slot_referent_type cx.ctxt_abi slot in
+ let (elt_size, elt_align) = rty_layout rt in
+ if vregs_ok
+ && (is_subword_size elt_size)
+ && (not (type_is_structured (slot_ty slot)))
+ && (not (force_slot_to_mem slot))
+ && (not (Hashtbl.mem cx.ctxt_slot_aliased id))
+ then
+ begin
+ iflog
+ begin
+ fun _ ->
+ let k = Hashtbl.find cx.ctxt_slot_keys id in
+ log cx "assigning slot #%d = %a to vreg"
+ (int_of_node id)
+ Ast.sprintf_slot_key k;
+ end;
+ htab_put cx.ctxt_slot_vregs id (ref None);
+ (off,align)
+ end
+ else
+ begin
+ let elt_off = align_sz elt_align off in
+ let frame_off =
+ if upwards
+ then elt_off
+ else neg_sz (add_sz elt_off elt_size)
+ in
+ Stack.push (slot_referent_type cx.ctxt_abi slot) slot_accum;
+ iflog
+ begin
+ fun _ ->
+ let k = Hashtbl.find cx.ctxt_slot_keys id in
+ log cx "assigning slot #%d = %a frame-offset %s"
+ (int_of_node id)
+ Ast.sprintf_slot_key k
+ (string_of_size frame_off);
+ end;
+ if (not (Hashtbl.mem cx.ctxt_slot_offsets id))
+ then htab_put cx.ctxt_slot_offsets id frame_off;
+ (add_sz elt_off elt_size, max_sz elt_align align)
+ end
+ in
+ ignore (Array.fold_left accum (offset, SIZE_fixed 0L) slots)
+ in
+
+ let layout_block
+ (slot_accum:slot_stack)
+ (offset:size)
+ (block:Ast.block)
+ : unit =
+ log cx "laying out block #%d at fp offset %s"
+ (int_of_node block.id) (string_of_size offset);
+ let block_slot_ids =
+ Array.of_list (htab_vals (Hashtbl.find cx.ctxt_block_slots block.id))
+ in
+ layout_slot_ids slot_accum false true offset block_slot_ids
+ in
+
+ let layout_header (id:node_id) (input_slot_ids:node_id array) : unit =
+ let rty = direct_call_args_referent_type cx id in
+ let offset =
+ match rty with
+ Il.StructTy elts ->
+ (add_sz
+ (SIZE_fixed cx.ctxt_abi.Abi.abi_frame_base_sz)
+ (Il.get_element_offset
+ cx.ctxt_abi.Abi.abi_word_bits
+ elts Abi.calltup_elt_args))
+ | _ -> bug () "call tuple has non-StructTy"
+ in
+ log cx "laying out header for node #%d at fp offset %s"
+ (int_of_node id) (string_of_size offset);
+ layout_slot_ids (Stack.create()) true false offset input_slot_ids
+ in
+
+ let layout_obj_state (id:node_id) (state_slot_ids:node_id array) : unit =
+ let offset =
+ let word_sz = cx.ctxt_abi.Abi.abi_word_sz in
+ let word_n (n:int) = Int64.mul word_sz (Int64.of_int n) in
+ SIZE_fixed (word_n (Abi.exterior_rc_slot_field_body
+ + 1 (* the state tydesc. *)))
+ in
+ log cx "laying out object-state for node #%d at offset %s"
+ (int_of_node id) (string_of_size offset);
+ layout_slot_ids (Stack.create()) true false offset state_slot_ids
+ in
+
+ let (frame_stack:(node_id * frame_blocks) Stack.t) = Stack.create() in
+
+ let block_rty (block:slot_stack) : Il.referent_ty =
+ Il.StructTy (Array.of_list (stk_elts_from_bot block))
+ in
+
+ let frame_rty (frame:frame_blocks) : Il.referent_ty =
+ Il.StructTy (Array.of_list (List.map block_rty (stk_elts_from_bot frame)))
+ in
+
+ let update_frame_size _ =
+ let (frame_id, frame_blocks) = Stack.top frame_stack in
+ let frame_spill = Hashtbl.find cx.ctxt_spill_fixups frame_id in
+ let sz =
+ add_sz
+ (add_sz
+ (rty_sz (frame_rty frame_blocks))
+ (SIZE_fixup_mem_sz frame_spill))
+ (SIZE_fixed cx.ctxt_abi.Abi.abi_frame_info_sz)
+ in
+ let curr = Hashtbl.find cx.ctxt_frame_sizes frame_id in
+ let sz = max_sz curr sz in
+ log cx "extending frame #%d frame to size %s"
+ (int_of_node frame_id) (string_of_size sz);
+ Hashtbl.replace cx.ctxt_frame_sizes frame_id sz
+ in
+
+ (*
+ * FIXME: this is a little aggressive for default callsz; it can be
+ * narrowed in frames with no drop glue and/or no indirect drop glue.
+ *)
+
+ let glue_callsz =
+ let word = interior_slot Ast.TY_int in
+ let glue_fn =
+ mk_simple_ty_fn
+ (Array.init Abi.worst_case_glue_call_args (fun _ -> word))
+ in
+ rty_sz (indirect_call_args_referent_type cx 0 glue_fn Il.OpaqueTy)
+ in
+
+ let enter_frame id =
+ Stack.push (id, (Stack.create())) frame_stack;
+ htab_put cx.ctxt_frame_sizes id (SIZE_fixed 0L);
+ htab_put cx.ctxt_call_sizes id glue_callsz;
+ htab_put cx.ctxt_spill_fixups id (new_fixup "frame spill fixup");
+ htab_put cx.ctxt_frame_blocks id [];
+ update_frame_size ();
+ in
+
+ let leave_frame _ =
+ ignore (Stack.pop frame_stack);
+ in
+
+ let header_slot_ids hdr = Array.map (fun (sid,_) -> sid.id) hdr in
+
+ let visit_mod_item_pre n p i =
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ enter_frame i.id;
+ layout_header i.id
+ (header_slot_ids f.Ast.fn_input_slots)
+
+ | Ast.MOD_ITEM_tag (header_slots, _, _) ->
+ enter_frame i.id;
+ layout_header i.id
+ (Array.map (fun sid -> sid.id) header_slots)
+
+ | Ast.MOD_ITEM_obj obj ->
+ enter_frame i.id;
+ let ids = header_slot_ids obj.Ast.obj_state in
+ layout_obj_state i.id ids;
+ Array.iter
+ (fun id -> htab_put cx.ctxt_slot_is_obj_state id ())
+ ids
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn _
+ | Ast.MOD_ITEM_tag _
+ | Ast.MOD_ITEM_obj _ -> leave_frame ()
+ | _ -> ()
+ end
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ enter_frame fn.id;
+ layout_header fn.id
+ (header_slot_ids fn.node.Ast.fn_input_slots);
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_fn_post obj ident fn =
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ leave_frame ()
+ in
+
+ let visit_obj_drop_pre obj b =
+ enter_frame b.id;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_obj_drop_post obj b =
+ inner.Walk.visit_obj_drop_post obj b;
+ leave_frame ()
+ in
+
+ let visit_block_pre b =
+ if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+ then enter_frame b.id;
+ let (frame_id, frame_blocks) = Stack.top frame_stack in
+ let frame_spill = Hashtbl.find cx.ctxt_spill_fixups frame_id in
+ let spill_sz = SIZE_fixup_mem_sz frame_spill in
+ let info_sz = SIZE_fixed cx.ctxt_abi.Abi.abi_frame_info_sz in
+ let locals_off = add_sz spill_sz info_sz in
+ let off =
+ if Stack.is_empty frame_blocks
+ then locals_off
+ else
+ add_sz locals_off (rty_sz (frame_rty frame_blocks))
+ in
+ let block_slots = Stack.create() in
+ let frame_block_ids = Hashtbl.find cx.ctxt_frame_blocks frame_id in
+ Hashtbl.replace cx.ctxt_frame_blocks frame_id (b.id :: frame_block_ids);
+ layout_block block_slots off b;
+ Stack.push block_slots frame_blocks;
+ update_frame_size ();
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+ then leave_frame();
+ (* FIXME (issue #27): In earlier versions of this file, multiple
+ * lexical blocks in the same frame would reuse space from one to
+ * the next so long as they were not nested; The (commented-out)
+ * code here supports that logic. Unfortunately since our marking
+ * and unwinding strategy is very simplistic for now (analogous to
+ * shadow stacks) we're going to give each lexical block in a frame
+ * its own space in the frame, even if they seem like they *should*
+ * be able to reuse space. This makes it possible to arrive at the
+ * frame and work out which variables are live (and which frame
+ * memory corresponds to them) w/o paying attention to the current
+ * pc in the function; a greatly-simplifying assumption.
+ *
+ * This is of course not optimal for the long term, but in the
+ * longer term we'll have time to form proper DWARF CFI
+ * records. We're in a hurry at the moment. *)
+ (*
+ let stk = Stack.top block_stacks in
+ ignore (Stack.pop stk)
+ *)
+ in
+
+ let visit_stmt_pre (s:Ast.stmt) : unit =
+
+ (* Call-size calculation. *)
+ begin
+ let callees =
+ match s.node with
+ Ast.STMT_call (_, lv, _)
+ | Ast.STMT_spawn (_, _, lv, _) -> [| lv |]
+ | Ast.STMT_check (_, calls) -> Array.map (fun (lv, _) -> lv) calls
+ | _ -> [| |]
+ in
+ Array.iter
+ begin
+ fun (callee:Ast.lval) ->
+ let lv_ty = lval_ty cx callee in
+ let abi = cx.ctxt_abi in
+ let static = lval_is_static cx callee in
+ let closure = if static then None else Some Il.OpaqueTy in
+ let n_ty_params =
+ match resolve_lval cx callee with
+ DEFN_item i -> Array.length i.Ast.decl_params
+ | _ -> 0
+ in
+ let rty =
+ call_args_referent_type cx n_ty_params lv_ty closure
+ in
+ let sz = Il.referent_ty_size abi.Abi.abi_word_bits rty in
+ let frame_id = fst (Stack.top frame_stack) in
+ let curr = Hashtbl.find cx.ctxt_call_sizes frame_id in
+ log cx "extending frame #%d call size to %s"
+ (int_of_node frame_id) (string_of_size (max_sz curr sz));
+ Hashtbl.replace cx.ctxt_call_sizes frame_id (max_sz curr sz)
+ end
+ callees
+ end;
+ inner.Walk.visit_stmt_pre s
+ 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;
+
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (layout_visitor cx
+ Walk.empty_visitor)
+ |];
+ in
+ run_passes cx "layout" path passes (log cx "%s") crate
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/loop.ml b/src/boot/me/loop.ml
new file mode 100644
index 00000000..c23c4afd
--- /dev/null
+++ b/src/boot/me/loop.ml
@@ -0,0 +1,163 @@
+(*
+ * Computes iterator-loop nesting depths and max depth of each function.
+ *)
+
+open Semant;;
+open Common;;
+
+let log cx = Session.log "loop"
+ cx.ctxt_sess.Session.sess_log_loop
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+type fn_ctxt = { current_depth: int; }
+;;
+
+let incr_depth (fcx:fn_ctxt) =
+ { current_depth = fcx.current_depth + 1; }
+;;
+
+let decr_depth (fcx:fn_ctxt) =
+ { current_depth = fcx.current_depth - 1; }
+;;
+
+let top_fcx = { current_depth = 0; }
+;;
+
+let loop_depth_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let (fcxs : fn_ctxt Stack.t) = Stack.create () in
+
+ let push_loop () =
+ let fcx = Stack.pop fcxs in
+ Stack.push (incr_depth fcx) fcxs
+ in
+
+ let pop_loop () =
+ let fcx = Stack.pop fcxs in
+ Stack.push (decr_depth fcx) fcxs
+ in
+
+ let visit_mod_item_pre
+ (ident:Ast.ident)
+ (ty_params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ Stack.push top_fcx fcxs;
+ inner.Walk.visit_mod_item_pre ident ty_params item
+ in
+
+ let visit_mod_item_post
+ (ident:Ast.ident)
+ (ty_params:(Ast.ty_param identified) array)
+ (item:Ast.mod_item)
+ : unit =
+ inner.Walk.visit_mod_item_post ident ty_params item;
+ ignore (Stack.pop fcxs);
+ in
+
+ let visit_obj_fn_pre
+ (obj:Ast.obj identified)
+ (ident:Ast.ident)
+ (fn:Ast.fn identified)
+ : unit =
+ Stack.push top_fcx fcxs;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_fn_post
+ (obj:Ast.obj identified)
+ (ident:Ast.ident)
+ (fn:Ast.fn identified)
+ : unit =
+ inner.Walk.visit_obj_fn_pre obj ident fn;
+ ignore (Stack.pop fcxs)
+ in
+
+ let visit_obj_drop_pre
+ (obj:Ast.obj identified)
+ (b:Ast.block)
+ : unit =
+ Stack.push top_fcx fcxs;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_obj_drop_post
+ (obj:Ast.obj identified)
+ (b:Ast.block)
+ : unit =
+ inner.Walk.visit_obj_drop_post obj b;
+ ignore (Stack.pop fcxs)
+ in
+
+ let visit_slot_identified_pre sloti =
+ let fcx = Stack.top fcxs in
+ htab_put cx.ctxt_slot_loop_depths sloti.id fcx.current_depth;
+ inner.Walk.visit_slot_identified_pre sloti
+ in
+
+ let visit_stmt_pre s =
+ let fcx = Stack.top fcxs in
+ htab_put cx.ctxt_stmt_loop_depths s.id fcx.current_depth;
+ begin
+ match s.node with
+ | Ast.STMT_for_each fe ->
+ htab_put cx.ctxt_block_is_loop_body fe.Ast.for_each_body.id ();
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_block_pre b =
+ if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+ then push_loop ();
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ if Hashtbl.mem cx.ctxt_block_is_loop_body b.id
+ then pop_loop ()
+ 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;
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (loop_depth_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+
+ run_passes cx "loop" path passes (log cx "%s") crate;
+ ()
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml
new file mode 100644
index 00000000..8f034aee
--- /dev/null
+++ b/src/boot/me/resolve.ml
@@ -0,0 +1,959 @@
+open Semant;;
+open Common;;
+
+(*
+ * Resolution passes:
+ *
+ * - build multiple 'scope' hashtables mapping slot_key -> node_id
+ * - build single 'type inference' hashtable mapping node_id -> slot
+ *
+ * (note: not every slot is identified; only those that are declared
+ * in statements and/or can participate in local type inference.
+ * Those in function signatures are not, f.e. Also no type values
+ * are identified, though module items are. )
+ *
+ *)
+
+
+let log cx = Session.log "resolve"
+ cx.ctxt_sess.Session.sess_log_resolve
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_resolve
+ then thunk ()
+ else ()
+;;
+
+
+let block_scope_forming_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_block_pre b =
+ if not (Hashtbl.mem cx.ctxt_block_items b.id)
+ then htab_put cx.ctxt_block_items b.id (Hashtbl.create 0);
+ if not (Hashtbl.mem cx.ctxt_block_slots b.id)
+ then htab_put cx.ctxt_block_slots b.id (Hashtbl.create 0);
+ inner.Walk.visit_block_pre b
+ in
+ { inner with Walk.visit_block_pre = visit_block_pre }
+;;
+
+
+let stmt_collecting_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let block_ids = Stack.create () in
+ let visit_block_pre (b:Ast.block) =
+ Stack.push b.id block_ids;
+ inner.Walk.visit_block_pre b
+ in
+ let visit_block_post (b:Ast.block) =
+ inner.Walk.visit_block_post b;
+ ignore (Stack.pop block_ids)
+ in
+
+ let visit_for_block
+ ((si:Ast.slot identified),(ident:Ast.ident))
+ (block_id:node_id)
+ : unit =
+ let slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ let key = Ast.KEY_ident ident in
+ log cx "found decl of '%s' in for-loop block header" ident;
+ htab_put slots key si.id;
+ htab_put cx.ctxt_slot_keys si.id key
+ in
+
+ let visit_stmt_pre stmt =
+ begin
+ htab_put cx.ctxt_all_stmts stmt.id stmt;
+ match stmt.node with
+ Ast.STMT_decl d ->
+ begin
+ let bid = Stack.top block_ids in
+ let items = Hashtbl.find cx.ctxt_block_items bid in
+ let slots = Hashtbl.find cx.ctxt_block_slots bid in
+ let check_and_log_ident id ident =
+ if Hashtbl.mem items ident ||
+ Hashtbl.mem slots (Ast.KEY_ident ident)
+ then
+ err (Some id)
+ "duplicate declaration '%s' in block" ident
+ else
+ log cx "found decl of '%s' in block" ident
+ in
+ let check_and_log_tmp id tmp =
+ if Hashtbl.mem slots (Ast.KEY_temp tmp)
+ then
+ err (Some id)
+ "duplicate declaration of temp #%d in block"
+ (int_of_temp tmp)
+ else
+ log cx "found decl of temp #%d in block" (int_of_temp tmp)
+ in
+ let check_and_log_key id key =
+ match key with
+ Ast.KEY_ident i -> check_and_log_ident id i
+ | Ast.KEY_temp t -> check_and_log_tmp id t
+ in
+ match d with
+ Ast.DECL_mod_item (ident, item) ->
+ check_and_log_ident item.id ident;
+ htab_put items ident item.id
+ | Ast.DECL_slot (key, sid) ->
+ check_and_log_key sid.id key;
+ htab_put slots key sid.id;
+ htab_put cx.ctxt_slot_keys sid.id key
+ end
+ | Ast.STMT_for f ->
+ visit_for_block f.Ast.for_slot f.Ast.for_body.id
+ | Ast.STMT_for_each f ->
+ visit_for_block f.Ast.for_each_slot f.Ast.for_each_head.id
+ | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms } ->
+ let rec resolve_pat block pat =
+ match pat with
+ Ast.PAT_slot ({ id = slot_id }, ident) ->
+ let slots = Hashtbl.find cx.ctxt_block_slots block.id in
+ let key = Ast.KEY_ident ident in
+ htab_put slots key slot_id;
+ htab_put cx.ctxt_slot_keys slot_id key
+ | Ast.PAT_tag (_, pats) -> Array.iter (resolve_pat block) pats
+ | Ast.PAT_lit _ | Ast.PAT_wild -> ()
+ in
+ Array.iter (fun { node = (p, b) } -> resolve_pat b p) arms
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre stmt
+ in
+ { inner with
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+
+let all_item_collecting_visitor
+ (cx:ctxt)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let items = Stack.create () in
+
+ let push_on_item_arg_list item_id arg_id =
+ let existing =
+ match htab_search cx.ctxt_frame_args item_id with
+ None -> []
+ | Some x -> x
+ in
+ htab_put cx.ctxt_slot_is_arg arg_id ();
+ Hashtbl.replace cx.ctxt_frame_args item_id (arg_id :: existing)
+ in
+
+ let note_header item_id header =
+ Array.iter
+ (fun (sloti,ident) ->
+ let key = Ast.KEY_ident ident in
+ htab_put cx.ctxt_slot_keys sloti.id key;
+ push_on_item_arg_list item_id sloti.id)
+ header;
+ in
+
+ let visit_mod_item_pre n p i =
+ Stack.push i.id items;
+ 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);
+ log cx "collected item #%d: %s" (int_of_node i.id) n;
+ begin
+ (* FIXME: this is incomplete. *)
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ note_header i.id f.Ast.fn_input_slots;
+ | Ast.MOD_ITEM_obj ob ->
+ note_header i.id ob.Ast.obj_state;
+ | Ast.MOD_ITEM_tag (header_slots, _, _) ->
+ let skey i = Printf.sprintf "_%d" i in
+ note_header i.id
+ (Array.mapi (fun i s -> (s, skey i)) header_slots)
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ ignore (Stack.pop items)
+ in
+
+ 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);
+ 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);
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_for_each fe ->
+ let id = fe.Ast.for_each_body.id in
+ 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);
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s;
+ 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_drop_pre = visit_obj_drop_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre; }
+;;
+
+
+let lookup_type_node_by_name
+ (cx:ctxt)
+ (scopes:scope list)
+ (name:Ast.name)
+ : node_id =
+ iflog cx (fun _ ->
+ log cx "lookup_simple_type_by_name %a"
+ Ast.sprintf_name name);
+ match lookup_by_name cx scopes name with
+ None -> err None "unknown name: %a" Ast.sprintf_name name
+ | Some (_, id) ->
+ match htab_search cx.ctxt_all_defns id with
+ Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _ })
+ | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _ })
+ | Some (DEFN_ty_param _) -> id
+ | _ ->
+ err None "Found non-type binding for %a"
+ Ast.sprintf_name name
+;;
+
+
+let get_ty_references
+ (t:Ast.ty)
+ (cx:ctxt)
+ (scopes:scope list)
+ : node_id list =
+ let base = ty_fold_list_concat () in
+ let ty_fold_named n =
+ [ lookup_type_node_by_name cx scopes n ]
+ in
+ let fold = { base with ty_fold_named = ty_fold_named } in
+ fold_ty fold t
+;;
+
+
+let type_reference_and_tag_extracting_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (node_to_references:(node_id,node_id list) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_mod_item_pre id params item =
+ begin
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type ty ->
+ begin
+ log cx "extracting references for type node %d"
+ (int_of_node item.id);
+ let referenced = get_ty_references ty cx (!scopes) in
+ List.iter
+ (fun i -> log cx "type %d references type %d"
+ (int_of_node item.id) (int_of_node i)) referenced;
+ htab_put node_to_references item.id referenced;
+ match ty with
+ Ast.TY_tag ttag ->
+ htab_put all_tags item.id (ttag, (!scopes))
+ | _ -> ()
+ end
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre id params item
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre }
+;;
+
+
+type recur_info =
+ { recur_all_nodes: node_id list;
+ recur_curr_iso: (node_id array) option; }
+;;
+
+let empty_recur_info =
+ { recur_all_nodes = [];
+ recur_curr_iso = None }
+;;
+
+let push_node r n =
+ { r with recur_all_nodes = n :: r.recur_all_nodes }
+;;
+
+let set_iso r i =
+ { r with recur_curr_iso = Some i }
+;;
+
+
+let index_in_curr_iso (recur:recur_info) (node:node_id) : int option =
+ match recur.recur_curr_iso with
+ None -> None
+ | Some iso ->
+ let rec search i =
+ if i >= (Array.length iso)
+ then None
+ else
+ if iso.(i) = node
+ then Some i
+ else search (i+1)
+ in
+ search 0
+;;
+
+let need_ty_tag t =
+ match t with
+ Ast.TY_tag ttag -> ttag
+ | _ -> err None "needed ty_tag"
+;;
+
+
+let rec ty_iso_of
+ (cx:ctxt)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (n:node_id)
+ : Ast.ty =
+ let _ = iflog cx (fun _ -> log cx "+++ ty_iso_of #%d" (int_of_node n)) in
+ let group_table = Hashtbl.find recursive_tag_groups n in
+ let group_array = Array.of_list (htab_keys group_table) in
+ let compare_nodes a_id b_id =
+ (* FIXME: this should sort by the sorted name-lists of the
+ *constructors* of the tag, not the tag type name. *)
+ let a_name = Hashtbl.find cx.ctxt_all_item_names a_id in
+ let b_name = Hashtbl.find cx.ctxt_all_item_names b_id in
+ compare a_name b_name
+ in
+ let recur = set_iso (push_node empty_recur_info n) group_array in
+ let resolve_member member =
+ let (tag, scopes) = Hashtbl.find all_tags member in
+ let ty = Ast.TY_tag tag in
+ let ty = resolve_type cx scopes recursive_tag_groups all_tags recur ty in
+ need_ty_tag ty
+ in
+ Array.sort compare_nodes group_array;
+ log cx "resolving node %d, %d-member iso group"
+ (int_of_node n) (Array.length group_array);
+ Array.iteri (fun i n -> log cx "member %d: %d" i
+ (int_of_node n)) group_array;
+ let group = Array.map resolve_member group_array in
+ let rec search i =
+ if i >= (Array.length group_array)
+ then err None "node is not a member of its own iso group"
+ else
+ if group_array.(i) = n
+ then i
+ else search (i+1)
+ in
+ let iso =
+ Ast.TY_iso { Ast.iso_index = (search 0);
+ Ast.iso_group = group }
+ in
+ iflog cx (fun _ ->
+ log cx "--- ty_iso_of #%d ==> %a"
+ (int_of_node n) Ast.sprintf_ty iso);
+ iso
+
+
+and lookup_type_by_name
+ (cx:ctxt)
+ (scopes:scope list)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (recur:recur_info)
+ (name:Ast.name)
+ : ((scope list) * node_id * Ast.ty) =
+ iflog cx (fun _ ->
+ log cx "+++ lookup_type_by_name %a"
+ Ast.sprintf_name name);
+ match lookup_by_name cx scopes name with
+ None -> err None "unknown name: %a" Ast.sprintf_name name
+ | Some (scopes', id) ->
+ let ty, params =
+ match htab_search cx.ctxt_all_defns id with
+ Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type t;
+ Ast.decl_params = params }) ->
+ (t, Array.map (fun p -> p.node) params)
+ | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj ob;
+ Ast.decl_params = params }) ->
+ (Ast.TY_obj (ty_obj_of_obj ob),
+ Array.map (fun p -> p.node) params)
+ | Some (DEFN_ty_param (_, x)) ->
+ (Ast.TY_param x, [||])
+ | _ ->
+ err None "Found non-type binding for %a"
+ Ast.sprintf_name name
+ in
+ let args =
+ match name with
+ Ast.NAME_ext (_, Ast.COMP_app (_, args)) -> args
+ | Ast.NAME_base (Ast.BASE_app (_, args)) -> args
+ | _ -> [| |]
+ in
+ let args =
+ iflog cx (fun _ -> log cx
+ "lookup_type_by_name %a resolving %d type args"
+ Ast.sprintf_name name
+ (Array.length args));
+ Array.mapi
+ begin
+ fun i t ->
+ let t =
+ resolve_type cx scopes recursive_tag_groups
+ all_tags recur t
+ in
+ iflog cx (fun _ -> log cx
+ "lookup_type_by_name resolved arg %d to %a" i
+ Ast.sprintf_ty t);
+ t
+ end
+ args
+ in
+ iflog cx
+ begin
+ fun _ ->
+ log cx
+ "lookup_type_by_name %a found ty %a"
+ Ast.sprintf_name name Ast.sprintf_ty ty;
+ log cx "applying %d type args to %d params"
+ (Array.length args) (Array.length params);
+ log cx "params: %s"
+ (Ast.fmt_to_str Ast.fmt_decl_params params);
+ log cx "args: %s"
+ (Ast.fmt_to_str Ast.fmt_app_args args);
+ end;
+ let ty = rebuild_ty_under_params ty params args true in
+ iflog cx (fun _ -> log cx "--- lookup_type_by_name %a ==> %a"
+ Ast.sprintf_name name
+ Ast.sprintf_ty ty);
+ (scopes', id, ty)
+
+and resolve_type
+ (cx:ctxt)
+ (scopes:(scope list))
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (recur:recur_info)
+ (t:Ast.ty)
+ : Ast.ty =
+ let _ = iflog cx (fun _ -> log cx "+++ resolve_type %a" Ast.sprintf_ty t) in
+ let base = ty_fold_rebuild (fun t -> t) in
+ let ty_fold_named name =
+ let (scopes, node, t) =
+ lookup_type_by_name cx scopes recursive_tag_groups all_tags recur name
+ in
+ iflog cx (fun _ ->
+ log cx "resolved type name '%a' to item %d with ty %a"
+ Ast.sprintf_name name (int_of_node node) Ast.sprintf_ty t);
+ match index_in_curr_iso recur node with
+ Some i -> Ast.TY_idx i
+ | None ->
+ if Hashtbl.mem recursive_tag_groups node
+ then
+ begin
+ let ttag = need_ty_tag t in
+ Hashtbl.replace all_tags node (ttag, scopes);
+ ty_iso_of cx recursive_tag_groups all_tags node
+ end
+ else
+ if List.mem node recur.recur_all_nodes
+ then (err (Some node) "infinite recursive type definition: '%a'"
+ Ast.sprintf_name name)
+ else
+ let recur = push_node recur node in
+ iflog cx (fun _ -> log cx "recursively resolving type %a"
+ Ast.sprintf_ty t);
+ resolve_type cx scopes recursive_tag_groups all_tags recur t
+ in
+ let fold =
+ { base with
+ ty_fold_named = ty_fold_named; }
+ in
+ let t' = fold_ty fold t in
+ iflog cx (fun _ ->
+ log cx "--- resolve_type %a ==> %a"
+ Ast.sprintf_ty t Ast.sprintf_ty t');
+ t'
+;;
+
+
+let type_resolving_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let resolve_ty (t:Ast.ty) : Ast.ty =
+ resolve_type cx (!scopes) recursive_tag_groups all_tags empty_recur_info t
+ in
+
+ let resolve_slot (s:Ast.slot) : Ast.slot =
+ match s.Ast.slot_ty with
+ None -> s
+ | Some ty -> { s with Ast.slot_ty = Some (resolve_ty ty) }
+ in
+
+ let resolve_slot_identified
+ (s:Ast.slot identified)
+ : (Ast.slot identified) =
+ try
+ let slot = resolve_slot s.node in
+ { s with node = slot }
+ with
+ Semant_err (None, e) -> raise (Semant_err ((Some s.id), e))
+ in
+
+ let visit_slot_identified_pre slot =
+ let slot = resolve_slot_identified slot in
+ htab_put cx.ctxt_all_defns slot.id (DEFN_slot slot.node);
+ log cx "collected resolved slot #%d with type %s" (int_of_node slot.id)
+ (match slot.node.Ast.slot_ty with
+ None -> "??"
+ | Some t -> (Ast.fmt_to_str Ast.fmt_ty t));
+ inner.Walk.visit_slot_identified_pre slot
+ in
+
+ let visit_mod_item_pre id params item =
+ begin
+ try
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type ty ->
+ let ty =
+ resolve_type cx (!scopes) recursive_tag_groups
+ all_tags empty_recur_info ty
+ in
+ log cx "resolved item %s, defining type %a"
+ id Ast.sprintf_ty ty;
+ htab_put cx.ctxt_all_type_items item.id ty;
+ htab_put cx.ctxt_all_item_types item.id Ast.TY_type
+
+ (*
+ * Don't resolve the "type" of a mod item; just resolve its
+ * members.
+ *)
+ | Ast.MOD_ITEM_mod _ -> ()
+
+ | Ast.MOD_ITEM_tag (header_slots, _, nid)
+ when Hashtbl.mem recursive_tag_groups nid ->
+ begin
+ match ty_of_mod_item true item with
+ Ast.TY_fn (tsig, taux) ->
+ let input_slots =
+ Array.map
+ (fun sloti -> resolve_slot sloti.node)
+ header_slots
+ in
+ let output_slot =
+ interior_slot (ty_iso_of cx recursive_tag_groups
+ all_tags nid)
+ in
+ let ty =
+ Ast.TY_fn
+ ({tsig with
+ Ast.sig_input_slots = input_slots;
+ Ast.sig_output_slot = output_slot }, taux)
+ in
+ log cx "resolved recursive tag %s, type as %a"
+ id Ast.sprintf_ty ty;
+ htab_put cx.ctxt_all_item_types item.id ty
+ | _ -> bug () "recursive tag with non-function type"
+ end
+
+ | _ ->
+ let t = ty_of_mod_item true item in
+ let ty =
+ resolve_type cx (!scopes) recursive_tag_groups
+ all_tags empty_recur_info t
+ in
+ log cx "resolved item %s, type as %a" id Ast.sprintf_ty ty;
+ htab_put cx.ctxt_all_item_types item.id ty;
+ with
+ Semant_err (None, e) -> raise (Semant_err ((Some item.id), e))
+ end;
+ inner.Walk.visit_mod_item_pre id params item
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ let fty =
+ resolve_type cx (!scopes) recursive_tag_groups all_tags
+ empty_recur_info (Ast.TY_fn (ty_fn_of_fn fn.node))
+ in
+ log cx "resolved obj fn %s as %a" ident Ast.sprintf_ty fty;
+ htab_put cx.ctxt_all_item_types fn.id fty;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_drop_pre obj b =
+ let fty = mk_simple_ty_fn [| |] in
+ htab_put cx.ctxt_all_item_types b.id fty;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_stmt_pre stmt =
+ begin
+ match stmt.node with
+ Ast.STMT_for_each fe ->
+ let id = fe.Ast.for_each_body.id in
+ let fty = mk_simple_ty_iter [| |] in
+ htab_put cx.ctxt_all_item_types id fty;
+ | Ast.STMT_copy (_, Ast.EXPR_unary (Ast.UNOP_cast t, _)) ->
+ let ty = resolve_ty t.node in
+ htab_put cx.ctxt_all_cast_types t.id ty
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre stmt
+ in
+
+ let visit_lval_pre lv =
+ let rec rebuild_lval' lv =
+ match lv with
+ Ast.LVAL_ext (base, ext) ->
+ let ext =
+ match ext with
+ Ast.COMP_named (Ast.COMP_ident _)
+ | Ast.COMP_named (Ast.COMP_idx _)
+ | Ast.COMP_atom (Ast.ATOM_literal _) -> ext
+ | Ast.COMP_atom (Ast.ATOM_lval lv) ->
+ Ast.COMP_atom (Ast.ATOM_lval (rebuild_lval lv))
+ | Ast.COMP_named (Ast.COMP_app (ident, params)) ->
+ Ast.COMP_named
+ (Ast.COMP_app (ident, Array.map resolve_ty params))
+ in
+ Ast.LVAL_ext (rebuild_lval' base, ext)
+
+ | Ast.LVAL_base nb ->
+ let node =
+ match nb.node with
+ Ast.BASE_ident _
+ | Ast.BASE_temp _ -> nb.node
+ | Ast.BASE_app (ident, params) ->
+ Ast.BASE_app (ident, Array.map resolve_ty params)
+ in
+ Ast.LVAL_base {nb with node = node}
+
+ and rebuild_lval lv =
+ let id = lval_base_id lv in
+ let lv' = rebuild_lval' lv in
+ iflog cx (fun _ -> log cx "rebuilt lval %a as %a (#%d)"
+ Ast.sprintf_lval lv Ast.sprintf_lval lv'
+ (int_of_node id));
+ htab_put cx.ctxt_all_lvals id lv';
+ lv'
+ in
+ ignore (rebuild_lval lv);
+ inner.Walk.visit_lval_pre lv
+ in
+
+ { inner with
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+ Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_lval_pre = visit_lval_pre; }
+;;
+
+
+let lval_base_resolving_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let lookup_referent_by_ident id ident =
+ log cx "looking up slot or item with ident '%s'" ident;
+ match lookup cx (!scopes) (Ast.KEY_ident ident) with
+ None -> err (Some id) "unresolved identifier '%s'" ident
+ | Some (_, id) -> (log cx "resolved to node id #%d"
+ (int_of_node id); id)
+ in
+ let lookup_slot_by_temp id temp =
+ log cx "looking up temp slot #%d" (int_of_temp temp);
+ let res = lookup cx (!scopes) (Ast.KEY_temp temp) in
+ match res with
+ None -> err
+ (Some id) "unresolved temp node #%d" (int_of_temp temp)
+ | Some (_, id) ->
+ (log cx "resolved to node id #%d" (int_of_node id); id)
+ in
+ let lookup_referent_by_name_base id nb =
+ match nb with
+ Ast.BASE_ident ident
+ | Ast.BASE_app (ident, _) -> lookup_referent_by_ident id ident
+ | Ast.BASE_temp temp -> lookup_slot_by_temp id temp
+ in
+
+ let visit_lval_pre lv =
+ let rec lookup_lval lv =
+ iflog cx (fun _ ->
+ log cx "looking up lval #%d"
+ (int_of_node (lval_base_id lv)));
+ match lv with
+ Ast.LVAL_ext (base, ext) ->
+ begin
+ lookup_lval base;
+ match ext with
+ Ast.COMP_atom (Ast.ATOM_lval lv') -> lookup_lval lv'
+ | _ -> ()
+ end
+ | Ast.LVAL_base nb ->
+ let referent_id = lookup_referent_by_name_base nb.id nb.node in
+ iflog cx (fun _ -> log cx "resolved lval #%d to referent #%d"
+ (int_of_node nb.id) (int_of_node referent_id));
+ htab_put cx.ctxt_lval_to_referent nb.id referent_id
+ in
+ lookup_lval lv;
+ inner.Walk.visit_lval_pre lv
+ in
+ { inner with
+ Walk.visit_lval_pre = visit_lval_pre }
+;;
+
+
+
+(*
+ * iso-recursion groups are very complicated.
+ *
+ * - iso groups are always rooted at *named* ty_tag nodes
+ *
+ * - consider:
+ *
+ * type colour = tag(red, green, blue);
+ * type list = tag(cons(colour, @list), nil())
+ *
+ * this should include list as an iso but not colour,
+ * should result in:
+ *
+ * type list = iso[<0>:tag(cons(tag(red,green,blue),@#1))]
+ *
+ * - consider:
+ *
+ * type colour = tag(red, green, blue);
+ * type tree = tag(children(@list), leaf(colour))
+ * type list = tag(cons(@tree, @list), nil())
+ *
+ * this should result in:
+ *
+ * type list = iso[<0>:tag(cons(@#2, @#1),nil());
+ * 1: tag(children(@#1),leaf(tag(red,green,blue)))]
+ *
+ * - how can you calculate these?
+ *
+ * - start by making a map from named-tag-node-id -> referenced-other-nodes
+ * - for each member in the set, if you can get from itself to itself, keep
+ * it, otherwise it's non-recursive => non-interesting, delete it.
+ * - group the members (now all recursive) by dependency
+ * - assign index-number to each elt of group
+ * - fully resolve each elt of group, turning names into numbers or chasing
+ * through to fully-resolving targets as necessary
+ * - place group in iso, store differently-indexed value in table for each
+ *
+ *
+ * - what are the illegal forms?
+ * - recursion that takes indefinite storage to form a tag, eg.
+ *
+ * type t = tag(foo(t));
+ *
+ * - recursion that makes a tag unconstructable, eg:
+ *
+ * type t = tag(foo(@t));
+ *)
+
+let resolve_recursion
+ (cx:ctxt)
+ (node_to_references:(node_id,node_id list) Hashtbl.t)
+ (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
+ : unit =
+
+ let recursive_tag_types = Hashtbl.create 0 in
+
+ let rec can_reach
+ (target:node_id)
+ (visited:node_id list)
+ (curr:node_id)
+ : bool =
+ if List.mem curr visited
+ then false
+ else
+ match htab_search node_to_references curr with
+ None -> false
+ | Some referenced ->
+ if List.mem target referenced
+ then true
+ else List.exists (can_reach target (curr :: visited)) referenced
+ in
+
+ let extract_recursive_tags _ =
+ Hashtbl.iter
+ begin fun id _ ->
+ if can_reach id [] id
+ then begin
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item
+ { Ast.decl_item = Ast.MOD_ITEM_type (Ast.TY_tag _) } ->
+ log cx "type %d is a recursive tag" (int_of_node id);
+ Hashtbl.replace recursive_tag_types id ()
+ | _ ->
+ log cx "type %d is recursive, but not a tag" (int_of_node id);
+ end
+ else log cx "type %d is non-recursive" (int_of_node id);
+ end
+ node_to_references
+ in
+
+ let group_recursive_tags _ =
+ while (Hashtbl.length recursive_tag_types) != 0 do
+ let keys = htab_keys recursive_tag_types in
+ let root = List.hd keys in
+ let group = Hashtbl.create 0 in
+ let rec walk visited node =
+ if List.mem node visited
+ then ()
+ else
+ begin
+ if Hashtbl.mem recursive_tag_types node
+ then
+ begin
+ Hashtbl.remove recursive_tag_types node;
+ htab_put recursive_tag_groups node group;
+ htab_put group node ();
+ log cx "recursion group rooted at tag %d contains tag %d"
+ (int_of_node root) (int_of_node node);
+ end;
+ match htab_search node_to_references node with
+ None -> ()
+ | Some referenced ->
+ List.iter (walk (node :: visited)) referenced
+ end
+ in
+ walk [] root;
+ done
+ in
+
+ begin
+ extract_recursive_tags ();
+ group_recursive_tags ();
+ log cx "found %d independent type-recursion groups"
+ (Hashtbl.length recursive_tag_groups);
+ end
+;;
+
+let pattern_resolving_visitor
+ (cx:ctxt)
+ (scopes:scope list ref)
+ (inner:Walk.visitor) : Walk.visitor =
+ let visit_stmt_pre stmt =
+ begin
+ match stmt.node with
+ Ast.STMT_alt_tag { Ast.alt_tag_lval = _; Ast.alt_tag_arms = arms } ->
+ let resolve_arm { node = arm } =
+ match fst arm with
+ Ast.PAT_tag (ident, _) ->
+ begin
+ match lookup_by_ident cx !scopes ident with
+ None ->
+ err None "unresolved tag constructor '%s'" ident
+ | Some (_, tag_id) ->
+ match Hashtbl.find cx.ctxt_all_defns tag_id with
+ DEFN_item {
+ Ast.decl_item = Ast.MOD_ITEM_tag _
+ } -> ()
+ | _ ->
+ err None "'%s' is not a tag constructor" ident
+ end
+ | _ -> ()
+
+ in
+ Array.iter resolve_arm arms
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre stmt
+ in
+ { inner with Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let (scopes:(scope list) ref) = ref [] in
+ let path = Stack.create () in
+
+ let node_to_references = Hashtbl.create 0 in
+ let all_tags = Hashtbl.create 0 in
+ let recursive_tag_groups = Hashtbl.create 0 in
+
+ let passes_0 =
+ [|
+ (block_scope_forming_visitor cx Walk.empty_visitor);
+ (stmt_collecting_visitor cx
+ (all_item_collecting_visitor cx path
+ Walk.empty_visitor));
+ (scope_stack_managing_visitor scopes
+ (type_reference_and_tag_extracting_visitor
+ cx scopes node_to_references all_tags
+ Walk.empty_visitor))
+ |]
+ in
+ let passes_1 =
+ [|
+ (scope_stack_managing_visitor scopes
+ (type_resolving_visitor cx scopes
+ recursive_tag_groups all_tags
+ (lval_base_resolving_visitor cx scopes
+ Walk.empty_visitor)));
+ |]
+ in
+ let passes_2 =
+ [|
+ (scope_stack_managing_visitor scopes
+ (pattern_resolving_visitor cx scopes
+ Walk.empty_visitor))
+ |]
+ in
+ log cx "running primary resolve passes";
+ run_passes cx "resolve collect" path passes_0 (log cx "%s") 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;
+ log cx "running tertiary resolve passes";
+ run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
new file mode 100644
index 00000000..b5000ff3
--- /dev/null
+++ b/src/boot/me/semant.ml
@@ -0,0 +1,1969 @@
+
+open Common;;
+
+type slots_table = (Ast.slot_key,node_id) Hashtbl.t
+type items_table = (Ast.ident,node_id) Hashtbl.t
+type block_slots_table = (node_id,slots_table) Hashtbl.t
+type block_items_table = (node_id,items_table) Hashtbl.t
+;;
+
+
+type code = {
+ code_fixup: fixup;
+ code_quads: Il.quads;
+ code_vregs_and_spill: (int * fixup) option;
+}
+;;
+
+type glue =
+ GLUE_activate
+ | GLUE_yield
+ | GLUE_exit_main_task
+ | GLUE_exit_task
+ | GLUE_mark of Ast.ty
+ | GLUE_drop of Ast.ty
+ | GLUE_free of Ast.ty
+ | GLUE_copy of Ast.ty (* One-level copy. *)
+ | GLUE_clone of Ast.ty (* Deep copy. *)
+ | GLUE_compare of Ast.ty
+ | GLUE_hash of Ast.ty
+ | GLUE_write of Ast.ty
+ | GLUE_read of Ast.ty
+ | GLUE_unwind
+ | GLUE_get_next_pc
+ | 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_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)
+;;
+
+type data =
+ DATA_str of string
+ | DATA_name of Ast.name
+ | DATA_tydesc of Ast.ty
+ | DATA_frame_glue_fns of node_id
+ | DATA_obj_vtbl of node_id
+ | DATA_forwarding_vtbl of (Ast.ty_obj * Ast.ty_obj)
+ | DATA_crate
+;;
+
+type defn =
+ DEFN_slot of Ast.slot
+ | DEFN_item of Ast.mod_item_decl
+ | DEFN_ty_param of Ast.ty_param
+ | DEFN_obj_fn of (node_id * Ast.fn)
+ | DEFN_obj_drop of node_id
+ | DEFN_loop_body of node_id
+;;
+
+type glue_code = (glue, code) Hashtbl.t;;
+type item_code = (node_id, code) Hashtbl.t;;
+type file_code = (node_id, item_code) Hashtbl.t;;
+type data_frags = (data, (fixup * Asm.frag)) Hashtbl.t;;
+
+let string_of_name (n:Ast.name) : string =
+ Ast.fmt_to_str Ast.fmt_name n
+;;
+
+(* The only need for a carg is to uniquely identify a constraint-arg
+ * in a scope-independent fashion. So we just look up the node that's
+ * used as the base of any such arg and glue it on the front of the
+ * symbolic name.
+ *)
+
+type constr_key_arg = Constr_arg_node of (node_id * Ast.carg_path)
+ | Constr_arg_lit of Ast.lit
+type constr_key =
+ Constr_pred of (node_id * constr_key_arg array)
+ | Constr_init of node_id
+
+type ctxt =
+ { ctxt_sess: Session.sess;
+ ctxt_frame_args: (node_id,node_id list) Hashtbl.t;
+ ctxt_frame_blocks: (node_id,node_id list) Hashtbl.t;
+ ctxt_block_slots: block_slots_table;
+ ctxt_block_items: block_items_table;
+ ctxt_slot_is_arg: (node_id,unit) Hashtbl.t;
+ ctxt_slot_keys: (node_id,Ast.slot_key) Hashtbl.t;
+ ctxt_all_item_names: (node_id,Ast.name) Hashtbl.t;
+ ctxt_all_item_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_lval_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_cast_types: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_type_items: (node_id,Ast.ty) Hashtbl.t;
+ ctxt_all_stmts: (node_id,Ast.stmt) Hashtbl.t;
+ ctxt_item_files: (node_id,filename) Hashtbl.t;
+ ctxt_all_lvals: (node_id,Ast.lval) Hashtbl.t;
+
+ (* definition id --> definition *)
+ ctxt_all_defns: (node_id,defn) Hashtbl.t;
+
+ (* reference id --> definition id *)
+ ctxt_lval_to_referent: (node_id,node_id) Hashtbl.t;
+
+ ctxt_required_items: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
+ ctxt_required_syms: (node_id, string) Hashtbl.t;
+
+ (* Layout-y stuff. *)
+ ctxt_slot_aliased: (node_id,unit) Hashtbl.t;
+ ctxt_slot_is_obj_state: (node_id,unit) Hashtbl.t;
+ ctxt_slot_vregs: (node_id,((int option) ref)) Hashtbl.t;
+ ctxt_slot_offsets: (node_id,size) Hashtbl.t;
+ ctxt_frame_sizes: (node_id,size) Hashtbl.t;
+ ctxt_call_sizes: (node_id,size) Hashtbl.t;
+ ctxt_block_is_loop_body: (node_id,unit) Hashtbl.t;
+ ctxt_stmt_loop_depths: (node_id,int) Hashtbl.t;
+ ctxt_slot_loop_depths: (node_id,int) Hashtbl.t;
+
+ (* Typestate-y stuff. *)
+ ctxt_constrs: (constr_id,constr_key) Hashtbl.t;
+ ctxt_constr_ids: (constr_key,constr_id) Hashtbl.t;
+ ctxt_preconditions: (node_id,Bits.t) Hashtbl.t;
+ ctxt_postconditions: (node_id,Bits.t) Hashtbl.t;
+ ctxt_prestates: (node_id,Bits.t) Hashtbl.t;
+ ctxt_poststates: (node_id,Bits.t) Hashtbl.t;
+ ctxt_call_lval_params: (node_id,Ast.ty array) Hashtbl.t;
+ ctxt_copy_stmt_is_init: (node_id,unit) Hashtbl.t;
+ ctxt_post_stmt_slot_drops: (node_id,node_id list) Hashtbl.t;
+
+ (* Translation-y stuff. *)
+ ctxt_fn_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_block_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_file_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_spill_fixups: (node_id,fixup) Hashtbl.t;
+ ctxt_abi: Abi.abi;
+ ctxt_activate_fixup: fixup;
+ ctxt_yield_fixup: fixup;
+ ctxt_unwind_fixup: fixup;
+ ctxt_exit_task_fixup: fixup;
+
+ ctxt_debug_aranges_fixup: fixup;
+ ctxt_debug_pubnames_fixup: fixup;
+ ctxt_debug_info_fixup: fixup;
+ ctxt_debug_abbrev_fixup: fixup;
+ ctxt_debug_line_fixup: fixup;
+ ctxt_debug_frame_fixup: fixup;
+
+ ctxt_image_base_fixup: fixup;
+ ctxt_crate_fixup: fixup;
+
+ ctxt_file_code: file_code;
+ ctxt_all_item_code: item_code;
+ ctxt_glue_code: glue_code;
+ ctxt_data: data_frags;
+
+ ctxt_native_required:
+ (required_lib,((string,fixup) Hashtbl.t)) Hashtbl.t;
+ ctxt_native_provided:
+ (segment,((string, fixup) Hashtbl.t)) Hashtbl.t;
+
+ ctxt_required_rust_sym_num: (node_id, int) Hashtbl.t;
+ ctxt_required_c_sym_num: ((required_lib * string), int) Hashtbl.t;
+ ctxt_required_lib_num: (required_lib, int) Hashtbl.t;
+
+ ctxt_main_fn_fixup: fixup option;
+ ctxt_main_name: string option;
+ }
+;;
+
+let new_ctxt sess abi crate =
+ { ctxt_sess = sess;
+ ctxt_frame_args = Hashtbl.create 0;
+ ctxt_frame_blocks = Hashtbl.create 0;
+ ctxt_block_slots = Hashtbl.create 0;
+ ctxt_block_items = Hashtbl.create 0;
+ ctxt_slot_is_arg = Hashtbl.create 0;
+ ctxt_slot_keys = Hashtbl.create 0;
+ ctxt_all_item_names = Hashtbl.create 0;
+ ctxt_all_item_types = Hashtbl.create 0;
+ ctxt_all_lval_types = Hashtbl.create 0;
+ ctxt_all_cast_types = Hashtbl.create 0;
+ ctxt_all_type_items = Hashtbl.create 0;
+ ctxt_all_stmts = Hashtbl.create 0;
+ ctxt_item_files = crate.Ast.crate_files;
+ ctxt_all_lvals = Hashtbl.create 0;
+ ctxt_all_defns = Hashtbl.create 0;
+ ctxt_lval_to_referent = Hashtbl.create 0;
+ ctxt_required_items = crate.Ast.crate_required;
+ ctxt_required_syms = crate.Ast.crate_required_syms;
+
+ ctxt_constrs = Hashtbl.create 0;
+ ctxt_constr_ids = Hashtbl.create 0;
+ ctxt_preconditions = Hashtbl.create 0;
+ ctxt_postconditions = Hashtbl.create 0;
+ ctxt_prestates = Hashtbl.create 0;
+ ctxt_poststates = Hashtbl.create 0;
+ ctxt_copy_stmt_is_init = Hashtbl.create 0;
+ ctxt_post_stmt_slot_drops = Hashtbl.create 0;
+ ctxt_call_lval_params = Hashtbl.create 0;
+
+ ctxt_slot_aliased = Hashtbl.create 0;
+ ctxt_slot_is_obj_state = Hashtbl.create 0;
+ ctxt_slot_vregs = Hashtbl.create 0;
+ ctxt_slot_offsets = Hashtbl.create 0;
+ ctxt_frame_sizes = Hashtbl.create 0;
+ ctxt_call_sizes = Hashtbl.create 0;
+
+ ctxt_block_is_loop_body = Hashtbl.create 0;
+ ctxt_slot_loop_depths = Hashtbl.create 0;
+ ctxt_stmt_loop_depths = Hashtbl.create 0;
+
+ ctxt_fn_fixups = Hashtbl.create 0;
+ ctxt_block_fixups = Hashtbl.create 0;
+ ctxt_file_fixups = Hashtbl.create 0;
+ ctxt_spill_fixups = Hashtbl.create 0;
+ ctxt_abi = abi;
+ ctxt_activate_fixup = new_fixup "activate glue";
+ ctxt_yield_fixup = new_fixup "yield glue";
+ ctxt_unwind_fixup = new_fixup "unwind glue";
+ ctxt_exit_task_fixup = new_fixup "exit-task glue";
+
+ ctxt_debug_aranges_fixup = new_fixup "debug_aranges section";
+ ctxt_debug_pubnames_fixup = new_fixup "debug_pubnames section";
+ ctxt_debug_info_fixup = new_fixup "debug_info section";
+ ctxt_debug_abbrev_fixup = new_fixup "debug_abbrev section";
+ ctxt_debug_line_fixup = new_fixup "debug_line section";
+ ctxt_debug_frame_fixup = new_fixup "debug_frame section";
+
+ ctxt_image_base_fixup = new_fixup "loaded image base";
+ ctxt_crate_fixup = new_fixup "root crate structure";
+ ctxt_file_code = Hashtbl.create 0;
+ ctxt_all_item_code = Hashtbl.create 0;
+ ctxt_glue_code = Hashtbl.create 0;
+ ctxt_data = Hashtbl.create 0;
+
+ ctxt_native_required = Hashtbl.create 0;
+ ctxt_native_provided = Hashtbl.create 0;
+
+ ctxt_required_rust_sym_num = Hashtbl.create 0;
+ ctxt_required_c_sym_num = Hashtbl.create 0;
+ ctxt_required_lib_num = Hashtbl.create 0;
+
+ ctxt_main_fn_fixup =
+ (match crate.Ast.crate_main with
+ None -> None
+ | Some n -> Some (new_fixup (string_of_name n)));
+
+ ctxt_main_name =
+ (match crate.Ast.crate_main with
+ None -> None
+ | Some n -> Some (string_of_name n));
+ }
+;;
+
+let report_err cx ido str =
+ let sess = cx.ctxt_sess in
+ let spano = match ido with
+ None -> None
+ | Some id -> (Session.get_span sess id)
+ in
+ match spano with
+ None ->
+ Session.fail sess "Error: %s\n%!" str
+ | Some span ->
+ Session.fail sess "%s:E:Error: %s\n%!"
+ (Session.string_of_span span) str
+;;
+
+let bugi (cx:ctxt) (i:node_id) =
+ let k s =
+ report_err cx (Some i) s;
+ failwith s
+ in Printf.ksprintf k
+;;
+
+(* Convenience accessors. *)
+
+(* resolve an lval reference id to the id of its definition *)
+let lval_to_referent (cx:ctxt) (id:node_id) : node_id =
+ if Hashtbl.mem cx.ctxt_lval_to_referent id
+ then Hashtbl.find cx.ctxt_lval_to_referent id
+ else bug () "unresolved lval"
+;;
+
+(* resolve an lval reference id to its definition *)
+let resolve_lval_id (cx:ctxt) (id:node_id) : defn =
+ Hashtbl.find cx.ctxt_all_defns (lval_to_referent cx id)
+;;
+
+let referent_is_slot (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let referent_is_item (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+(* coerce an lval definition id to a slot *)
+let referent_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_slot slot -> slot
+ | _ -> bugi cx id "unknown slot"
+;;
+
+(* coerce an lval reference id to its definition slot *)
+let lval_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
+ match resolve_lval_id cx id with
+ DEFN_slot slot -> slot
+ | _ -> bugi cx id "unknown slot"
+;;
+
+let get_stmt_depth (cx:ctxt) (id:node_id) : int =
+ Hashtbl.find cx.ctxt_stmt_loop_depths id
+;;
+
+let get_slot_depth (cx:ctxt) (id:node_id) : int =
+ Hashtbl.find cx.ctxt_slot_loop_depths id
+;;
+
+let get_fn_fixup (cx:ctxt) (id:node_id) : fixup =
+ if Hashtbl.mem cx.ctxt_fn_fixups id
+ then Hashtbl.find cx.ctxt_fn_fixups id
+ else bugi cx id "fn without fixup"
+;;
+
+let get_framesz (cx:ctxt) (id:node_id) : size =
+ if Hashtbl.mem cx.ctxt_frame_sizes id
+ then Hashtbl.find cx.ctxt_frame_sizes id
+ else bugi cx id "missing framesz"
+;;
+
+let get_callsz (cx:ctxt) (id:node_id) : size =
+ if Hashtbl.mem cx.ctxt_call_sizes id
+ then Hashtbl.find cx.ctxt_call_sizes id
+ else bugi cx id "missing callsz"
+;;
+
+let rec n_item_ty_params (cx:ctxt) (id:node_id) : int =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item i -> Array.length i.Ast.decl_params
+ | DEFN_obj_fn (oid,_) -> n_item_ty_params cx oid
+ | DEFN_obj_drop oid -> n_item_ty_params cx oid
+ | DEFN_loop_body fid -> n_item_ty_params cx fid
+ | _ -> bugi cx id "n_item_ty_params on non-item"
+;;
+
+let item_is_obj_fn (cx:ctxt) (id:node_id) : bool =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_obj_fn _
+ | DEFN_obj_drop _ -> true
+ | _ -> false
+;;
+
+let get_spill (cx:ctxt) (id:node_id) : fixup =
+ if Hashtbl.mem cx.ctxt_spill_fixups id
+ then Hashtbl.find cx.ctxt_spill_fixups id
+ else bugi cx id "missing spill fixup"
+;;
+
+let require_native (cx:ctxt) (lib:required_lib) (name:string) : fixup =
+ let lib_tab = (htab_search_or_add cx.ctxt_native_required lib
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_search_or_add lib_tab name
+ (fun _ -> new_fixup ("require: " ^ name))
+;;
+
+let provide_native (cx:ctxt) (seg:segment) (name:string) : fixup =
+ let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_search_or_add seg_tab name
+ (fun _ -> new_fixup ("provide: " ^ name))
+;;
+
+let provide_existing_native
+ (cx:ctxt)
+ (seg:segment)
+ (name:string)
+ (fix:fixup)
+ : unit =
+ let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
+ (fun _ -> Hashtbl.create 0))
+ in
+ htab_put seg_tab name fix
+;;
+
+let slot_ty (s:Ast.slot) : Ast.ty =
+ match s.Ast.slot_ty with
+ Some t -> t
+ | None -> bug () "untyped slot"
+;;
+
+let defn_is_slot (d:defn) : bool =
+ match d with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let defn_is_item (d:defn) : bool =
+ match d with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+let slot_is_obj_state (cx:ctxt) (sid:node_id) : bool =
+ Hashtbl.mem cx.ctxt_slot_is_obj_state sid
+;;
+
+
+(* determines whether d defines a statically-known value *)
+let defn_is_static (d:defn) : bool =
+ not (defn_is_slot d)
+;;
+
+let defn_is_callable (d:defn) : bool =
+ match d with
+ DEFN_slot { Ast.slot_ty = Some Ast.TY_fn _ }
+ | DEFN_item { Ast.decl_item = (Ast.MOD_ITEM_fn _ ) } -> true
+ | _ -> false
+;;
+
+(* Constraint manipulation. *)
+
+let rec apply_names_to_carg_path
+ (names:(Ast.name_base option) array)
+ (cp:Ast.carg_path)
+ : Ast.carg_path =
+ match cp with
+ Ast.CARG_ext (Ast.CARG_base Ast.BASE_formal,
+ Ast.COMP_idx i) ->
+ begin
+ match names.(i) with
+ Some nb ->
+ Ast.CARG_base (Ast.BASE_named nb)
+ | None -> bug () "Indexing off non-named carg"
+ end
+ | Ast.CARG_ext (cp', e) ->
+ Ast.CARG_ext (apply_names_to_carg_path names cp', e)
+ | _ -> cp
+;;
+
+let apply_names_to_carg
+ (names:(Ast.name_base option) array)
+ (carg:Ast.carg)
+ : Ast.carg =
+ match carg with
+ Ast.CARG_path cp ->
+ Ast.CARG_path (apply_names_to_carg_path names cp)
+ | Ast.CARG_lit _ -> carg
+;;
+
+let apply_names_to_constr
+ (names:(Ast.name_base option) array)
+ (constr:Ast.constr)
+ : Ast.constr =
+ { constr with
+ Ast.constr_args =
+ Array.map (apply_names_to_carg names) constr.Ast.constr_args }
+;;
+
+let atoms_to_names (atoms:Ast.atom array)
+ : (Ast.name_base option) array =
+ Array.map
+ begin
+ fun atom ->
+ match atom with
+ Ast.ATOM_lval (Ast.LVAL_base nbi) -> Some nbi.node
+ | _ -> None
+ end
+ atoms
+;;
+
+let rec lval_base_id (lv:Ast.lval) : node_id =
+ match lv with
+ Ast.LVAL_base nbi -> nbi.id
+ | Ast.LVAL_ext (lv, _) -> lval_base_id lv
+;;
+
+let rec lval_base_slot (cx:ctxt) (lv:Ast.lval) : node_id option =
+ match lv with
+ Ast.LVAL_base nbi ->
+ let referent = lval_to_referent cx nbi.id in
+ if referent_is_slot cx referent
+ then Some referent
+ else None
+ | Ast.LVAL_ext (lv, _) -> lval_base_slot cx lv
+;;
+
+let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array =
+ match lv with
+ Ast.LVAL_base nbi ->
+ let referent = lval_to_referent cx nbi.id in
+ if referent_is_slot cx referent
+ then [| referent |]
+ else [| |]
+ | Ast.LVAL_ext (lv, Ast.COMP_named _) -> lval_slots cx lv
+ | Ast.LVAL_ext (lv, Ast.COMP_atom a) ->
+ Array.append (lval_slots cx lv) (atom_slots cx a)
+
+and atom_slots (cx:ctxt) (a:Ast.atom) : node_id array =
+ match a with
+ Ast.ATOM_literal _ -> [| |]
+ | Ast.ATOM_lval lv -> lval_slots cx lv
+;;
+
+let lval_option_slots (cx:ctxt) (lv:Ast.lval option) : node_id array =
+ match lv with
+ None -> [| |]
+ | Some lv -> lval_slots cx lv
+;;
+
+let resolve_lval (cx:ctxt) (lv:Ast.lval) : defn =
+ resolve_lval_id cx (lval_base_id lv)
+;;
+
+let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array =
+ Array.concat (List.map (atom_slots cx) (Array.to_list az))
+;;
+
+let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
+ Array.concat (List.map
+ (fun (_,_,a) -> atom_slots cx a)
+ (Array.to_list 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)
+ (Array.to_list inputs))
+;;
+
+let expr_slots (cx:ctxt) (e:Ast.expr) : node_id array =
+ match e with
+ Ast.EXPR_binary (_, a, b) ->
+ Array.append (atom_slots cx a) (atom_slots cx b)
+ | Ast.EXPR_unary (_, u) -> atom_slots cx u
+ | Ast.EXPR_atom a -> atom_slots cx a
+;;
+
+
+(* Type extraction. *)
+
+let interior_slot_full mut ty : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_interior;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+;;
+
+let exterior_slot_full mut ty : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_exterior;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some ty }
+;;
+
+let interior_slot ty : Ast.slot = interior_slot_full false ty
+;;
+
+let exterior_slot ty : Ast.slot = exterior_slot_full false ty
+;;
+
+
+(* General folds of Ast.ty. *)
+
+type ('ty, 'slot, 'slots, 'tag) ty_fold =
+ {
+ (* Functions that correspond to interior nodes in Ast.ty. *)
+ ty_fold_slot : (Ast.mode * bool * 'ty) -> 'slot;
+ ty_fold_slots : ('slot array) -> 'slots;
+ ty_fold_tags : (Ast.name, 'slots) Hashtbl.t -> 'tag;
+
+ (* Functions that correspond to the Ast.ty constructors. *)
+ ty_fold_any: unit -> 'ty;
+ ty_fold_nil : unit -> 'ty;
+ ty_fold_bool : unit -> 'ty;
+ ty_fold_mach : ty_mach -> 'ty;
+ ty_fold_int : unit -> 'ty;
+ ty_fold_uint : unit -> 'ty;
+ ty_fold_char : unit -> 'ty;
+ ty_fold_str : unit -> 'ty;
+ ty_fold_tup : 'slots -> 'ty;
+ ty_fold_vec : 'slot -> 'ty;
+ ty_fold_rec : (Ast.ident * 'slot) array -> 'ty;
+ ty_fold_tag : 'tag -> 'ty;
+ ty_fold_iso : (int * 'tag array) -> 'ty;
+ ty_fold_idx : int -> 'ty;
+ ty_fold_fn : (('slots * Ast.constrs * 'slot) * Ast.ty_fn_aux) -> 'ty;
+ ty_fold_obj : (Ast.effect
+ * (Ast.ident, (('slots * Ast.constrs * 'slot) *
+ Ast.ty_fn_aux)) Hashtbl.t) -> 'ty;
+ ty_fold_chan : 'ty -> 'ty;
+ ty_fold_port : 'ty -> 'ty;
+ ty_fold_task : unit -> 'ty;
+ ty_fold_native : opaque_id -> 'ty;
+ ty_fold_param : (int * Ast.effect) -> 'ty;
+ ty_fold_named : Ast.name -> 'ty;
+ ty_fold_type : unit -> 'ty;
+ ty_fold_constrained : ('ty * Ast.constrs) -> 'ty }
+;;
+
+let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
+ let fold_slot (s:Ast.slot) : 'slot =
+ f.ty_fold_slot (s.Ast.slot_mode,
+ s.Ast.slot_mutable,
+ fold_ty f (slot_ty s))
+ in
+ let fold_slots (slots:Ast.slot array) : 'slots =
+ f.ty_fold_slots (Array.map fold_slot slots)
+ in
+ let fold_tags (ttag:Ast.ty_tag) : 'tag =
+ f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_slots v)))
+ in
+ let fold_sig tsig =
+ (fold_slots tsig.Ast.sig_input_slots,
+ tsig.Ast.sig_input_constrs,
+ fold_slot tsig.Ast.sig_output_slot)
+ in
+ let fold_obj fns =
+ htab_map fns (fun i (tsig, taux) -> (i, (fold_sig tsig, taux)))
+ in
+ match ty with
+ Ast.TY_any -> f.ty_fold_any ()
+ | Ast.TY_nil -> f.ty_fold_nil ()
+ | Ast.TY_bool -> f.ty_fold_bool ()
+ | Ast.TY_mach m -> f.ty_fold_mach m
+ | Ast.TY_int -> f.ty_fold_int ()
+ | Ast.TY_uint -> f.ty_fold_uint ()
+ | Ast.TY_char -> f.ty_fold_char ()
+ | Ast.TY_str -> f.ty_fold_str ()
+
+ | Ast.TY_tup t -> f.ty_fold_tup (fold_slots t)
+ | Ast.TY_vec s -> f.ty_fold_vec (fold_slot s)
+ | Ast.TY_rec r -> f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_slot v)) r)
+
+ | Ast.TY_tag tt -> f.ty_fold_tag (fold_tags tt)
+ | Ast.TY_iso ti -> f.ty_fold_iso (ti.Ast.iso_index,
+ (Array.map fold_tags ti.Ast.iso_group))
+ | Ast.TY_idx i -> f.ty_fold_idx i
+
+ | Ast.TY_fn (tsig,taux) -> f.ty_fold_fn (fold_sig tsig, taux)
+ | Ast.TY_chan t -> f.ty_fold_chan (fold_ty f t)
+ | Ast.TY_port t -> f.ty_fold_port (fold_ty f t)
+
+ | Ast.TY_obj (eff,t) -> f.ty_fold_obj (eff, (fold_obj t))
+ | Ast.TY_task -> f.ty_fold_task ()
+
+ | Ast.TY_native x -> f.ty_fold_native x
+ | Ast.TY_param x -> f.ty_fold_param x
+ | Ast.TY_named n -> f.ty_fold_named n
+ | Ast.TY_type -> f.ty_fold_type ()
+
+ | Ast.TY_constrained (t, constrs) ->
+ f.ty_fold_constrained (fold_ty f t, constrs)
+
+;;
+
+type 'a simple_ty_fold = ('a, 'a, 'a, 'a) ty_fold
+;;
+
+let ty_fold_default (default:'a) : 'a simple_ty_fold =
+ { ty_fold_slot = (fun _ -> default);
+ ty_fold_slots = (fun _ -> default);
+ ty_fold_tags = (fun _ -> default);
+ ty_fold_any = (fun _ -> default);
+ ty_fold_nil = (fun _ -> default);
+ ty_fold_bool = (fun _ -> default);
+ ty_fold_mach = (fun _ -> default);
+ ty_fold_int = (fun _ -> default);
+ ty_fold_uint = (fun _ -> default);
+ ty_fold_char = (fun _ -> default);
+ ty_fold_str = (fun _ -> default);
+ ty_fold_tup = (fun _ -> default);
+ ty_fold_vec = (fun _ -> default);
+ ty_fold_rec = (fun _ -> default);
+ ty_fold_tag = (fun _ -> default);
+ ty_fold_iso = (fun _ -> default);
+ ty_fold_idx = (fun _ -> default);
+ ty_fold_fn = (fun _ -> default);
+ ty_fold_obj = (fun _ -> default);
+ ty_fold_chan = (fun _ -> default);
+ ty_fold_port = (fun _ -> default);
+ ty_fold_task = (fun _ -> default);
+ ty_fold_native = (fun _ -> default);
+ ty_fold_param = (fun _ -> default);
+ ty_fold_named = (fun _ -> default);
+ ty_fold_type = (fun _ -> default);
+ ty_fold_constrained = (fun _ -> default) }
+;;
+
+let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
+ : (Ast.ty, Ast.slot, Ast.slot array, Ast.ty_tag) ty_fold =
+ let rebuild_fn ((islots, constrs, oslot), aux) =
+ ({ Ast.sig_input_slots = islots;
+ Ast.sig_input_constrs = constrs;
+ Ast.sig_output_slot = oslot }, aux)
+ in
+ { ty_fold_slot = (fun (mode, mut, t) ->
+ { Ast.slot_mode = mode;
+ Ast.slot_mutable = mut;
+ Ast.slot_ty = Some t });
+ ty_fold_slots = (fun slots -> slots);
+ ty_fold_tags = (fun htab -> htab);
+ ty_fold_any = (fun _ -> id Ast.TY_any);
+ ty_fold_nil = (fun _ -> id Ast.TY_nil);
+ ty_fold_bool = (fun _ -> id Ast.TY_bool);
+ ty_fold_mach = (fun m -> id (Ast.TY_mach m));
+ ty_fold_int = (fun _ -> id Ast.TY_int);
+ ty_fold_uint = (fun _ -> id Ast.TY_uint);
+ ty_fold_char = (fun _ -> id Ast.TY_char);
+ ty_fold_str = (fun _ -> id Ast.TY_str);
+ ty_fold_tup = (fun slots -> id (Ast.TY_tup slots));
+ ty_fold_vec = (fun slot -> id (Ast.TY_vec slot));
+ ty_fold_rec = (fun entries -> id (Ast.TY_rec entries));
+ ty_fold_tag = (fun tag -> id (Ast.TY_tag tag));
+ ty_fold_iso = (fun (i, tags) -> id (Ast.TY_iso { Ast.iso_index = i;
+ Ast.iso_group = tags }));
+ ty_fold_idx = (fun i -> id (Ast.TY_idx i));
+ ty_fold_fn = (fun t -> id (Ast.TY_fn (rebuild_fn t)));
+ ty_fold_obj = (fun (eff,fns) ->
+ id (Ast.TY_obj
+ (eff, (htab_map fns
+ (fun id fn -> (id, rebuild_fn fn))))));
+ ty_fold_chan = (fun t -> id (Ast.TY_chan t));
+ ty_fold_port = (fun t -> id (Ast.TY_port t));
+ ty_fold_task = (fun _ -> id Ast.TY_task);
+ ty_fold_native = (fun oid -> id (Ast.TY_native oid));
+ ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
+ ty_fold_named = (fun n -> id (Ast.TY_named n));
+ ty_fold_type = (fun _ -> id (Ast.TY_type));
+ ty_fold_constrained = (fun (t, constrs) ->
+ id (Ast.TY_constrained (t, constrs))) }
+;;
+
+let rebuild_ty_under_params
+ (ty:Ast.ty)
+ (params:Ast.ty_param array)
+ (args:Ast.ty array)
+ (resolve_names:bool)
+ : Ast.ty =
+ if (Array.length params) <> (Array.length args)
+ then err None "mismatched type-params"
+ else
+ let nmap = Hashtbl.create (Array.length args) in
+ let pmap = Hashtbl.create (Array.length args) in
+ let _ =
+ Array.iteri
+ begin
+ fun i (ident, param) ->
+ htab_put pmap (Ast.TY_param param) args.(i);
+ if resolve_names
+ then
+ htab_put nmap ident args.(i)
+ end
+ params
+ in
+ let substituted = ref false in
+ let rec rebuild_ty t =
+ let base = ty_fold_rebuild (fun t -> t) in
+ let ty_fold_param (i, mut) =
+ let param = Ast.TY_param (i, mut) in
+ match htab_search pmap param with
+ None -> param
+ | Some arg -> (substituted := true; arg)
+ in
+ let ty_fold_named n =
+ let rec rebuild_name n =
+ match n with
+ Ast.NAME_base nb ->
+ Ast.NAME_base (rebuild_name_base nb)
+ | Ast.NAME_ext (n, nc) ->
+ Ast.NAME_ext (rebuild_name n,
+ rebuild_name_component nc)
+
+ and rebuild_name_base nb =
+ match nb with
+ Ast.BASE_ident i ->
+ Ast.BASE_ident i
+ | Ast.BASE_temp t ->
+ Ast.BASE_temp t
+ | Ast.BASE_app (i, tys) ->
+ Ast.BASE_app (i, rebuild_tys tys)
+
+ and rebuild_name_component nc =
+ match nc with
+ Ast.COMP_ident i ->
+ Ast.COMP_ident i
+ | Ast.COMP_app (i, tys) ->
+ Ast.COMP_app (i, rebuild_tys tys)
+ | Ast.COMP_idx i ->
+ Ast.COMP_idx i
+
+ and rebuild_tys tys =
+ Array.map (fun t -> rebuild_ty t) tys
+ in
+ let n = rebuild_name n in
+ match n with
+ Ast.NAME_base (Ast.BASE_ident id)
+ when resolve_names ->
+ begin
+ match htab_search nmap id with
+ None -> Ast.TY_named n
+ | Some arg -> (substituted := true; arg)
+ end
+ | _ -> Ast.TY_named n
+ in
+ let fold =
+ { base with
+ ty_fold_param = ty_fold_param;
+ ty_fold_named = ty_fold_named;
+ }
+ in
+ let t' = fold_ty fold t in
+ (*
+ * FIXME: "substituted" and "ty'" here are only required
+ * because the current type-equality-comparison code in Type
+ * uses <> and will judge some cases, such as rebuilt tags, as
+ * unequal simply due to the different hashtable order in the
+ * fold.
+ *)
+ if !substituted
+ then t'
+ else t
+ in
+ rebuild_ty ty
+;;
+
+let associative_binary_op_ty_fold
+ (default:'a)
+ (fn:'a -> 'a -> 'a)
+ : 'a simple_ty_fold =
+ let base = ty_fold_default default in
+ let reduce ls =
+ match ls with
+ [] -> default
+ | x::xs -> List.fold_left fn x xs
+ in
+ let reduce_fn ((islots, _, oslot), _) =
+ fn islots oslot
+ in
+ { base with
+ ty_fold_slots = (fun slots -> reduce (Array.to_list slots));
+ ty_fold_slot = (fun (_, _, a) -> a);
+ ty_fold_tags = (fun tab -> reduce (htab_vals tab));
+ ty_fold_tup = (fun a -> a);
+ ty_fold_vec = (fun a -> a);
+ ty_fold_rec = (fun sz ->
+ reduce (Array.to_list
+ (Array.map (fun (_, s) -> s) sz)));
+ ty_fold_tag = (fun a -> a);
+ ty_fold_iso = (fun (_,iso) -> reduce (Array.to_list iso));
+ ty_fold_fn = reduce_fn;
+ ty_fold_obj = (fun (_,fns) ->
+ reduce (List.map reduce_fn (htab_vals fns)));
+ ty_fold_chan = (fun a -> a);
+ ty_fold_port = (fun a -> a);
+ ty_fold_constrained = (fun (a, _) -> a) }
+
+let ty_fold_bool_and (default:bool) : bool simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> a & b)
+;;
+
+let ty_fold_bool_or (default:bool) : bool simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> a || b)
+;;
+
+let ty_fold_int_max (default:int) : int simple_ty_fold =
+ associative_binary_op_ty_fold default (fun a b -> max a b)
+;;
+
+let ty_fold_list_concat _ : ('a list) simple_ty_fold =
+ associative_binary_op_ty_fold [] (fun a b -> a @ b)
+;;
+
+let type_is_structured (t:Ast.ty) : bool =
+ let fold = ty_fold_bool_or false in
+ let fold = { fold with
+ ty_fold_tup = (fun _ -> true);
+ ty_fold_vec = (fun _ -> true);
+ ty_fold_rec = (fun _ -> true);
+ ty_fold_tag = (fun _ -> true);
+ ty_fold_iso = (fun _ -> true);
+ ty_fold_idx = (fun _ -> true);
+ ty_fold_fn = (fun _ -> true);
+ ty_fold_obj = (fun _ -> true) }
+ in
+ fold_ty fold t
+;;
+
+(* Effect analysis. *)
+let effect_le x y =
+ match (x,y) with
+ (Ast.UNSAFE, _) -> true
+ | (Ast.STATE, Ast.PURE) -> true
+ | (Ast.STATE, Ast.IO) -> true
+ | (Ast.STATE, Ast.STATE) -> true
+ | (Ast.IO, Ast.PURE) -> true
+ | (Ast.IO, Ast.IO) -> true
+ | (Ast.PURE, Ast.PURE) -> true
+ | _ -> false
+;;
+
+let lower_effect_of x y =
+ if effect_le x y then x else y
+;;
+
+let type_effect (t:Ast.ty) : Ast.effect =
+ let fold_slot ((*mode*)_, mut, eff) =
+ if mut
+ then lower_effect_of Ast.STATE eff
+ else eff
+ in
+ let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
+ let fold = { fold with ty_fold_slot = fold_slot } in
+ fold_ty fold t
+;;
+
+let type_has_state (t:Ast.ty) : bool =
+ effect_le (type_effect t) Ast.STATE
+;;
+
+
+(* Various type analyses. *)
+
+let is_prim_type (t:Ast.ty) : bool =
+ match t with
+ Ast.TY_int
+ | Ast.TY_uint
+ | Ast.TY_char
+ | Ast.TY_mach _
+ | Ast.TY_bool -> true
+ | _ -> false
+;;
+
+let type_contains_chan (t:Ast.ty) : bool =
+ let fold_chan _ = true in
+ let fold = ty_fold_bool_or false in
+ let fold = { fold with ty_fold_chan = fold_chan } in
+ fold_ty fold t
+;;
+
+
+let type_is_unsigned_2s_complement t =
+ match t with
+ Ast.TY_mach TY_u8
+ | Ast.TY_mach TY_u16
+ | Ast.TY_mach TY_u32
+ | Ast.TY_mach TY_u64
+ | Ast.TY_char
+ | Ast.TY_uint
+ | Ast.TY_bool -> true
+ | _ -> false
+;;
+
+
+let type_is_signed_2s_complement t =
+ match t with
+ Ast.TY_mach TY_i8
+ | Ast.TY_mach TY_i16
+ | Ast.TY_mach TY_i32
+ | Ast.TY_mach TY_i64
+ | Ast.TY_int -> true
+ | _ -> false
+;;
+
+
+let type_is_2s_complement t =
+ (type_is_unsigned_2s_complement t)
+ || (type_is_signed_2s_complement t)
+;;
+
+let n_used_type_params t =
+ let fold_param (i,_) = i+1 in
+ let fold = ty_fold_int_max 0 in
+ let fold = { fold with ty_fold_param = fold_param } in
+ fold_ty fold t
+;;
+
+
+
+let check_concrete params thing =
+ if Array.length params = 0
+ then thing
+ else bug () "unhandled parametric binding"
+;;
+
+
+let project_type_to_slot
+ (base_ty:Ast.ty)
+ (comp:Ast.lval_component)
+ : Ast.slot =
+ match (base_ty, comp) with
+ (Ast.TY_rec elts, Ast.COMP_named (Ast.COMP_ident id)) ->
+ begin
+ match atab_search elts id with
+ Some slot -> slot
+ | None -> err None "unknown record-member '%s'" id
+ end
+
+ | (Ast.TY_tup elts, Ast.COMP_named (Ast.COMP_idx i)) ->
+ if 0 <= i && i < (Array.length elts)
+ then elts.(i)
+ else err None "out-of-range tuple index %d" i
+
+ | (Ast.TY_vec slot, Ast.COMP_atom _) ->
+ slot
+
+ | (Ast.TY_str, Ast.COMP_atom _) ->
+ interior_slot (Ast.TY_mach TY_u8)
+
+ | (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) ->
+ interior_slot (Ast.TY_fn (Hashtbl.find fns id))
+
+ | (_,_) ->
+ bug ()
+ "unhandled form of lval-ext in Semant."
+ "project_slot: %a indexed by %a"
+ Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp
+;;
+
+
+(* NB: this will fail if lval is not a slot. *)
+let rec lval_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot =
+ match lval with
+ Ast.LVAL_base nb -> lval_to_slot cx nb.id
+ | Ast.LVAL_ext (base, comp) ->
+ let base_ty = slot_ty (lval_slot cx base) in
+ project_type_to_slot base_ty comp
+;;
+
+let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool =
+ (Hashtbl.mem view.Ast.view_exports Ast.EXPORT_all_decls) ||
+ (Hashtbl.mem view.Ast.view_exports (Ast.EXPORT_ident ident))
+;;
+
+(* NB: this will fail if lval is not an item. *)
+let rec lval_item (cx:ctxt) (lval:Ast.lval) : Ast.mod_item =
+ match lval with
+ Ast.LVAL_base nb ->
+ begin
+ let referent = lval_to_referent cx nb.id in
+ match htab_search cx.ctxt_all_defns referent with
+ Some (DEFN_item item) -> {node=item; id=referent}
+ | _ -> err (Some (lval_base_id lval))
+ "lval does not name an item"
+ end
+ | Ast.LVAL_ext (base, comp) ->
+ let base_item = lval_item cx base in
+ match base_item.node.Ast.decl_item with
+ Ast.MOD_ITEM_mod (view, items) ->
+ begin
+ let i, args =
+ match comp with
+ Ast.COMP_named (Ast.COMP_ident i) -> (i, [||])
+ | Ast.COMP_named (Ast.COMP_app (i, args)) -> (i, args)
+ | _ ->
+ bug ()
+ "unhandled lval-component '%a' in Semant.lval_item"
+ Ast.sprintf_lval_component comp
+ in
+ match htab_search items i with
+ | Some sub when exports_permit view i ->
+ assert
+ ((Array.length sub.node.Ast.decl_params) =
+ (Array.length args));
+ check_concrete base_item.node.Ast.decl_params sub
+ | _ -> err (Some (lval_base_id lval))
+ "unknown module item '%s'" i
+ end
+ | _ -> err (Some (lval_base_id lval))
+ "lval base %a does not name a module" Ast.sprintf_lval base
+;;
+
+let lval_is_slot (cx:ctxt) (lval:Ast.lval) : bool =
+ match resolve_lval cx lval with
+ DEFN_slot _ -> true
+ | _ -> false
+;;
+
+let lval_is_item (cx:ctxt) (lval:Ast.lval) : bool =
+ match resolve_lval cx lval with
+ DEFN_item _ -> true
+ | _ -> false
+;;
+
+let lval_is_direct_fn (cx:ctxt) (lval:Ast.lval) : bool =
+ let defn = resolve_lval cx lval in
+ (defn_is_static defn) && (defn_is_callable defn)
+;;
+
+let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool =
+ let defn = resolve_lval cx lval in
+ if not (defn_is_static defn)
+ then false
+ else
+ match defn with
+ DEFN_item { Ast.decl_item = Ast.MOD_ITEM_mod _ } -> true
+ | _ -> false
+;;
+
+let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool =
+ defn_is_static (resolve_lval cx lval)
+;;
+
+let lval_is_callable (cx:ctxt) (lval:Ast.lval) : bool =
+ defn_is_callable (resolve_lval cx lval)
+;;
+
+let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool =
+ if lval_is_slot cx lval
+ then
+ match lval with
+ Ast.LVAL_ext (base, _) ->
+ begin
+ match slot_ty (lval_slot cx base) with
+ Ast.TY_obj _ -> true
+ | _ -> false
+ end
+ | _ -> false
+ else false
+;;
+
+let rec lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
+ let base_id = lval_base_id lval in
+ Hashtbl.find cx.ctxt_all_lval_types base_id
+;;
+
+let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
+ match at with
+ Ast.ATOM_literal {node=(Ast.LIT_int _); id=_} -> Ast.TY_int
+ | Ast.ATOM_literal {node=(Ast.LIT_uint _); id=_} -> Ast.TY_uint
+ | Ast.ATOM_literal {node=(Ast.LIT_bool _); id=_} -> Ast.TY_bool
+ | Ast.ATOM_literal {node=(Ast.LIT_char _); id=_} -> Ast.TY_char
+ | Ast.ATOM_literal {node=(Ast.LIT_nil); id=_} -> Ast.TY_nil
+ | Ast.ATOM_literal {node=(Ast.LIT_mach (m,_,_)); id=_} -> Ast.TY_mach m
+ | Ast.ATOM_lval lv -> lval_ty cx lv
+;;
+
+let expr_type (cx:ctxt) (e:Ast.expr) : Ast.ty =
+ match e with
+ Ast.EXPR_binary (op, a, _) ->
+ begin
+ match op with
+ Ast.BINOP_eq | Ast.BINOP_ne | Ast.BINOP_lt | Ast.BINOP_le
+ | Ast.BINOP_ge | Ast.BINOP_gt -> Ast.TY_bool
+ | _ -> atom_type cx a
+ end
+ | Ast.EXPR_unary (Ast.UNOP_not, _) -> Ast.TY_bool
+ | Ast.EXPR_unary (_, a) -> atom_type cx a
+ | Ast.EXPR_atom a -> atom_type cx a
+;;
+
+(* Mappings between mod items and their respective types. *)
+
+let arg_slots (slots:Ast.header_slots) : Ast.slot array =
+ Array.map (fun (sid,_) -> sid.node) slots
+;;
+
+let tup_slots (slots:Ast.header_tup) : Ast.slot array =
+ Array.map (fun sid -> sid.node) slots
+;;
+
+let ty_fn_of_fn (fn:Ast.fn) : Ast.ty_fn =
+ ({ Ast.sig_input_slots = arg_slots fn.Ast.fn_input_slots;
+ Ast.sig_input_constrs = fn.Ast.fn_input_constrs;
+ Ast.sig_output_slot = fn.Ast.fn_output_slot.node },
+ fn.Ast.fn_aux )
+;;
+
+let ty_obj_of_obj (obj:Ast.obj) : Ast.ty_obj =
+ (obj.Ast.obj_effect,
+ htab_map obj.Ast.obj_fns (fun i f -> (i, ty_fn_of_fn f.node)))
+;;
+
+let ty_of_mod_item ((*inside*)_:bool) (item:Ast.mod_item) : Ast.ty =
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type _ -> Ast.TY_type
+ | Ast.MOD_ITEM_fn f -> (Ast.TY_fn (ty_fn_of_fn f))
+ | Ast.MOD_ITEM_mod _ -> bug () "Semant.ty_of_mod_item on mod"
+ | Ast.MOD_ITEM_obj ob ->
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = false }
+ in
+ let tobj = Ast.TY_obj (ty_obj_of_obj ob) in
+ let tsig = { Ast.sig_input_slots = arg_slots ob.Ast.obj_state;
+ Ast.sig_input_constrs = ob.Ast.obj_constrs;
+ Ast.sig_output_slot = interior_slot tobj }
+ in
+ (Ast.TY_fn (tsig, taux))
+
+ | Ast.MOD_ITEM_tag (htup, ttag, _) ->
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = false }
+ in
+ let tsig = { Ast.sig_input_slots = tup_slots htup;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = interior_slot (Ast.TY_tag ttag) }
+ in
+ (Ast.TY_fn (tsig, taux))
+;;
+
+(* Scopes and the visitor that builds them. *)
+
+type scope =
+ SCOPE_block of node_id
+ | SCOPE_mod_item of Ast.mod_item
+ | SCOPE_obj_fn of (Ast.fn identified)
+ | SCOPE_crate of Ast.crate
+;;
+
+let id_of_scope (sco:scope) : node_id =
+ match sco with
+ SCOPE_block id -> id
+ | SCOPE_mod_item i -> i.id
+ | SCOPE_obj_fn f -> f.id
+ | SCOPE_crate c -> c.id
+;;
+
+let scope_stack_managing_visitor
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let push s =
+ scopes := s :: (!scopes)
+ in
+ let pop _ =
+ scopes := List.tl (!scopes)
+ in
+ let visit_block_pre b =
+ push (SCOPE_block b.id);
+ inner.Walk.visit_block_pre b
+ in
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ pop();
+ in
+ let visit_mod_item_pre n p i =
+ push (SCOPE_mod_item i);
+ inner.Walk.visit_mod_item_pre n p i
+ in
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ pop();
+ in
+ let visit_obj_fn_pre obj ident fn =
+ push (SCOPE_obj_fn fn);
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+ let visit_obj_fn_post obj ident fn =
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ pop();
+ in
+ let visit_crate_pre c =
+ push (SCOPE_crate c);
+ inner.Walk.visit_crate_pre c
+ in
+ let visit_crate_post c =
+ inner.Walk.visit_crate_post c;
+ pop()
+ in
+ { inner with
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ 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_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post; }
+;;
+
+(* Generic lookup, used for slots, items, types, etc. *)
+
+type resolved = ((scope list * node_id) option) ;;
+
+let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl =
+ match htab_search cx.ctxt_all_defns node with
+ Some (DEFN_item item) -> item
+ | Some _ -> err (Some node) "defn is not an item"
+ | None -> bug () "missing defn"
+;;
+
+let get_slot (cx:ctxt) (node:node_id) : Ast.slot =
+ match htab_search cx.ctxt_all_defns node with
+ Some (DEFN_slot slot) -> slot
+ | Some _ -> err (Some node) "defn is not a slot"
+ | None -> bug () "missing defn"
+;;
+
+let get_mod_item
+ (cx:ctxt)
+ (node:node_id)
+ : (Ast.mod_view * Ast.mod_items) =
+ match get_item cx node with
+ { Ast.decl_item = Ast.MOD_ITEM_mod md } -> md
+ | _ -> err (Some node) "defn is not a mod"
+;;
+
+let get_name_comp_ident
+ (comp:Ast.name_component)
+ : Ast.ident =
+ match comp with
+ Ast.COMP_ident i -> i
+ | Ast.COMP_app (i, _) -> i
+ | Ast.COMP_idx i -> string_of_int i
+;;
+
+let get_name_base_ident
+ (comp:Ast.name_base)
+ : Ast.ident =
+ match comp with
+ Ast.BASE_ident i -> i
+ | Ast.BASE_app (i, _) -> i
+ | Ast.BASE_temp _ ->
+ bug () "get_name_base_ident on BASE_temp"
+;;
+
+let rec project_ident_from_items
+ (cx:ctxt)
+ (scopes:scope list)
+ ((view:Ast.mod_view),(items:Ast.mod_items))
+ (ident:Ast.ident)
+ (inside:bool)
+ : resolved =
+ if not (inside || (exports_permit view ident))
+ then None
+ else
+ match htab_search items ident with
+ Some i -> Some (scopes, i.id)
+ | None ->
+ match htab_search view.Ast.view_imports ident with
+ None -> None
+ | Some name -> lookup_by_name cx scopes name
+
+and project_name_comp_from_resolved
+ (cx:ctxt)
+ (mod_res:resolved)
+ (ext:Ast.name_component)
+ : resolved =
+ match mod_res with
+ None -> None
+ | Some (scopes, id) ->
+ let scope = (SCOPE_mod_item {id=id; node=get_item cx id}) in
+ let scopes = scope :: scopes in
+ let ident = get_name_comp_ident ext in
+ let md = get_mod_item cx id in
+ project_ident_from_items cx scopes md ident false
+
+and lookup_by_name
+ (cx:ctxt)
+ (scopes:scope list)
+ (name:Ast.name)
+ : resolved =
+ assert (Ast.sane_name name);
+ match name with
+ Ast.NAME_base nb ->
+ let ident = get_name_base_ident nb in
+ lookup_by_ident cx scopes ident
+ | Ast.NAME_ext (name, ext) ->
+ let base_res = lookup_by_name cx scopes name in
+ project_name_comp_from_resolved cx base_res ext
+
+and lookup_by_ident
+ (cx:ctxt)
+ (scopes:scope list)
+ (ident:Ast.ident)
+ : resolved =
+ let check_slots scopes islots =
+ arr_search islots
+ (fun _ (sloti,ident') ->
+ if ident = ident'
+ then Some (scopes, sloti.id)
+ else None)
+ in
+ let check_params scopes params =
+ arr_search params
+ (fun _ {node=(i,_); id=id} ->
+ if i = ident then Some (scopes, id) else None)
+ in
+ let passed_capture_scope = ref false in
+ let would_capture r =
+ match r with
+ None -> None
+ | Some _ ->
+ if !passed_capture_scope
+ then err None "attempted dynamic environment-capture"
+ else r
+ in
+ let check_scope scopes scope =
+ match scope with
+ SCOPE_block block_id ->
+ let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ let block_items = Hashtbl.find cx.ctxt_block_items block_id in
+ begin
+ match htab_search block_slots (Ast.KEY_ident ident) with
+ Some id -> would_capture (Some (scopes, id))
+ | None ->
+ match htab_search block_items ident with
+ Some id -> Some (scopes, id)
+ | None -> None
+ end
+
+ | SCOPE_crate crate ->
+ project_ident_from_items
+ cx scopes crate.node.Ast.crate_items ident true
+
+ | SCOPE_obj_fn fn ->
+ would_capture (check_slots scopes fn.node.Ast.fn_input_slots)
+
+ | SCOPE_mod_item item ->
+ begin
+ let item_match =
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ check_slots scopes f.Ast.fn_input_slots
+
+ | Ast.MOD_ITEM_obj obj ->
+ begin
+ match htab_search obj.Ast.obj_fns ident with
+ Some fn -> Some (scopes, fn.id)
+ | None -> check_slots scopes obj.Ast.obj_state
+ end
+
+ | Ast.MOD_ITEM_mod md ->
+ project_ident_from_items cx scopes md ident true
+
+ | _ -> None
+ in
+ match item_match with
+ Some _ -> item_match
+ | None ->
+ would_capture
+ (check_params scopes item.node.Ast.decl_params)
+ end
+ in
+ let rec search scopes =
+ match scopes with
+ [] -> None
+ | scope::rest ->
+ match check_scope scopes scope with
+ None ->
+ begin
+ let is_ty_item i =
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_type _ -> true
+ | _ -> false
+ in
+ match scope with
+ SCOPE_block _
+ | SCOPE_obj_fn _ ->
+ search rest
+
+ | SCOPE_mod_item item when is_ty_item item ->
+ search rest
+
+ | _ ->
+ passed_capture_scope := true;
+ search rest
+ end
+ | x -> x
+ in
+ search scopes
+;;
+
+let lookup_by_temp
+ (cx:ctxt)
+ (scopes:scope list)
+ (temp:temp_id)
+ : ((scope list * node_id) option) =
+ let passed_item_scope = ref false in
+ let check_scope scope =
+ if !passed_item_scope
+ then None
+ else
+ match scope with
+ SCOPE_block block_id ->
+ let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ htab_search block_slots (Ast.KEY_temp temp)
+ | _ ->
+ passed_item_scope := true;
+ None
+ in
+ list_search_ctxt scopes check_scope
+;;
+
+let lookup
+ (cx:ctxt)
+ (scopes:scope list)
+ (key:Ast.slot_key)
+ : ((scope list * node_id) option) =
+ match key with
+ Ast.KEY_temp temp -> lookup_by_temp cx scopes temp
+ | Ast.KEY_ident ident -> lookup_by_ident cx scopes ident
+;;
+
+
+let run_passes
+ (cx:ctxt)
+ (name:string)
+ (path:Ast.name_component Stack.t)
+ (passes:Walk.visitor array)
+ (log:string->unit)
+ (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))
+ crate
+ in
+ let sess = cx.ctxt_sess in
+ if sess.Session.sess_failed
+ then ()
+ else
+ try
+ Session.time_inner name sess
+ (fun _ -> Array.iteri do_pass passes)
+ with
+ Semant_err (ido, str) -> report_err cx ido str
+;;
+
+(* Rust type -> IL type conversion. *)
+
+let word_sty (abi:Abi.abi) : Il.scalar_ty =
+ Il.ValTy abi.Abi.abi_word_bits
+;;
+
+let word_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.ScalarTy (word_sty abi)
+;;
+
+let tydesc_rty (abi:Abi.abi) : Il.referent_ty =
+ (*
+ * NB: must match corresponding tydesc structure
+ * in trans and offsets in ABI exactly.
+ *)
+ Il.StructTy
+ [|
+ word_rty abi; (* Abi.tydesc_field_first_param *)
+ word_rty abi; (* Abi.tydesc_field_size *)
+ word_rty abi; (* Abi.tydesc_field_align *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_copy_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_drop_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_free_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_mark_glue *)
+ Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_obj_drop_glue *)
+ |]
+;;
+
+let obj_closure_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.StructTy [| word_rty abi;
+ Il.ScalarTy (Il.AddrTy (tydesc_rty abi));
+ word_rty abi (* A lie: it's opaque, but this permits
+ * GEP'ing to it. *)
+ |]
+;;
+
+let rec referent_type (abi:Abi.abi) (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 word = word_rty abi 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 (slot_referent_type abi) ttup) in
+ let tag ttag =
+ let union =
+ Il.UnionTy
+ (Array.map
+ (fun key -> tup (Hashtbl.find ttag key))
+ (sorted_htab_keys ttag))
+ in
+ let discriminant = word in
+ Il.StructTy [| discriminant; union |]
+ in
+
+ match t with
+ Ast.TY_any -> Il.StructTy [| word; ptr |]
+ | Ast.TY_nil -> Il.NilTy
+ | Ast.TY_int
+ | Ast.TY_uint -> word
+
+ | Ast.TY_bool -> sv Il.Bits8
+
+ | Ast.TY_mach (TY_u8)
+ | Ast.TY_mach (TY_i8) -> sv Il.Bits8
+
+ | Ast.TY_mach (TY_u16)
+ | Ast.TY_mach (TY_i16) -> sv Il.Bits16
+
+ | Ast.TY_mach (TY_u32)
+ | Ast.TY_mach (TY_i32)
+ | Ast.TY_mach (TY_f32)
+ | Ast.TY_char -> sv Il.Bits32
+
+ | Ast.TY_mach (TY_u64)
+ | Ast.TY_mach (TY_i64)
+ | Ast.TY_mach (TY_f64) -> sv Il.Bits64
+
+ | Ast.TY_str -> sp (Il.StructTy [| word; word; word; ptr |])
+ | Ast.TY_vec _ -> sp (Il.StructTy [| word; word; word; ptr |])
+ | 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_closure_ptr = sp (obj_closure_rty abi) in
+ Il.StructTy [| ptr; obj_closure_ptr |]
+
+ | Ast.TY_tag ttag -> tag ttag
+ | Ast.TY_iso tiso -> tag tiso.Ast.iso_group.(tiso.Ast.iso_index)
+
+ | Ast.TY_idx _ -> word (* A lie, but permits GEP'ing to it. *)
+
+ | Ast.TY_chan _
+ | Ast.TY_port _
+ | Ast.TY_task -> rc_ptr
+
+ | Ast.TY_type -> sp (tydesc_rty abi)
+
+ | Ast.TY_native _ -> ptr
+
+ | Ast.TY_param (i, _) -> Il.ParamTy i
+
+ | Ast.TY_named _ -> bug () "named type in referent_type"
+ | Ast.TY_constrained (t, _) -> referent_type abi t
+
+and slot_referent_type (abi:Abi.abi) (sl:Ast.slot) : 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 word = sv abi.Abi.abi_word_bits in
+
+ let rty = referent_type abi (slot_ty sl) in
+ match sl.Ast.slot_mode with
+ Ast.MODE_exterior _ -> sp (Il.StructTy [| word; rty |])
+ | Ast.MODE_interior _ -> rty
+ | Ast.MODE_alias _ -> sp rty
+;;
+
+let task_rty (abi:Abi.abi) : Il.referent_ty =
+ Il.StructTy
+ begin
+ Array.init
+ Abi.n_visible_task_fields
+ (fun _ -> word_rty abi)
+ end
+;;
+
+let call_args_referent_type_full
+ (abi:Abi.abi)
+ (out_slot:Ast.slot)
+ (n_ty_params:int)
+ (in_slots:Ast.slot array)
+ (iterator_arg_rtys:Il.referent_ty array)
+ (indirect_arg_rtys:Il.referent_ty array)
+ : Il.referent_ty =
+ let out_slot_rty = slot_referent_type abi out_slot in
+ let out_ptr_rty = Il.ScalarTy (Il.AddrTy out_slot_rty) in
+ let task_ptr_rty = Il.ScalarTy (Il.AddrTy (task_rty abi)) in
+ let ty_param_rtys =
+ let td = Il.ScalarTy (Il.AddrTy (tydesc_rty abi)) in
+ Il.StructTy (Array.init n_ty_params (fun _ -> td))
+ in
+ let arg_rtys = Il.StructTy (Array.map (slot_referent_type abi) in_slots) in
+ (*
+ * NB: must match corresponding calltup structure in trans and
+ * member indices in ABI exactly.
+ *)
+ Il.StructTy
+ [|
+ out_ptr_rty; (* Abi.calltup_elt_out_ptr *)
+ task_ptr_rty; (* Abi.calltup_elt_task_ptr *)
+ 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 *)
+ |]
+;;
+
+let call_args_referent_type
+ (cx:ctxt)
+ (n_ty_params:int)
+ (callee_ty:Ast.ty)
+ (closure:Il.referent_ty option)
+ : Il.referent_ty =
+ let indirect_arg_rtys =
+ match closure with
+ None -> [| |]
+ | Some c ->
+ [|
+ (* Abi.indirect_args_elt_closure *)
+ Il.ScalarTy (Il.AddrTy c)
+ |]
+ in
+ let iterator_arg_rtys _ =
+ [|
+ (* Abi.iterator_args_elt_loop_size *)
+ Il.ScalarTy (Il.ValTy cx.ctxt_abi.Abi.abi_word_bits);
+ (* Abi.iterator_args_elt_loop_info_ptr *)
+ Il.ScalarTy (Il.AddrTy Il.OpaqueTy)
+ |]
+ in
+ match callee_ty with
+ Ast.TY_fn (tsig, taux) ->
+ call_args_referent_type_full
+ cx.ctxt_abi
+ tsig.Ast.sig_output_slot
+ n_ty_params
+ tsig.Ast.sig_input_slots
+ (if taux.Ast.fn_is_iter then (iterator_arg_rtys()) else [||])
+ indirect_arg_rtys
+
+ | _ -> bug cx "Semant.call_args_referent_type on non-callable type"
+;;
+
+let indirect_call_args_referent_type
+ (cx:ctxt)
+ (n_ty_params:int)
+ (callee_ty:Ast.ty)
+ (closure:Il.referent_ty)
+ : Il.referent_ty =
+ call_args_referent_type cx n_ty_params callee_ty (Some closure)
+;;
+
+let direct_call_args_referent_type
+ (cx:ctxt)
+ (callee_node:node_id)
+ : Il.referent_ty =
+ let ity = Hashtbl.find cx.ctxt_all_item_types callee_node in
+ let n_ty_params =
+ if item_is_obj_fn cx callee_node
+ then 0
+ else n_item_ty_params cx callee_node
+ in
+ call_args_referent_type cx n_ty_params ity None
+;;
+
+let ty_sz (abi:Abi.abi) (t:Ast.ty) : int64 =
+ force_sz (Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi t))
+;;
+
+let ty_align (abi:Abi.abi) (t:Ast.ty) : int64 =
+ force_sz (Il.referent_ty_align abi.Abi.abi_word_bits (referent_type abi t))
+;;
+
+let slot_sz (abi:Abi.abi) (s:Ast.slot) : int64 =
+ force_sz (Il.referent_ty_size abi.Abi.abi_word_bits
+ (slot_referent_type abi s))
+;;
+
+let word_slot (abi:Abi.abi) : Ast.slot =
+ interior_slot (Ast.TY_mach abi.Abi.abi_word_ty)
+;;
+
+let read_alias_slot (ty:Ast.ty) : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_alias;
+ Ast.slot_mutable = false;
+ Ast.slot_ty = Some ty }
+;;
+
+let word_write_alias_slot (abi:Abi.abi) : Ast.slot =
+ { Ast.slot_mode = Ast.MODE_alias;
+ Ast.slot_mutable = true;
+ Ast.slot_ty = Some (Ast.TY_mach abi.Abi.abi_word_ty) }
+;;
+
+let mk_ty_fn_or_iter
+ (out_slot:Ast.slot)
+ (arg_slots:Ast.slot array)
+ (is_iter:bool)
+ : Ast.ty =
+ (* In some cases we don't care what aux or constrs are. *)
+ let taux = { Ast.fn_effect = Ast.PURE;
+ Ast.fn_is_iter = is_iter; }
+ in
+ let tsig = { Ast.sig_input_slots = arg_slots;
+ Ast.sig_input_constrs = [| |];
+ Ast.sig_output_slot = out_slot; }
+ in
+ Ast.TY_fn (tsig, taux)
+;;
+
+let mk_ty_fn
+ (out_slot:Ast.slot)
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ mk_ty_fn_or_iter out_slot arg_slots false
+;;
+
+let mk_simple_ty_fn
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ (* In some cases we don't care what the output slot is. *)
+ let out_slot = interior_slot Ast.TY_nil in
+ mk_ty_fn out_slot arg_slots
+;;
+
+let mk_simple_ty_iter
+ (arg_slots:Ast.slot array)
+ : Ast.ty =
+ (* In some cases we don't care what the output slot is. *)
+ let out_slot = interior_slot Ast.TY_nil in
+ mk_ty_fn_or_iter out_slot arg_slots true
+;;
+
+
+(* name mangling support. *)
+
+let item_name (cx:ctxt) (id:node_id) : Ast.name =
+ Hashtbl.find cx.ctxt_all_item_names id
+;;
+
+let item_str (cx:ctxt) (id:node_id) : string =
+ string_of_name (item_name cx id)
+;;
+
+let ty_str (ty:Ast.ty) : string =
+ let base = associative_binary_op_ty_fold "" (fun a b -> a ^ b) in
+ let fold_slot (mode,mut,ty) =
+ (if mut then "m" else "")
+ ^ (match mode with
+ Ast.MODE_exterior -> "e"
+ | Ast.MODE_alias -> "a"
+ | Ast.MODE_interior -> "")
+ ^ ty
+ in
+ let num n = (string_of_int n) ^ "$" in
+ let len a = num (Array.length a) in
+ let join az = Array.fold_left (fun a b -> a ^ b) "" az in
+ let fold_slots slots =
+ "t"
+ ^ (len slots)
+ ^ (join slots)
+ in
+ let fold_rec entries =
+ "r"
+ ^ (len entries)
+ ^ (Array.fold_left
+ (fun str (ident, s) -> str ^ "$" ^ ident ^ "$" ^ s)
+ "" entries)
+ in
+ let fold_tags tags =
+ "g"
+ ^ (num (Hashtbl.length tags))
+ ^ (Array.fold_left
+ (fun str key -> str ^ (string_of_name key) ^ (Hashtbl.find tags key))
+ "" (sorted_htab_keys tags))
+ in
+ let fold_iso (n, tags) =
+ "G"
+ ^ (num n)
+ ^ (len tags)
+ ^ (join tags)
+ in
+ let fold_mach m =
+ match m with
+ TY_u8 -> "U0"
+ | TY_u16 -> "U1"
+ | TY_u32 -> "U2"
+ | TY_u64 -> "U3"
+ | TY_i8 -> "I0"
+ | TY_i16 -> "I1"
+ | TY_i32 -> "I2"
+ | TY_i64 -> "I3"
+ | TY_f32 -> "F2"
+ | TY_f64 -> "F3"
+ in
+ let fold =
+ { base with
+ (* Structural types. *)
+ ty_fold_slot = fold_slot;
+ ty_fold_slots = fold_slots;
+ ty_fold_tags = fold_tags;
+ ty_fold_rec = fold_rec;
+ ty_fold_nil = (fun _ -> "n");
+ ty_fold_bool = (fun _ -> "b");
+ ty_fold_mach = fold_mach;
+ ty_fold_int = (fun _ -> "i");
+ ty_fold_uint = (fun _ -> "u");
+ ty_fold_char = (fun _ -> "c");
+ ty_fold_obj = (fun _ -> "o");
+ ty_fold_str = (fun _ -> "s");
+ ty_fold_vec = (fun s -> "v" ^ s);
+ ty_fold_iso = fold_iso;
+ ty_fold_idx = (fun i -> "x" ^ (string_of_int i));
+ (* FIXME: encode constrs, aux as well. *)
+ ty_fold_fn = (fun ((ins,_,out),_) -> "f" ^ ins ^ out);
+
+ (* Built-in special types. *)
+ ty_fold_any = (fun _ -> "A");
+ ty_fold_chan = (fun t -> "H" ^ t);
+ ty_fold_port = (fun t -> "R" ^ t);
+ ty_fold_task = (fun _ -> "T");
+ ty_fold_native = (fun _ -> "N");
+ ty_fold_param = (fun _ -> "P");
+ ty_fold_type = (fun _ -> "Y");
+
+ (* FIXME: encode obj types. *)
+ (* FIXME: encode opaque and param numbers. *)
+ ty_fold_named = (fun _ -> bug () "string-encoding named type");
+ (* FIXME: encode constrs as well. *)
+ ty_fold_constrained = (fun (t,_)-> t) }
+ in
+ fold_ty fold ty
+;;
+
+let glue_str (cx:ctxt) (g:glue) : string =
+ match g with
+ GLUE_activate -> "glue$activate"
+ | GLUE_yield -> "glue$yield"
+ | GLUE_exit_main_task -> "glue$exit_main_task"
+ | GLUE_exit_task -> "glue$exit_task"
+ | GLUE_mark ty -> "glue$mark$" ^ (ty_str ty)
+ | GLUE_drop ty -> "glue$drop$" ^ (ty_str ty)
+ | GLUE_free ty -> "glue$free$" ^ (ty_str ty)
+ | GLUE_copy ty -> "glue$copy$" ^ (ty_str ty)
+ | GLUE_clone ty -> "glue$clone$" ^ (ty_str ty)
+ | GLUE_compare ty -> "glue$compare$" ^ (ty_str ty)
+ | GLUE_hash ty -> "glue$hash$" ^ (ty_str ty)
+ | GLUE_write ty -> "glue$write$" ^ (ty_str ty)
+ | GLUE_read ty -> "glue$read$" ^ (ty_str ty)
+ | GLUE_unwind -> "glue$unwind"
+ | GLUE_get_next_pc -> "glue$get_next_pc"
+ | GLUE_mark_frame i -> "glue$mark_frame$" ^ (item_str cx i)
+ | GLUE_drop_frame i -> "glue$drop_frame$" ^ (item_str cx i)
+ | GLUE_reloc_frame i -> "glue$reloc_frame$" ^ (item_str cx i)
+ (*
+ * FIXME: the node_id here isn't an item, it's 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_obj_drop oid
+ -> (item_str cx oid) ^ ".drop"
+ | GLUE_loop_body i
+ -> "glue$loop_body$" ^ (string_of_int (int_of_node i))
+ | GLUE_forward (id, oty1, oty2)
+ -> "glue$forward$"
+ ^ id
+ ^ "$" ^ (ty_str (Ast.TY_obj oty1))
+ ^ "$" ^ (ty_str (Ast.TY_obj oty2))
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
new file mode 100644
index 00000000..bca15136
--- /dev/null
+++ b/src/boot/me/trans.ml
@@ -0,0 +1,5031 @@
+(* Translation *)
+
+open Semant;;
+open Common;;
+open Transutil;;
+
+let log cx = Session.log "trans"
+ cx.ctxt_sess.Session.sess_log_trans
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let arr_max a = (Array.length a) - 1;;
+
+type quad_idx = int
+;;
+
+type call =
+ {
+ call_ctrl: call_ctrl;
+ call_callee_ptr: Il.operand;
+ call_callee_ty: Ast.ty;
+ call_callee_ty_params: Ast.ty array;
+ call_output: Il.cell;
+ call_args: Ast.atom array;
+ call_iterator_args: Il.operand array;
+ call_indirect_args: Il.operand array;
+ }
+;;
+
+let trans_visitor
+ (cx:ctxt)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let iflog thunk =
+ if cx.ctxt_sess.Session.sess_log_trans
+ then thunk ()
+ else ()
+ in
+
+ let curr_file = Stack.create () in
+ let curr_stmt = Stack.create () in
+
+ let (abi:Abi.abi) = cx.ctxt_abi in
+ let (word_sz:int64) = word_sz abi in
+ let (word_slot:Ast.slot) = word_slot abi in
+
+ let oper_str = Il.string_of_operand abi.Abi.abi_str_of_hardreg in
+ let cell_str = Il.string_of_cell abi.Abi.abi_str_of_hardreg in
+
+ let (word_bits:Il.bits) = abi.Abi.abi_word_bits in
+ let (word_ty:Il.scalar_ty) = Il.ValTy word_bits in
+ let (word_rty:Il.referent_ty) = Il.ScalarTy word_ty in
+ let (word_ty_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_u8
+ | Il.Bits16 -> TY_u16
+ | Il.Bits32 -> TY_u32
+ | Il.Bits64 -> TY_u64
+ in
+ let (word_ty_signed_mach:ty_mach) =
+ match word_bits with
+ Il.Bits8 -> TY_i8
+ | Il.Bits16 -> TY_i16
+ | Il.Bits32 -> TY_i32
+ | Il.Bits64 -> TY_i64
+ in
+ let word_n = word_n abi in
+ let imm_of_ty (i:int64) (tm:ty_mach) : Il.operand =
+ Il.Imm (Asm.IMM i, tm)
+ in
+
+ let imm (i:int64) : Il.operand = imm_of_ty i word_ty_mach in
+ let simm (i:int64) : Il.operand = imm_of_ty i word_ty_signed_mach in
+ let one = imm 1L in
+ let zero = imm 0L in
+ let imm_true = imm_of_ty 1L TY_u8 in
+ let imm_false = imm_of_ty 0L TY_u8 in
+ let nil_ptr = Il.Mem ((Il.Abs (Asm.IMM 0L)), Il.NilTy) in
+
+ let crate_rel fix =
+ Asm.SUB (Asm.M_POS fix, Asm.M_POS cx.ctxt_crate_fixup)
+ in
+
+ let crate_rel_word fix =
+ Asm.WORD (word_ty_signed_mach, crate_rel fix)
+ in
+
+ let crate_rel_imm (fix:fixup) : Il.operand =
+ Il.Imm (crate_rel fix, word_ty_signed_mach)
+ in
+
+ let table_of_crate_rel_fixups (fixups:fixup array) : Asm.frag =
+ Asm.SEQ (Array.map crate_rel_word fixups)
+ in
+
+ let fixup_rel_word (base:fixup) (fix:fixup) =
+ Asm.WORD (word_ty_signed_mach,
+ Asm.SUB (Asm.M_POS fix, Asm.M_POS base))
+ in
+
+ let table_of_fixup_rel_fixups
+ (fixup:fixup)
+ (fixups:fixup array)
+ : Asm.frag =
+ Asm.SEQ (Array.map (fixup_rel_word fixup) fixups)
+ in
+
+ let table_of_table_rel_fixups (fixups:fixup array) : Asm.frag =
+ let table_fix = new_fixup "vtbl" in
+ Asm.DEF (table_fix, table_of_fixup_rel_fixups table_fix fixups)
+ in
+
+ let nabi_indirect =
+ match cx.ctxt_sess.Session.sess_targ with
+ Linux_x86_elf -> false
+ | _ -> true
+ in
+
+ let nabi_rust =
+ { nabi_indirect = nabi_indirect;
+ nabi_convention = CONV_rust }
+ in
+
+ let out_mem_disp = abi.Abi.abi_frame_base_sz in
+ let arg0_disp =
+ Int64.add abi.Abi.abi_frame_base_sz abi.Abi.abi_implicit_args_sz
+ in
+ let frame_crate_ptr = word_n (-1) in
+ let frame_fns_disp = word_n (-2) in
+
+ let fn_ty (id:node_id) : Ast.ty =
+ Hashtbl.find cx.ctxt_all_item_types id
+ in
+ let fn_args_rty
+ (id:node_id)
+ (closure:Il.referent_ty option)
+ : Il.referent_ty =
+ let n_params =
+ if item_is_obj_fn cx id
+ then 0
+ else n_item_ty_params cx id
+ in
+ call_args_referent_type cx n_params (fn_ty id) closure
+ in
+
+ let emitters = Stack.create () in
+ let push_new_emitter (vregs_ok:bool) (fnid:node_id option) =
+ let e = Il.new_emitter
+ abi.Abi.abi_prealloc_quad
+ abi.Abi.abi_is_2addr_machine
+ vregs_ok fnid
+ in
+ Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
+ Stack.push e emitters;
+ in
+
+ let push_new_emitter_with_vregs fnid = push_new_emitter true fnid in
+ let push_new_emitter_without_vregs fnid = push_new_emitter false fnid in
+
+ let pop_emitter _ = ignore (Stack.pop emitters) in
+ let emitter _ = Stack.top emitters in
+ let emitter_size_cache _ = Stack.top (emitter()).Il.emit_size_cache in
+ let push_emitter_size_cache _ =
+ Stack.push
+ (Hashtbl.copy (emitter_size_cache()))
+ (emitter()).Il.emit_size_cache
+ in
+ let pop_emitter_size_cache _ =
+ ignore (Stack.pop (emitter()).Il.emit_size_cache)
+ in
+ let emit q = Il.emit (emitter()) q in
+ let next_vreg _ = Il.next_vreg (emitter()) in
+ let next_vreg_cell t = Il.next_vreg_cell (emitter()) t in
+ let next_spill_cell t =
+ let s = Il.next_spill (emitter()) in
+ let spill_mem = Il.Spill s in
+ let spill_ta = (spill_mem, Il.ScalarTy t) in
+ Il.Mem spill_ta
+ in
+ let mark _ : quad_idx = (emitter()).Il.emit_pc in
+ let patch_existing (jmp:quad_idx) (targ:quad_idx) : unit =
+ Il.patch_jump (emitter()) jmp targ
+ in
+ let patch (i:quad_idx) : unit =
+ Il.patch_jump (emitter()) i (mark());
+ (* Insert a dead quad to ensure there's an otherwise-unused
+ * jump-target here.
+ *)
+ emit Il.Dead
+ in
+
+ let current_fn () =
+ match (emitter()).Il.emit_node with
+ None -> bug () "current_fn without associated node"
+ | Some id -> id
+ in
+ let current_fn_args_rty (closure:Il.referent_ty option) : Il.referent_ty =
+ fn_args_rty (current_fn()) closure
+ in
+ let current_fn_callsz () = get_callsz cx (current_fn()) in
+
+ let annotations _ =
+ (emitter()).Il.emit_annotations
+ in
+
+ let annotate (str:string) =
+ let e = emitter() in
+ Hashtbl.add e.Il.emit_annotations e.Il.emit_pc str
+ in
+
+ let epilogue_jumps = Stack.create() in
+
+ let path_name (_:unit) : string =
+ string_of_name (Walk.path_to_name path)
+ in
+
+ let based (reg:Il.reg) : Il.mem =
+ Il.RegIn (reg, None)
+ in
+
+ let based_off (reg:Il.reg) (off:Asm.expr64) : Il.mem =
+ Il.RegIn (reg, Some off)
+ in
+
+ let based_imm (reg:Il.reg) (imm:int64) : Il.mem =
+ based_off reg (Asm.IMM imm)
+ in
+
+ let fp_imm (imm:int64) : Il.mem =
+ based_imm abi.Abi.abi_fp_reg imm
+ in
+
+ let sp_imm (imm:int64) : Il.mem =
+ based_imm abi.Abi.abi_sp_reg imm
+ in
+
+ let word_at (mem:Il.mem) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.ValTy word_bits))
+ in
+
+ let wordptr_at (mem:Il.mem) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.AddrTy (Il.ScalarTy (Il.ValTy word_bits))))
+ in
+
+ let mov (dst:Il.cell) (src:Il.operand) : unit =
+ emit (Il.umov dst src)
+ in
+
+ let umul (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.UMUL dst a b);
+ in
+
+ let add (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.ADD dst a b);
+ in
+
+ let add_to (dst:Il.cell) (src:Il.operand) : unit =
+ add dst (Il.Cell dst) src;
+ in
+
+ let sub (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
+ emit (Il.binary Il.SUB dst a b);
+ in
+
+ let sub_from (dst:Il.cell) (src:Il.operand) : unit =
+ sub dst (Il.Cell dst) src;
+ in
+
+ let lea (dst:Il.cell) (src:Il.mem) : unit =
+ emit (Il.lea dst (Il.Cell (Il.Mem (src, Il.OpaqueTy))))
+ in
+
+ let rty_ptr_at (mem:Il.mem) (pointee_rty:Il.referent_ty) : Il.cell =
+ Il.Mem (mem, Il.ScalarTy (Il.AddrTy pointee_rty))
+ in
+
+ let ptr_at (mem:Il.mem) (pointee_ty:Ast.ty) : Il.cell =
+ rty_ptr_at mem (referent_type abi pointee_ty)
+ in
+
+ let need_scalar_ty (rty:Il.referent_ty) : Il.scalar_ty =
+ match rty with
+ Il.ScalarTy s -> s
+ | _ -> bug () "expected ScalarTy"
+ in
+
+ let need_mem_cell (cell:Il.cell) : Il.typed_mem =
+ match cell with
+ Il.Mem a -> a
+ | Il.Reg _ -> bug ()
+ "expected address cell, got non-address register cell"
+ in
+
+ let need_cell (operand:Il.operand) : Il.cell =
+ match operand with
+ Il.Cell c -> c
+ | _ -> bug () "expected cell, got operand %s"
+ (Il.string_of_operand abi.Abi.abi_str_of_hardreg operand)
+ in
+
+ let get_element_ptr =
+ Il.get_element_ptr word_bits abi.Abi.abi_str_of_hardreg
+ in
+
+ let get_variant_ptr (mem_cell:Il.cell) (i:int) : Il.cell =
+ match mem_cell with
+ Il.Mem (mem, Il.UnionTy elts)
+ when i >= 0 && i < (Array.length elts) ->
+ assert ((Array.length elts) != 0);
+ Il.Mem (mem, elts.(i))
+
+ | _ -> bug () "get_variant_ptr %d on cell %s" i
+ (cell_str mem_cell)
+ in
+
+ let rec ptr_cast (cell:Il.cell) (rty:Il.referent_ty) : Il.cell =
+ match cell with
+ Il.Mem (mem, _) -> Il.Mem (mem, rty)
+ | Il.Reg (reg, Il.AddrTy _) -> Il.Reg (reg, Il.AddrTy rty)
+ | _ -> bug () "expected address cell in Trans.ptr_cast"
+
+ and curr_crate_ptr _ : Il.cell =
+ word_at (fp_imm frame_crate_ptr)
+
+ and crate_rel_to_ptr (rel:Il.operand) (rty:Il.referent_ty) : Il.cell =
+ let cell = next_vreg_cell (Il.AddrTy rty) in
+ mov cell (Il.Cell (curr_crate_ptr()));
+ add_to cell rel;
+ cell
+
+ (*
+ * Note: alias *requires* its cell to be in memory already, and should
+ * only be used on slots you know to be memory-resident. Use 'aliasing' or
+ * 'via_memory' if you have a cell or operand you want in memory for a very
+ * short period of time (the time spent by the code generated by the thunk).
+ *)
+
+ and alias (cell:Il.cell) : Il.cell =
+ let mem, ty = need_mem_cell cell in
+ let vreg_cell = next_vreg_cell (Il.AddrTy ty) in
+ begin
+ match ty with
+ Il.NilTy -> ()
+ | _ -> lea vreg_cell mem
+ end;
+ vreg_cell
+
+ and force_to_mem (src:Il.operand) : Il.typed_mem =
+ let do_spill op (t:Il.scalar_ty) =
+ let spill = next_spill_cell t in
+ mov spill op;
+ need_mem_cell spill
+ in
+ match src with
+ Il.Cell (Il.Mem ta) -> ta
+ | Il.Cell (Il.Reg (_, t)) -> do_spill src t
+ | Il.Imm _ -> do_spill src (Il.ValTy word_bits)
+ | Il.ImmPtr (f, rty) ->
+ do_spill
+ (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
+ (Il.AddrTy rty)
+
+ and force_to_reg (op:Il.operand) : Il.typed_reg =
+ let do_mov op st =
+ let tmp = next_vreg () in
+ let regty = (tmp, st) in
+ mov (Il.Reg regty) op;
+ regty
+ in
+ match op with
+ Il.Imm (_, tm) -> do_mov op (Il.ValTy (Il.bits_of_ty_mach tm))
+ | Il.ImmPtr (f, rty) ->
+ do_mov
+ (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
+ (Il.AddrTy rty)
+ | Il.Cell (Il.Reg rt) -> rt
+ | Il.Cell (Il.Mem (_, Il.ScalarTy st)) -> do_mov op st
+ | Il.Cell (Il.Mem (_, rt)) ->
+ bug () "forcing non-scalar referent of type %s to register"
+ (Il.string_of_referent_ty rt)
+
+ and via_memory (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
+ match c with
+ Il.Mem _ -> thunk c
+ | Il.Reg _ ->
+ let mem_c = Il.Mem (force_to_mem (Il.Cell c)) in
+ thunk mem_c;
+ if writeback
+ then
+ mov c (Il.Cell mem_c)
+
+ and aliasing (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
+ via_memory writeback c (fun c -> thunk (alias c))
+
+ and pointee_type (ptr:Il.cell) : Il.referent_ty =
+ match ptr with
+ Il.Reg (_, (Il.AddrTy rt)) -> rt
+ | Il.Mem (_, Il.ScalarTy (Il.AddrTy rt)) -> rt
+ | _ ->
+ bug () "taking pointee-type of non-address cell %s "
+ (cell_str ptr)
+
+ and deref (ptr:Il.cell) : Il.cell =
+ let (r, st) = force_to_reg (Il.Cell ptr) in
+ match st with
+ Il.AddrTy rt -> Il.Mem (based r, rt)
+ | _ -> bug () "dereferencing non-address cell of type %s "
+ (Il.string_of_scalar_ty st)
+
+ and deref_off (ptr:Il.cell) (off:Asm.expr64) : Il.cell =
+ let (r, st) = force_to_reg (Il.Cell ptr) in
+ match st with
+ Il.AddrTy rt -> Il.Mem (based_off r off, rt)
+ | _ -> bug () "offset-dereferencing non-address cell of type %s "
+ (Il.string_of_scalar_ty st)
+
+ and deref_imm (ptr:Il.cell) (imm:int64) : Il.cell =
+ deref_off ptr (Asm.IMM imm)
+
+ and tp_imm (imm:int64) : Il.cell =
+ deref_imm abi.Abi.abi_tp_cell imm
+ in
+
+
+ let make_tydesc_slots n =
+ Array.init n (fun _ -> interior_slot Ast.TY_type)
+ in
+
+ let cell_vreg_num (vr:(int option) ref) : int =
+ match !vr with
+ None ->
+ let v = (Il.next_vreg_num (emitter())) in
+ vr := Some v;
+ v
+ | Some v -> v
+ in
+
+ let slot_id_referent_type (slot_id:node_id) : Il.referent_ty =
+ slot_referent_type abi (referent_to_slot cx slot_id)
+ in
+
+ let caller_args_cell (args_rty:Il.referent_ty) : Il.cell =
+ Il.Mem (fp_imm out_mem_disp, args_rty)
+ in
+
+ let get_ty_param (ty_params:Il.cell) (param_idx:int) : Il.cell =
+ get_element_ptr ty_params param_idx
+ in
+
+ let get_ty_params_of_frame (fp:Il.reg) (n_params:int) : Il.cell =
+ let fn_ty = mk_simple_ty_fn [| |] in
+ let fn_rty = call_args_referent_type cx n_params fn_ty None in
+ let args_cell = Il.Mem (based_imm fp out_mem_disp, fn_rty) in
+ get_element_ptr args_cell Abi.calltup_elt_ty_params
+ in
+
+ let get_args_for_current_frame _ =
+ let curr_args_rty =
+ current_fn_args_rty (Some Il.OpaqueTy)
+ in
+ caller_args_cell curr_args_rty
+ in
+
+ let get_indirect_args_for_current_frame _ =
+ get_element_ptr (get_args_for_current_frame ())
+ Abi.calltup_elt_indirect_args
+ in
+
+ let get_iterator_args_for_current_frame _ =
+ get_element_ptr (get_args_for_current_frame ())
+ Abi.calltup_elt_iterator_args
+ in
+
+ let get_closure_for_current_frame _ =
+ let self_indirect_args =
+ get_indirect_args_for_current_frame ()
+ in
+ get_element_ptr self_indirect_args
+ Abi.indirect_args_elt_closure
+ in
+
+ let get_iter_block_fn_for_current_frame _ =
+ let self_iterator_args =
+ get_iterator_args_for_current_frame ()
+ in
+ let blk_fn = get_element_ptr self_iterator_args
+ Abi.iterator_args_elt_block_fn
+ in
+ ptr_cast blk_fn
+ (Il.ScalarTy (Il.AddrTy Il.CodeTy))
+ in
+
+ let get_iter_outer_frame_ptr_for_current_frame _ =
+ let self_iterator_args =
+ get_iterator_args_for_current_frame ()
+ in
+ get_element_ptr self_iterator_args
+ Abi.iterator_args_elt_outer_frame_ptr
+ in
+
+ let get_obj_for_current_frame _ =
+ deref (ptr_cast
+ (get_closure_for_current_frame ())
+ (Il.ScalarTy (Il.AddrTy (obj_closure_rty abi))))
+ in
+
+ let get_ty_params_of_current_frame _ : Il.cell =
+ let id = current_fn() in
+ let n_ty_params = n_item_ty_params cx id in
+ if item_is_obj_fn cx id
+ then
+ begin
+ let obj = get_obj_for_current_frame() in
+ let tydesc = get_element_ptr obj 1 in
+ let ty_params_ty = Ast.TY_tup (make_tydesc_slots n_ty_params) in
+ let ty_params_rty = referent_type abi ty_params_ty in
+ let ty_params =
+ 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))
+ in
+ deref ty_params
+ end
+
+ else
+ get_ty_params_of_frame abi.Abi.abi_fp_reg n_ty_params
+ in
+
+ let get_ty_param_in_current_frame (param_idx:int) : Il.cell =
+ get_ty_param (get_ty_params_of_current_frame()) param_idx
+ in
+
+ let linearize_ty_params (ty:Ast.ty) : (Ast.ty * Il.operand array) =
+ let htab = Hashtbl.create 0 in
+ let q = Queue.create () in
+ let base = ty_fold_rebuild (fun t -> t) in
+ let ty_fold_param (i, mut) =
+ let param = Ast.TY_param (i, mut) in
+ match htab_search htab param with
+ Some p -> p
+ | None ->
+ let p = Ast.TY_param (Hashtbl.length htab, mut) in
+ htab_put htab param p;
+ Queue.add (Il.Cell (get_ty_param_in_current_frame i)) q;
+ p
+ in
+ let fold =
+ { base with
+ ty_fold_param = ty_fold_param; }
+ in
+ let ty = fold_ty fold ty in
+ (ty, queue_to_arr q)
+ in
+
+ let has_parametric_types (t:Ast.ty) : bool =
+ let base = ty_fold_bool_or false in
+ let ty_fold_param _ =
+ true
+ in
+ let fold = { base with ty_fold_param = ty_fold_param } in
+ fold_ty fold t
+ in
+
+ let rec calculate_sz (ty_params:Il.cell) (size:size) : Il.operand =
+ iflog (fun _ -> annotate
+ (Printf.sprintf "calculating size %s"
+ (string_of_size size)));
+ let sub_sz = calculate_sz ty_params in
+ match htab_search (emitter_size_cache()) size with
+ Some op -> op
+ | _ ->
+ let res =
+ match size with
+ SIZE_fixed i -> imm i
+ | SIZE_fixup_mem_pos f -> Il.Imm (Asm.M_POS f, word_ty_mach)
+ | SIZE_fixup_mem_sz f -> Il.Imm (Asm.M_SZ f, word_ty_mach)
+
+ | SIZE_param_size i ->
+ let tydesc = deref (get_ty_param ty_params i) in
+ Il.Cell (get_element_ptr tydesc Abi.tydesc_field_size)
+
+ | SIZE_param_align i ->
+ let tydesc = deref (get_ty_param ty_params i) in
+ Il.Cell (get_element_ptr tydesc Abi.tydesc_field_align)
+
+ | SIZE_rt_neg a ->
+ let op_a = sub_sz a in
+ let tmp = next_vreg_cell word_ty in
+ emit (Il.unary Il.NEG tmp op_a);
+ Il.Cell tmp
+
+ | SIZE_rt_add (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ add tmp op_a op_b;
+ Il.Cell tmp
+
+ | SIZE_rt_mul (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ emit (Il.binary Il.UMUL tmp op_a op_b);
+ Il.Cell tmp
+
+ | SIZE_rt_max (a, b) ->
+ let op_a = sub_sz a in
+ let op_b = sub_sz b in
+ let tmp = next_vreg_cell word_ty in
+ mov tmp op_a;
+ emit (Il.cmp op_a op_b);
+ let jmp = mark () in
+ emit (Il.jmp Il.JAE Il.CodeNone);
+ mov tmp op_b;
+ patch jmp;
+ Il.Cell tmp
+
+ | SIZE_rt_align (align, off) ->
+ (*
+ * calculate off + pad where:
+ *
+ * pad = (align - (off mod align)) mod align
+ *
+ * In our case it's always a power of two,
+ * so we can just do:
+ *
+ * mask = align-1
+ * off += mask
+ * off &= ~mask
+ *
+ *)
+ annotate "fetch alignment";
+ let op_align = sub_sz align in
+ annotate "fetch offset";
+ let op_off = sub_sz off in
+ let mask = next_vreg_cell word_ty in
+ let off = next_vreg_cell word_ty in
+ mov mask op_align;
+ sub_from mask one;
+ mov off op_off;
+ add_to off (Il.Cell mask);
+ emit (Il.unary Il.NOT mask (Il.Cell mask));
+ emit (Il.binary Il.AND
+ off (Il.Cell off) (Il.Cell mask));
+ Il.Cell off
+ in
+ iflog (fun _ -> annotate
+ (Printf.sprintf "calculated size %s is %s"
+ (string_of_size size)
+ (oper_str res)));
+ htab_put (emitter_size_cache()) size res;
+ res
+
+
+ and calculate_sz_in_current_frame (size:size) : Il.operand =
+ calculate_sz (get_ty_params_of_current_frame()) size
+
+ and callee_args_cell (tail_area:bool) (args_rty:Il.referent_ty) : Il.cell =
+ if tail_area
+ then
+ Il.Mem (sp_off_sz (current_fn_callsz ()), args_rty)
+ else
+ Il.Mem (sp_imm 0L, args_rty)
+
+ and based_sz (ty_params:Il.cell) (reg:Il.reg) (size:size) : Il.mem =
+ match Il.size_to_expr64 size with
+ Some e -> based_off reg e
+ | None ->
+ let runtime_size = calculate_sz ty_params size in
+ let v = next_vreg () in
+ let c = (Il.Reg (v, word_ty)) in
+ mov c (Il.Cell (Il.Reg (reg, word_ty)));
+ add_to c runtime_size;
+ based v
+
+ and fp_off_sz (size:size) : Il.mem =
+ based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_fp_reg size
+
+ and sp_off_sz (size:size) : Il.mem =
+ based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_sp_reg size
+ in
+
+ let slot_sz_in_current_frame (slot:Ast.slot) : Il.operand =
+ let rty = slot_referent_type abi slot in
+ let sz = Il.referent_ty_size word_bits rty in
+ calculate_sz_in_current_frame sz
+ in
+
+ let slot_sz_with_ty_params
+ (ty_params:Il.cell)
+ (slot:Ast.slot)
+ : Il.operand =
+ let rty = slot_referent_type abi slot in
+ let sz = Il.referent_ty_size word_bits rty in
+ calculate_sz ty_params sz
+ in
+
+ let get_element_ptr_dyn
+ (ty_params:Il.cell)
+ (mem_cell:Il.cell)
+ (i:int)
+ : Il.cell =
+ match mem_cell with
+ Il.Mem (mem, Il.StructTy elts)
+ when i >= 0 && i < (Array.length elts) ->
+ assert ((Array.length elts) != 0);
+ begin
+ let elt_rty = elts.(i) in
+ let elt_off = Il.get_element_offset word_bits elts i in
+ match elt_off with
+ SIZE_fixed fixed_off ->
+ Il.Mem (Il.mem_off_imm mem fixed_off, elt_rty)
+ | sz ->
+ let sz = calculate_sz ty_params sz in
+ let v = next_vreg word_ty in
+ let vc = Il.Reg (v, word_ty) in
+ lea vc mem;
+ add_to vc sz;
+ Il.Mem (based v, elt_rty)
+ end
+ | _ -> bug () "get_element_ptr_dyn %d on cell %s" i
+ (cell_str mem_cell)
+ in
+
+ let get_element_ptr_dyn_in_current_frame
+ (mem_cell:Il.cell)
+ (i:int)
+ : Il.cell =
+ get_element_ptr_dyn (get_ty_params_of_current_frame()) mem_cell i
+ in
+
+ let get_explicit_args_for_current_frame _ =
+ get_element_ptr_dyn_in_current_frame (get_args_for_current_frame ())
+ Abi.calltup_elt_args
+ in
+
+
+ let deref_off_sz
+ (ty_params:Il.cell)
+ (ptr:Il.cell)
+ (size:size)
+ : Il.cell =
+ match Il.size_to_expr64 size with
+ Some e -> deref_off ptr e
+ | None ->
+ let (r,_) = force_to_reg (Il.Cell ptr) in
+ let mem = based_sz ty_params r size in
+ Il.Mem (mem, (pointee_type ptr))
+ in
+
+ let cell_of_block_slot
+ (slot_id:node_id)
+ : Il.cell =
+ let referent_type = slot_id_referent_type slot_id in
+ match htab_search cx.ctxt_slot_vregs slot_id with
+ Some vr ->
+ begin
+ match referent_type with
+ Il.ScalarTy st -> Il.Reg (Il.Vreg (cell_vreg_num vr), st)
+ | Il.NilTy -> nil_ptr
+ | Il.StructTy _ -> bugi cx slot_id
+ "cannot treat structured referent as single operand"
+ | Il.UnionTy _ -> bugi cx slot_id
+ "cannot treat union referent as single operand"
+ | Il.ParamTy _ -> bugi cx slot_id
+ "cannot treat parametric referent as single operand"
+ | Il.OpaqueTy -> bugi cx slot_id
+ "cannot treat opaque referent as single operand"
+ | Il.CodeTy -> bugi cx slot_id
+ "cannot treat code referent as single operand"
+ end
+ | None ->
+ begin
+ match htab_search cx.ctxt_slot_offsets slot_id with
+ None -> bugi cx slot_id
+ "slot assigned to neither vreg nor offset"
+ | Some off ->
+ if slot_is_obj_state cx slot_id
+ then
+ begin
+ let state_arg = get_closure_for_current_frame () in
+ let (slot_mem, _) =
+ need_mem_cell (deref_off_sz
+ (get_ty_params_of_current_frame())
+ state_arg off)
+ in
+ Il.Mem (slot_mem, referent_type)
+ end
+ else
+ if (Stack.is_empty curr_stmt)
+ then
+ Il.Mem (fp_off_sz off, referent_type)
+ else
+ let slot_depth = get_slot_depth cx slot_id in
+ let stmt_depth =
+ get_stmt_depth cx (Stack.top curr_stmt)
+ in
+ if slot_depth <> stmt_depth
+ then
+ let _ = assert (slot_depth < stmt_depth) in
+ let _ =
+ iflog
+ begin
+ fun _ ->
+ let k =
+ Hashtbl.find cx.ctxt_slot_keys slot_id
+ in
+ annotate
+ (Printf.sprintf
+ "access outer frame slot #%d = %s"
+ (int_of_node slot_id)
+ (Ast.fmt_to_str
+ Ast.fmt_slot_key k))
+ end
+ in
+ let diff = stmt_depth - slot_depth in
+ let _ = annotate "get outer frame pointer" in
+ let fp =
+ get_iter_outer_frame_ptr_for_current_frame ()
+ in
+ if diff > 1
+ then
+ bug () "unsupported nested for each loop";
+ for i = 2 to diff do
+ (* FIXME: access outer caller-block fps,
+ * given nearest caller-block fp.
+ *)
+ let _ =
+ annotate "step to outer-outer frame"
+ in
+ mov fp (Il.Cell fp)
+ done;
+ let _ = annotate "calculate size" in
+ let p =
+ based_sz (get_ty_params_of_current_frame())
+ (fst (force_to_reg (Il.Cell fp))) off
+ in
+ Il.Mem (p, referent_type)
+ else
+ Il.Mem (fp_off_sz off, referent_type)
+ end
+ in
+
+ let binop_to_jmpop (binop:Ast.binop) : Il.jmpop =
+ match binop with
+ Ast.BINOP_eq -> Il.JE
+ | Ast.BINOP_ne -> Il.JNE
+ | Ast.BINOP_lt -> Il.JL
+ | Ast.BINOP_le -> Il.JLE
+ | Ast.BINOP_ge -> Il.JGE
+ | Ast.BINOP_gt -> Il.JG
+ | _ -> bug () "Unhandled binop in binop_to_jmpop"
+ in
+
+ let get_vtbl_entry_idx (table_ptr:Il.cell) (i:int) : Il.cell =
+ (* Vtbls are encoded as tables of table-relative displacements. *)
+ let (table_mem, _) = need_mem_cell (deref table_ptr) in
+ let disp = Il.Cell (word_at (Il.mem_off_imm table_mem (word_n i))) in
+ let ptr_cell = next_vreg_cell (Il.AddrTy Il.CodeTy) in
+ mov ptr_cell (Il.Cell table_ptr);
+ add_to ptr_cell disp;
+ ptr_cell
+ in
+
+ let get_vtbl_entry
+ (obj_cell:Il.cell)
+ (obj_ty:Ast.ty_obj)
+ (id:Ast.ident)
+ : (Il.cell * Ast.ty_fn) =
+ let (_, fns) = obj_ty in
+ let sorted_idents = sorted_htab_keys fns in
+ let i = arr_idx sorted_idents id in
+ let fn_ty = Hashtbl.find fns id in
+ let table_ptr = get_element_ptr obj_cell Abi.binding_field_item in
+ (get_vtbl_entry_idx table_ptr i, fn_ty)
+ in
+
+ let rec trans_slot_lval_ext
+ (base_ty:Ast.ty)
+ (cell:Il.cell)
+ (comp:Ast.lval_component)
+ : (Il.cell * Ast.slot) =
+
+ let bounds_checked_access at slot =
+ let atop = trans_atom at in
+ let unit_sz = slot_sz_in_current_frame slot in
+ let idx = next_vreg_cell word_ty in
+ emit (Il.binary Il.UMUL idx atop unit_sz);
+ let elt_mem = trans_bounds_check (deref cell) (Il.Cell idx) in
+ (Il.Mem (elt_mem, slot_referent_type abi slot), slot)
+ in
+
+ match (base_ty, comp) with
+ (Ast.TY_rec entries,
+ Ast.COMP_named (Ast.COMP_ident id)) ->
+ let i = arr_idx (Array.map fst entries) id in
+ (get_element_ptr_dyn_in_current_frame cell i, snd entries.(i))
+
+ | (Ast.TY_tup entries,
+ Ast.COMP_named (Ast.COMP_idx i)) ->
+ (get_element_ptr_dyn_in_current_frame cell i, entries.(i))
+
+ | (Ast.TY_vec slot,
+ Ast.COMP_atom at) ->
+ bounds_checked_access at slot
+
+ | (Ast.TY_str,
+ Ast.COMP_atom at) ->
+ bounds_checked_access at (interior_slot (Ast.TY_mach TY_u8))
+
+ | (Ast.TY_obj obj_ty,
+ Ast.COMP_named (Ast.COMP_ident id)) ->
+ let (cell, fn_ty) = get_vtbl_entry cell obj_ty id in
+ (cell, (interior_slot (Ast.TY_fn fn_ty)))
+
+
+ | _ -> bug () "unhandled form of lval_ext in trans_slot_lval_ext"
+
+ (*
+ * vec: operand holding ptr to vec.
+ * mul_idx: index value * unit size.
+ * return: ptr to element.
+ *)
+ and trans_bounds_check (vec:Il.cell) (mul_idx:Il.operand) : Il.mem =
+ let (len:Il.cell) = get_element_ptr vec Abi.vec_elt_fill in
+ let (data:Il.cell) = get_element_ptr vec Abi.vec_elt_data in
+ let (base:Il.cell) = next_vreg_cell Il.voidptr_t in
+ let (elt_reg:Il.reg) = next_vreg () in
+ let (elt:Il.cell) = Il.Reg (elt_reg, Il.voidptr_t) in
+ let (diff:Il.cell) = next_vreg_cell word_ty in
+ annotate "bounds check";
+ lea base (fst (need_mem_cell data));
+ add elt (Il.Cell base) mul_idx;
+ emit (Il.binary Il.SUB diff (Il.Cell elt) (Il.Cell base));
+ let jmp = trans_compare Il.JB (Il.Cell diff) (Il.Cell len) in
+ trans_cond_fail "bounds check" jmp;
+ based elt_reg
+
+ and trans_lval_full
+ (initializing:bool)
+ (lv:Ast.lval)
+ : (Il.cell * Ast.slot) =
+
+ let rec trans_slot_lval_full (initializing:bool) lv =
+ let (cell, slot) =
+ match lv with
+ Ast.LVAL_ext (base, comp) ->
+ let (base_cell, base_slot) =
+ trans_slot_lval_full initializing base
+ in
+ let base_cell' = deref_slot initializing base_cell base_slot in
+ trans_slot_lval_ext (slot_ty base_slot) base_cell' comp
+
+ | Ast.LVAL_base nb ->
+ let slot = lval_to_slot cx nb.id in
+ let referent = lval_to_referent cx nb.id in
+ let cell = cell_of_block_slot referent in
+ (cell, slot)
+ in
+ iflog
+ begin
+ fun _ ->
+ annotate
+ (Printf.sprintf "lval %a = %s"
+ Ast.sprintf_lval lv
+ (cell_str cell))
+ end;
+ (cell, slot)
+
+ in
+ if lval_is_slot cx lv
+ then trans_slot_lval_full initializing lv
+ else
+ if initializing
+ then err None "init item"
+ else
+ begin
+ assert (lval_is_item cx lv);
+ bug ()
+ "trans_lval_full called on item lval '%a'" Ast.sprintf_lval lv
+ end
+
+ and trans_lval_maybe_init
+ (initializing:bool)
+ (lv:Ast.lval)
+ : (Il.cell * Ast.slot) =
+ trans_lval_full initializing lv
+
+ and trans_lval_init (lv:Ast.lval) : (Il.cell * Ast.slot) =
+ trans_lval_maybe_init true lv
+
+ and trans_lval (lv:Ast.lval) : (Il.cell * Ast.slot) =
+ trans_lval_maybe_init false lv
+
+ and trans_callee
+ (flv:Ast.lval)
+ : (Il.operand * Ast.ty) =
+ (* direct call to item *)
+ let fty = Hashtbl.find cx.ctxt_all_lval_types (lval_base_id flv) in
+ if lval_is_item cx flv then
+ let fn_item = lval_item cx flv in
+ let fn_ptr = code_fixup_to_ptr_operand (get_fn_fixup cx fn_item.id) in
+ (fn_ptr, fty)
+ else
+ (* indirect call to computed slot *)
+ let (cell, _) = trans_lval flv in
+ (Il.Cell cell, fty)
+
+ and trans_crate_rel_data_operand
+ (d:data)
+ (thunk:unit -> Asm.frag)
+ : Il.operand =
+ let (fix, _) =
+ htab_search_or_add cx.ctxt_data d
+ begin
+ fun _ ->
+ let fix = new_fixup "data item" in
+ let frag = Asm.DEF (fix, thunk()) in
+ (fix, frag)
+ end
+ in
+ crate_rel_imm fix
+
+ and trans_crate_rel_data_frag (d:data) (thunk:unit -> Asm.frag) : Asm.frag =
+ let (fix, _) =
+ htab_search_or_add cx.ctxt_data d
+ begin
+ fun _ ->
+ let fix = new_fixup "data item" in
+ let frag = Asm.DEF (fix, thunk()) in
+ (fix, frag)
+ end
+ in
+ crate_rel_word fix
+
+ and trans_crate_rel_static_string_operand (s:string) : Il.operand =
+ trans_crate_rel_data_operand (DATA_str s) (fun _ -> Asm.ZSTRING s)
+
+ and trans_crate_rel_static_string_frag (s:string) : Asm.frag =
+ trans_crate_rel_data_frag (DATA_str s) (fun _ -> Asm.ZSTRING s)
+
+ and trans_static_string (s:string) : Il.operand =
+ Il.Cell (crate_rel_to_ptr
+ (trans_crate_rel_static_string_operand s)
+ (referent_type abi Ast.TY_str))
+
+ and get_static_tydesc
+ (idopt:node_id option)
+ (t:Ast.ty)
+ (sz:int64)
+ (align:int64)
+ : Il.operand =
+ trans_crate_rel_data_operand
+ (DATA_tydesc t)
+ begin
+ fun _ ->
+ let tydesc_fixup = new_fixup "tydesc" in
+ log cx "tydesc for %a has sz=%Ld, align=%Ld"
+ Ast.sprintf_ty t sz align;
+ Asm.DEF
+ (tydesc_fixup,
+ Asm.SEQ
+ [|
+ Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ Asm.WORD (word_ty_mach, Asm.IMM sz);
+ Asm.WORD (word_ty_mach, Asm.IMM align);
+ table_of_fixup_rel_fixups tydesc_fixup
+ [|
+ get_copy_glue t None;
+ get_drop_glue t None;
+ get_free_glue t (slot_mem_ctrl (interior_slot t)) None;
+ get_mark_glue t None;
+ |];
+ (* Include any obj-dtor, if this is an obj and has one. *)
+ begin
+ match idopt with
+ None -> Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ | Some oid ->
+ begin
+ let g = GLUE_obj_drop oid in
+ match htab_search cx.ctxt_glue_code g with
+ Some code ->
+ fixup_rel_word
+ tydesc_fixup
+ code.code_fixup;
+ | None ->
+ Asm.WORD (word_ty_mach, Asm.IMM 0L);
+ end
+ end;
+ |])
+ end
+
+ and get_obj_vtbl (id:node_id) : Il.operand =
+ let obj =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item { Ast.decl_item=Ast.MOD_ITEM_obj obj} -> obj
+ | _ -> bug () "Trans.get_obj_vtbl on non-obj referent"
+ in
+ trans_crate_rel_data_operand (DATA_obj_vtbl id)
+ begin
+ fun _ ->
+ iflog (fun _ -> log cx "emitting %d-entry obj vtbl for %s"
+ (Hashtbl.length obj.Ast.obj_fns) (path_name()));
+ table_of_table_rel_fixups
+ (Array.map
+ begin
+ fun k ->
+ let fn = Hashtbl.find obj.Ast.obj_fns k in
+ get_fn_fixup cx fn.id
+ end
+ (sorted_htab_keys obj.Ast.obj_fns))
+ end
+
+
+ and trans_copy_forward_args (args_rty:Il.referent_ty) : unit =
+ let caller_args_cell = caller_args_cell args_rty in
+ let callee_args_cell = callee_args_cell false args_rty in
+ let (dst_reg, _) = force_to_reg (Il.Cell (alias callee_args_cell)) in
+ let (src_reg, _) = force_to_reg (Il.Cell (alias caller_args_cell)) in
+ let tmp_reg = next_vreg () in
+ let nbytes = force_sz (Il.referent_ty_size word_bits args_rty) in
+ abi.Abi.abi_emit_inline_memcpy (emitter())
+ nbytes dst_reg src_reg tmp_reg false;
+
+
+ and get_forwarding_obj_fn
+ (ident:Ast.ident)
+ (caller:Ast.ty_obj)
+ (callee:Ast.ty_obj)
+ : fixup =
+ (* Forwarding "glue" is not glue in the normal sense of being called with
+ * only Abi.worst_case_glue_call_args args; the functions are full-fleged
+ * obj fns like any other, and they perform a full call to the target
+ * obj. We just use the glue facility here to store the forwarding
+ * operators somewhere.
+ *)
+ let g = GLUE_forward (ident, caller, callee) in
+ let fix = new_fixup (glue_str cx g) in
+ let fty = Hashtbl.find (snd caller) ident in
+ let self_args_rty =
+ call_args_referent_type cx 0
+ (Ast.TY_fn fty) (Some (obj_closure_rty abi))
+ in
+ let callsz = Il.referent_ty_size word_bits self_args_rty in
+ let spill = new_fixup "forwarding fn spill" in
+ 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
+ (*
+ * Note: this is wrong. This assumes our closure is a vtbl,
+ * when in fact it is a pointer to a refcounted malloc slab
+ * containing an obj.
+ *)
+ let closure_cell =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+
+ let (callee_fn_cell, _) =
+ get_vtbl_entry closure_cell callee ident
+ in
+ iflog (fun _ -> annotate "copy args forward to callee");
+ trans_copy_forward_args self_args_rty;
+
+ iflog (fun _ -> annotate "call through to callee");
+ (* FIXME: use a tail-call here. *)
+ call_code (code_of_cell callee_fn_cell);
+ trans_glue_frame_exit fix spill g;
+ fix
+
+
+ and get_forwarding_vtbl
+ (caller:Ast.ty_obj)
+ (callee:Ast.ty_obj)
+ : Il.operand =
+ trans_crate_rel_data_operand (DATA_forwarding_vtbl (caller,callee))
+ begin
+ fun _ ->
+ let (_,fns) = caller in
+ iflog (fun _ -> log cx "emitting %d-entry obj forwarding vtbl"
+ (Hashtbl.length fns));
+ table_of_table_rel_fixups
+ (Array.map
+ begin
+ fun k ->
+ get_forwarding_obj_fn k caller callee
+ end
+ (sorted_htab_keys fns))
+ end
+
+ 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
+ trans_upcall "upcall_new_str" dst [| static; imm init_sz |]
+
+ and trans_lit (lit:Ast.lit) : Il.operand =
+ match lit with
+ Ast.LIT_nil -> Il.Cell (nil_ptr)
+ | Ast.LIT_bool false -> imm_false
+ | Ast.LIT_bool true -> imm_true
+ | Ast.LIT_char c -> imm_of_ty (Int64.of_int c) TY_u32
+ | Ast.LIT_int (i, _) -> simm i
+ | Ast.LIT_uint (i, _) -> imm i
+ | Ast.LIT_mach (m, n, _) -> imm_of_ty n m
+
+ and trans_atom (atom:Ast.atom) : Il.operand =
+ iflog
+ begin
+ fun _ ->
+ annotate (Ast.fmt_to_str Ast.fmt_atom atom)
+ end;
+
+ match atom with
+ Ast.ATOM_lval lv ->
+ let (cell, slot) = trans_lval lv in
+ Il.Cell (deref_slot false cell slot)
+
+ | Ast.ATOM_literal lit -> trans_lit lit.node
+
+ and fixup_to_ptr_operand
+ (imm_ok:bool)
+ (fix:fixup)
+ (referent_ty:Il.referent_ty)
+ : Il.operand =
+ if imm_ok
+ then Il.ImmPtr (fix, referent_ty)
+ else Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) referent_ty)
+
+ and code_fixup_to_ptr_operand (fix:fixup) : Il.operand =
+ fixup_to_ptr_operand abi.Abi.abi_has_pcrel_code fix Il.CodeTy
+
+ (* A pointer-valued op may be of the form ImmPtr, which carries its
+ * target fixup, "constant-propagated" through trans so that
+ * pc-relative addressing can make use of it whenever
+ * appropriate. Reify_ptr exists for cases when you are about to
+ * store an ImmPtr into a memory cell or other place beyond which the
+ * compiler will cease to know about its identity; at this point you
+ * should decay it to a crate-relative displacement and
+ * (computationally) add it to the crate base value, before working
+ * with it.
+ *
+ * This helps you obey the IL type-system prohibition against
+ * 'mov'-ing an ImmPtr to a cell. If you forget to call this
+ * in the right places, you will get code-generation failures.
+ *)
+ and reify_ptr (op:Il.operand) : Il.operand =
+ match op with
+ Il.ImmPtr (fix, rty) ->
+ Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) rty)
+ | _ -> op
+
+ and annotate_quads (name:string) : unit =
+ let e = emitter() in
+ let quads = emitted_quads e in
+ let annotations = annotations() in
+ log cx "emitted quads for %s:" name;
+ for i = 0 to arr_max quads
+ do
+ if Hashtbl.mem annotations i
+ then
+ List.iter
+ (fun a -> log cx "// %s" a)
+ (List.rev (Hashtbl.find_all annotations i));
+ log cx "[%6d]\t%s" i
+ (Il.string_of_quad
+ abi.Abi.abi_str_of_hardreg quads.(i));
+ done
+
+
+ and write_frame_info_ptrs (fnid:node_id option) =
+ let frame_fns =
+ match fnid with
+ None -> zero
+ | Some fnid -> get_frame_glue_fns fnid
+ in
+ let crate_ptr_reg = next_vreg () in
+ let crate_ptr_cell = Il.Reg (crate_ptr_reg, (Il.AddrTy Il.OpaqueTy)) in
+ iflog (fun _ -> annotate "write frame-info pointers");
+ Abi.load_fixup_addr (emitter())
+ crate_ptr_reg cx.ctxt_crate_fixup Il.OpaqueTy;
+ mov (word_at (fp_imm frame_crate_ptr)) (Il.Cell (crate_ptr_cell));
+ mov (word_at (fp_imm frame_fns_disp)) frame_fns
+
+ and check_interrupt_flag _ =
+ let wordptr_ty = Il.AddrTy (Il.ScalarTy word_ty) in
+ let dom = next_vreg_cell wordptr_ty in
+ let flag = next_vreg_cell word_ty in
+ mov dom (Il.Cell (tp_imm (word_n Abi.task_field_dom)));
+ mov flag (Il.Cell (deref_imm dom
+ (word_n Abi.dom_field_interrupt_flag)));
+ let null_jmp = null_check flag in
+ trans_yield ();
+ patch null_jmp
+
+ and trans_glue_frame_entry
+ (callsz:size)
+ (spill:fixup)
+ : unit =
+ let framesz = SIZE_fixup_mem_sz spill in
+ push_new_emitter_with_vregs None;
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ check_interrupt_flag ();
+ iflog (fun _ -> annotate "finished prologue");
+
+ and emitted_quads e =
+ Array.sub e.Il.emit_quads 0 e.Il.emit_pc
+
+ and capture_emitted_glue (fix:fixup) (spill:fixup) (g:glue) : unit =
+ let e = emitter() in
+ iflog (fun _ -> annotate_quads (glue_str cx g));
+ let code = { code_fixup = fix;
+ code_quads = emitted_quads e;
+ code_vregs_and_spill = Some (Il.num_vregs e, spill); }
+ in
+ htab_put cx.ctxt_glue_code g code
+
+ and trans_glue_frame_exit (fix:fixup) (spill:fixup) (g:glue) : unit =
+ iflog (fun _ -> annotate "epilogue");
+ abi.Abi.abi_emit_fn_epilogue (emitter());
+ capture_emitted_glue fix spill g;
+ pop_emitter ()
+
+ and emit_exit_task_glue (fix:fixup) (g:glue) : unit =
+ let name = glue_str cx g in
+ let spill = new_fixup (name ^ " spill") in
+ push_new_emitter_with_vregs None;
+ (*
+ * We return-to-here in a synthetic frame we did not build; our job is
+ * merely to call upcall_exit.
+ *)
+ iflog (fun _ -> annotate "assume 'exited' state");
+ trans_void_upcall "upcall_exit" [| |];
+ capture_emitted_glue fix spill g;
+ pop_emitter ()
+
+ and get_exit_task_glue _ : fixup =
+ let g = GLUE_exit_task in
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None ->
+ let fix = cx.ctxt_exit_task_fixup in
+ 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_ty in
+ let targ = referent_type abi (mk_simple_ty_fn [||]) in
+ let bindings = Array.map (slot_referent_type abi) bs in
+ Il.StructTy [| rc; targ; Il.StructTy bindings |]
+
+ (* FIXME (issue #2): this should eventually use tail calling logic *)
+
+ and emit_fn_binding_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
+ (fun slot bound ->
+ if bound = want_bound then Some slot else None)
+ arg_slots
+ arg_bound_flags)
+ 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: binding type parameters doesn't work. *)
+ let self_args_rty =
+ call_args_referent_type cx 0 self_ty (Some self_closure_rty)
+ in
+ let callee_args_rty =
+ call_args_referent_type cx 0 callee_ty (Some Il.OpaqueTy)
+ in
+
+ let callsz = Il.referent_ty_size word_bits callee_args_rty in
+ let spill = new_fixup "bind glue spill" in
+ 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 =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+ let closure_target_cell =
+ get_element_ptr closure_cell Abi.binding_field_binding
+ in
+ let closure_target_fn_cell =
+ get_element_ptr closure_target_cell Abi.binding_field_item
+ in
+
+ merge_bound_args
+ self_args_rty callee_args_rty
+ arg_slots arg_bound_flags;
+ iflog (fun _ -> annotate "call through to closure target fn");
+
+ (*
+ * Closures, unlike first-class [disp,*binding] pairs, contain
+ * a fully-resolved target pointer, not a displacement. So we
+ * don't want to use callee_fn_ptr or the like to access the
+ * contents. We just call through the cell directly.
+ *)
+
+ call_code (code_of_cell closure_target_fn_cell);
+ trans_glue_frame_exit fix spill g
+
+
+ and get_fn_binding_glue
+ (bind_id:node_id)
+ (arg_slots:Ast.slot array)
+ (arg_bound_flags:bool array)
+ : fixup =
+ let g = GLUE_fn_binding 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;
+ fix
+
+
+ (*
+ * Mem-glue functions are either 'mark', 'drop' or 'free', they take
+ * one pointer arg and return nothing.
+ *)
+
+ and trans_mem_glue_frame_entry (n_outgoing_args:int) (spill:fixup) : unit =
+ let isz = cx.ctxt_abi.Abi.abi_implicit_args_sz in
+ let callsz = SIZE_fixed (Int64.add isz (word_n n_outgoing_args)) in
+ trans_glue_frame_entry callsz spill
+
+ and get_mem_glue (g:glue) (inner:Il.mem -> unit) : fixup =
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None ->
+ begin
+ let name = glue_str cx g in
+ let fix = new_fixup name in
+ (*
+ * Put a temporary code entry in the table to handle
+ * recursive emit calls during the generation of the glue
+ * function.
+ *)
+ let tmp_code = { code_fixup = fix;
+ code_quads = [| |];
+ code_vregs_and_spill = None; } in
+ let spill = new_fixup (name ^ " spill") in
+ htab_put cx.ctxt_glue_code g tmp_code;
+ log cx "emitting glue: %s" name;
+ trans_mem_glue_frame_entry Abi.worst_case_glue_call_args spill;
+ let (arg:Il.mem) = fp_imm arg0_disp in
+ inner arg;
+ Hashtbl.remove cx.ctxt_glue_code g;
+ trans_glue_frame_exit fix spill g;
+ fix
+ end
+
+ and get_typed_mem_glue
+ (g:glue)
+ (fty:Ast.ty)
+ (inner:Il.cell -> Il.cell -> unit)
+ : fixup =
+ get_mem_glue g
+ begin
+ fun _ ->
+ let n_ty_params = 0 in
+ let calltup_rty =
+ call_args_referent_type cx n_ty_params fty None
+ in
+ let calltup_cell = caller_args_cell calltup_rty in
+ let out_cell =
+ get_element_ptr calltup_cell Abi.calltup_elt_out_ptr
+ in
+ let args_cell =
+ get_element_ptr calltup_cell Abi.calltup_elt_args
+ in
+ begin
+ match Il.cell_referent_ty args_cell with
+ Il.StructTy az ->
+ assert ((Array.length az)
+ <= Abi.worst_case_glue_call_args);
+ | _ -> bug () "unexpected cell referent ty in glue args"
+ end;
+ inner out_cell args_cell
+ end
+
+ and trace_str b s =
+ if b
+ then
+ begin
+ let static = trans_static_string s in
+ trans_void_upcall "upcall_trace_str" [| static |]
+ end
+
+ and trace_word b w =
+ if b
+ then
+ trans_void_upcall "upcall_trace_word" [| Il.Cell w |]
+
+ and ty_params_covering (t:Ast.ty) : Ast.slot =
+ let n_ty_params = n_used_type_params t in
+ let params = make_tydesc_slots n_ty_params in
+ read_alias_slot (Ast.TY_tup params)
+
+ and get_drop_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_drop ty in
+ let inner _ (args:Il.cell) =
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ note_drop_step ty "in drop-glue, dropping";
+ trace_word cx.ctxt_sess.Session.sess_trace_drop cell;
+ drop_ty ty_params ty (deref cell) curr_iso;
+ note_drop_step ty "drop-glue complete";
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; read_alias_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_free_glue
+ (ty:Ast.ty)
+ (mctrl:mem_ctrl)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_free ty in
+ let inner _ (args:Il.cell) =
+ (*
+ * Free-glue assumes it's called with a pointer to an
+ * exterior allocation with normal exterior layout. It's
+ * just a way to move drop+free out of leaf code.
+ *)
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ let (body_mem, _) =
+ need_mem_cell
+ (get_element_ptr_dyn ty_params (deref cell)
+ Abi.exterior_rc_slot_field_body)
+ in
+ let vr = next_vreg_cell Il.voidptr_t in
+ lea vr body_mem;
+ note_drop_step ty "in free-glue, calling drop-glue on body";
+ trace_word cx.ctxt_sess.Session.sess_trace_drop vr;
+ trans_call_simple_static_glue
+ (get_drop_glue ty curr_iso) ty_params vr;
+ note_drop_step ty "back in free-glue, calling free";
+ if type_has_state ty
+ then
+ note_drop_step ty "type has state"
+ else
+ note_drop_step ty "type has no state";
+ if mctrl = MEM_gc
+ then
+ begin
+ note_drop_step ty "MEM_gc, adjusting pointer";
+ lea vr (fst (need_mem_cell (deref cell)));
+ emit (Il.binary Il.SUB vr (Il.Cell vr)
+ (imm
+ (word_n Abi.exterior_gc_malloc_return_adjustment)));
+ trans_free vr
+ end
+ else
+ begin
+ note_drop_step ty "not MEM_gc";
+ trans_free cell;
+ end;
+ trace_str cx.ctxt_sess.Session.sess_trace_drop
+ "free-glue complete";
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; exterior_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_mark_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_mark ty in
+ let inner _ (args:Il.cell) =
+ let ty_params = deref (get_element_ptr args 0) in
+ let cell = get_element_ptr args 1 in
+ mark_ty ty_params ty (deref cell) curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty = mk_simple_ty_fn [| ty_params_ptr; read_alias_slot ty |] in
+ get_typed_mem_glue g fty inner
+
+
+ and get_clone_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_clone ty in
+ let inner (out_ptr:Il.cell) (args:Il.cell) =
+ let dst = deref out_ptr in
+ let ty_params = deref (get_element_ptr args 0) in
+ let src = deref (get_element_ptr args 1) in
+ let clone_task = get_element_ptr args 2 in
+ clone_ty ty_params clone_task ty dst src curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty =
+ mk_ty_fn
+ (interior_slot ty) (* dst *)
+ [|
+ ty_params_ptr;
+ read_alias_slot ty; (* src *)
+ word_slot (* clone-task *)
+ |]
+ in
+ get_typed_mem_glue g fty inner
+
+
+ and get_copy_glue
+ (ty:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : fixup =
+ let g = GLUE_copy ty in
+ let inner (out_ptr:Il.cell) (args:Il.cell) =
+ let dst = deref out_ptr in
+ let ty_params = deref (get_element_ptr args 0) in
+ let src = deref (get_element_ptr args 1) in
+ copy_ty ty_params ty dst src curr_iso
+ in
+ let ty_params_ptr = ty_params_covering ty in
+ let fty =
+ mk_ty_fn
+ (interior_slot ty)
+ [| ty_params_ptr; read_alias_slot ty |]
+ in
+ get_typed_mem_glue g fty inner
+
+
+ (* Glue functions use mostly the same calling convention as ordinary
+ * functions.
+ *
+ * Each glue function expects its own particular arguments, which are
+ * usually aliases-- ie, caller doesn't transfer ownership to the
+ * glue. And nothing is represented in terms of AST nodes. So we
+ * don't do lvals-and-atoms here.
+ *)
+
+ and trans_call_glue
+ (code:Il.code)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ let inner dst =
+ 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 (Il.Cell abi.Abi.abi_tp_cell));
+ emit (Il.Push dst);
+ call_code code;
+ pop ();
+ pop ();
+ Array.iter (fun _ -> pop()) args;
+ in
+ match dst with
+ None -> inner zero
+ | Some dst -> aliasing true dst (fun dst -> inner (Il.Cell dst))
+
+ and trans_call_static_glue
+ (callee:Il.operand)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ trans_call_glue (code_of_operand callee) dst args
+
+ and trans_call_dynamic_glue
+ (tydesc:Il.cell)
+ (idx:int)
+ (dst:Il.cell option)
+ (args:Il.cell array)
+ : unit =
+ let fptr = get_vtbl_entry_idx tydesc idx in
+ trans_call_glue (code_of_operand (Il.Cell fptr)) dst args
+
+ and trans_call_simple_static_glue
+ (fix:fixup)
+ (ty_params:Il.cell)
+ (arg:Il.cell)
+ : unit =
+ trans_call_static_glue
+ (code_fixup_to_ptr_operand fix)
+ None [| alias ty_params; arg |]
+
+ and get_tydesc_params
+ (outer_ty_params:Il.cell)
+ (td:Il.cell)
+ : Il.cell =
+ let first_param =
+ get_element_ptr (deref td) Abi.tydesc_field_first_param
+ in
+ let res = next_vreg_cell Il.voidptr_t in
+ mov res (Il.Cell (alias outer_ty_params));
+ emit (Il.cmp (Il.Cell first_param) zero);
+ let no_param_jmp = mark() in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ mov res (Il.Cell first_param);
+ patch no_param_jmp;
+ res
+
+ and trans_call_simple_dynamic_glue
+ (ty_param:int)
+ (vtbl_idx:int)
+ (ty_params:Il.cell)
+ (arg:Il.cell)
+ : unit =
+ iflog (fun _ ->
+ annotate (Printf.sprintf "calling tydesc[%d].glue[%d]"
+ ty_param vtbl_idx));
+ 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; |]
+
+ (* trans_compare returns a quad number of the cjmp, which the caller
+ patches to the cjmp destination. *)
+ and trans_compare
+ (cjmp:Il.jmpop)
+ (lhs:Il.operand)
+ (rhs:Il.operand)
+ : quad_idx list =
+ (* FIXME: this is an x86-ism; abstract via ABI. *)
+ emit (Il.cmp (Il.Cell (Il.Reg (force_to_reg lhs))) rhs);
+ let jmp = mark() in
+ emit (Il.jmp cjmp Il.CodeNone);
+ [jmp]
+
+ and trans_cond (invert:bool) (expr:Ast.expr) : quad_idx list =
+
+ let anno _ =
+ iflog
+ begin
+ fun _ ->
+ annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+ ": cond, finale")
+ end
+ in
+
+ match expr with
+ Ast.EXPR_binary (binop, a, b) ->
+ let lhs = trans_atom a in
+ let rhs = trans_atom b in
+ let cjmp = binop_to_jmpop binop in
+ let cjmp' =
+ if invert then
+ match cjmp with
+ Il.JE -> Il.JNE
+ | Il.JNE -> Il.JE
+ | Il.JL -> Il.JGE
+ | Il.JLE -> Il.JG
+ | Il.JGE -> Il.JL
+ | Il.JG -> Il.JLE
+ | _ -> bug () "Unhandled inverse binop in trans_cond"
+ else
+ cjmp
+ in
+ anno ();
+ trans_compare cjmp' lhs rhs
+
+ | _ ->
+ let bool_operand = trans_expr expr in
+ anno ();
+ trans_compare Il.JNE bool_operand
+ (if invert then imm_true else imm_false)
+
+ and trans_binop (binop:Ast.binop) : Il.binop =
+ match binop with
+ Ast.BINOP_or -> Il.OR
+ | Ast.BINOP_and -> Il.AND
+ | Ast.BINOP_xor -> Il.XOR
+
+ | Ast.BINOP_lsl -> Il.LSL
+ | Ast.BINOP_lsr -> Il.LSR
+ | Ast.BINOP_asr -> Il.ASR
+
+ | Ast.BINOP_add -> Il.ADD
+ | Ast.BINOP_sub -> Il.SUB
+
+ (* FIXME (issue #57):
+ * switch on type of operands, IMUL/IDIV/IMOD etc.
+ *)
+ | Ast.BINOP_mul -> Il.UMUL
+ | Ast.BINOP_div -> Il.UDIV
+ | Ast.BINOP_mod -> Il.UMOD
+ | _ -> bug () "bad binop to Trans.trans_binop"
+
+ and trans_binary
+ (binop:Ast.binop)
+ (lhs:Il.operand)
+ (rhs:Il.operand) : Il.operand =
+ let arith op =
+ let bits = Il.operand_bits word_bits lhs in
+ let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
+ emit (Il.binary op dst lhs rhs);
+ Il.Cell dst
+ in
+ match binop with
+ Ast.BINOP_or | Ast.BINOP_and | Ast.BINOP_xor
+ | Ast.BINOP_lsl | Ast.BINOP_lsr | Ast.BINOP_asr
+ | Ast.BINOP_add | Ast.BINOP_sub
+ (* FIXME (issue #57):
+ * switch on type of operands, IMUL/IDIV/IMOD etc.
+ *)
+ | Ast.BINOP_mul | Ast.BINOP_div | Ast.BINOP_mod ->
+ arith (trans_binop binop)
+
+ | _ -> let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy Il.Bits8) in
+ mov dst imm_true;
+ let jmps = trans_compare (binop_to_jmpop binop) lhs rhs in
+ mov dst imm_false;
+ List.iter patch jmps;
+ Il.Cell dst
+
+
+ and trans_expr (expr:Ast.expr) : Il.operand =
+
+ let anno _ =
+ iflog
+ begin
+ fun _ ->
+ annotate ((Ast.fmt_to_str Ast.fmt_expr expr) ^
+ ": plain exit, finale")
+ end
+ in
+ match expr with
+ Ast.EXPR_binary (binop, a, b) ->
+ assert (is_prim_type (atom_type cx a));
+ assert (is_prim_type (atom_type cx b));
+ trans_binary binop (trans_atom a) (trans_atom b)
+
+ | Ast.EXPR_unary (unop, a) ->
+ assert (is_prim_type (atom_type cx a));
+ let src = trans_atom a in
+ let bits = Il.operand_bits word_bits src in
+ let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
+ let op = match unop with
+ Ast.UNOP_not
+ | Ast.UNOP_bitnot -> Il.NOT
+ | Ast.UNOP_neg -> Il.NEG
+ | Ast.UNOP_cast t ->
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ let at = atom_type cx a in
+ if (type_is_2s_complement at) &&
+ (type_is_2s_complement t)
+ then
+ if type_is_unsigned_2s_complement t
+ then Il.UMOV
+ else Il.IMOV
+ else
+ err None "unsupported cast operator"
+ in
+ anno ();
+ emit (Il.unary op dst src);
+ Il.Cell dst
+
+ | Ast.EXPR_atom a ->
+ trans_atom a
+
+ and trans_block (block:Ast.block) : unit =
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "entering block";
+ push_emitter_size_cache ();
+ emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups block.id));
+ Array.iter trans_stmt block.node;
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "exiting block";
+ emit Il.Leave;
+ pop_emitter_size_cache ();
+ trace_str cx.ctxt_sess.Session.sess_trace_block
+ "exited block";
+
+ and upcall_fixup (name:string) : fixup =
+ Semant.require_native cx REQUIRED_LIB_rustrt name;
+
+ and trans_upcall
+ (name:string)
+ (ret:Il.cell)
+ (args:Il.operand array)
+ : unit =
+ abi.Abi.abi_emit_native_call (emitter())
+ ret nabi_rust (upcall_fixup name) args;
+
+ and trans_void_upcall
+ (name:string)
+ (args:Il.operand array)
+ : unit =
+ abi.Abi.abi_emit_native_void_call (emitter())
+ nabi_rust (upcall_fixup name) args;
+
+ and trans_log_int (a:Ast.atom) : unit =
+ trans_void_upcall "upcall_log_int" [| (trans_atom a) |]
+
+ and trans_log_str (a:Ast.atom) : unit =
+ trans_void_upcall "upcall_log_str" [| (trans_atom a) |]
+
+ and trans_spawn
+ ((*initializing*)_:bool)
+ (dst:Ast.lval)
+ (domain:Ast.domain)
+ (fn_lval:Ast.lval)
+ (args:Ast.atom array)
+ : unit =
+ let (task_cell, _) = trans_lval_init dst in
+ let (fptr_operand, fn_ty) = trans_callee fn_lval in
+ (*let fn_ty_params = [| |] in*)
+ let _ =
+ (* FIXME: handle indirect-spawns (clone closure). *)
+ if not (lval_is_direct_fn cx fn_lval)
+ then bug () "unhandled indirect-spawn"
+ in
+ let args_rty = call_args_referent_type cx 0 fn_ty None in
+ let fptr_operand = reify_ptr fptr_operand in
+ let exit_task_glue_fixup = get_exit_task_glue () in
+ let callsz =
+ calculate_sz_in_current_frame (Il.referent_ty_size word_bits args_rty)
+ in
+ let exit_task_glue_fptr =
+ code_fixup_to_ptr_operand exit_task_glue_fixup
+ in
+ let exit_task_glue_fptr = reify_ptr exit_task_glue_fptr in
+
+ iflog (fun _ -> annotate "spawn task: copy args");
+
+ let new_task = next_vreg_cell Il.voidptr_t in
+ let call = { call_ctrl = CALL_indirect;
+ call_callee_ptr = fptr_operand;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = [| |];
+ call_output = task_cell;
+ call_args = args;
+ call_iterator_args = [| |];
+ call_indirect_args = [| |] }
+ in
+ match domain with
+ Ast.DOMAIN_thread ->
+ begin
+ trans_upcall "upcall_new_thread" new_task [| |];
+ copy_fn_args false (CLONE_all new_task) call;
+ trans_upcall "upcall_start_thread" task_cell
+ [|
+ Il.Cell new_task;
+ exit_task_glue_fptr;
+ fptr_operand;
+ callsz
+ |];
+ end
+ | _ ->
+ begin
+ trans_upcall "upcall_new_task" new_task [| |];
+ copy_fn_args false (CLONE_chan new_task) call;
+ trans_upcall "upcall_start_task" task_cell
+ [|
+ Il.Cell new_task;
+ exit_task_glue_fptr;
+ fptr_operand;
+ callsz
+ |];
+ end;
+ ()
+
+ and get_curr_span _ =
+ if Stack.is_empty curr_stmt
+ then ("<none>", 0, 0)
+ else
+ let stmt_id = Stack.top curr_stmt in
+ match (Session.get_span cx.ctxt_sess stmt_id) with
+ None -> ("<none>", 0, 0)
+ | Some sp -> sp.lo
+
+ and trans_cond_fail (str:string) (fwd_jmps:quad_idx list) : unit =
+ let (filename, line, _) = get_curr_span () in
+ iflog (fun _ -> annotate ("condition-fail: " ^ str));
+ trans_void_upcall "upcall_fail"
+ [|
+ trans_static_string str;
+ trans_static_string filename;
+ imm (Int64.of_int line)
+ |];
+ List.iter patch fwd_jmps
+
+ and trans_check_expr (e:Ast.expr) : unit =
+ let fwd_jmps = trans_cond false e in
+ trans_cond_fail (Ast.fmt_to_str Ast.fmt_expr e) fwd_jmps
+
+ and trans_malloc (dst:Il.cell) (nbytes:Il.operand) : unit =
+ trans_upcall "upcall_malloc" dst [| nbytes |]
+
+ and trans_free (src:Il.cell) : unit =
+ trans_void_upcall "upcall_free" [| Il.Cell src |]
+
+ and trans_yield () : unit =
+ trans_void_upcall "upcall_yield" [| |];
+
+ and trans_fail () : unit =
+ let (filename, line, _) = get_curr_span () in
+ trans_void_upcall "upcall_fail"
+ [|
+ trans_static_string "explicit failure";
+ trans_static_string filename;
+ imm (Int64.of_int line)
+ |];
+
+ and trans_join (task:Ast.lval) : unit =
+ trans_void_upcall "upcall_join" [| trans_atom (Ast.ATOM_lval task) |]
+
+ and trans_send (chan:Ast.lval) (src:Ast.lval) : unit =
+ let (srccell, _) = trans_lval src in
+ aliasing false srccell
+ begin
+ fun src_alias ->
+ trans_void_upcall "upcall_send"
+ [| trans_atom (Ast.ATOM_lval chan);
+ Il.Cell src_alias |];
+ end
+
+ and trans_recv (initializing:bool) (dst:Ast.lval) (chan:Ast.lval) : unit =
+ let (dstcell, _) = trans_lval_maybe_init initializing dst in
+ aliasing true dstcell
+ begin
+ fun dst_alias ->
+ trans_void_upcall "upcall_recv"
+ [| Il.Cell dst_alias;
+ trans_atom (Ast.ATOM_lval chan) |];
+ end
+
+ and trans_init_port (dst:Ast.lval) : unit =
+ let (dstcell, dst_slot) = trans_lval_init dst in
+ let unit_ty = match slot_ty dst_slot with
+ Ast.TY_port t -> t
+ | _ -> bug () "init dst of port-init has non-port type"
+ in
+ let unit_sz = ty_sz abi unit_ty in
+ trans_upcall "upcall_new_port" dstcell [| imm unit_sz |]
+
+ and trans_del_port (port:Il.cell) : unit =
+ trans_void_upcall "upcall_del_port" [| Il.Cell port |]
+
+ and trans_init_chan (dst:Ast.lval) (port:Ast.lval) : unit =
+ let (dstcell, _) = trans_lval_init dst
+ in
+ trans_upcall "upcall_new_chan" dstcell
+ [| trans_atom (Ast.ATOM_lval port) |]
+
+ and trans_del_chan (chan:Il.cell) : unit =
+ trans_void_upcall "upcall_del_chan" [| Il.Cell chan |]
+
+ and trans_kill_task (task:Il.cell) : unit =
+ trans_void_upcall "upcall_kill" [| Il.Cell task |]
+
+ (*
+ * A vec is implicitly exterior: every slot vec[T] is 1 word and
+ * points to a refcounted structure. That structure has 3 words with
+ * defined meaning at the beginning; data follows the header.
+ *
+ * word 0: refcount or gc control word
+ * word 1: allocated size of data
+ * word 2: initialised size of data
+ * word 3...N: data
+ *
+ * This 3-word prefix is shared with strings, we factor the common
+ * part out for reuse in string code.
+ *)
+
+ and trans_init_vec (dst:Ast.lval) (atoms:Ast.atom array) : unit =
+ let (dst_cell, dst_slot) = trans_lval_init dst in
+ let unit_slot = match slot_ty dst_slot with
+ Ast.TY_vec s -> s
+ | _ -> bug () "init dst of vec-init has non-vec type"
+ in
+ let fill = next_vreg_cell word_ty in
+ let unit_sz = slot_sz_in_current_frame unit_slot in
+ umul fill unit_sz (imm (Int64.of_int (Array.length atoms)));
+ trans_upcall "upcall_new_vec" dst_cell [| Il.Cell fill |];
+ let vec = deref dst_cell in
+ let body_mem =
+ fst (need_mem_cell
+ (get_element_ptr_dyn_in_current_frame
+ vec Abi.vec_elt_data))
+ in
+ let unit_rty = slot_referent_type abi unit_slot in
+ let body_rty = Il.StructTy (Array.map (fun _ -> unit_rty) atoms) in
+ let body = Il.Mem (body_mem, body_rty) in
+ Array.iteri
+ begin
+ fun i atom ->
+ let cell = get_element_ptr_dyn_in_current_frame body i in
+ trans_init_slot_from_atom CLONE_none cell unit_slot atom
+ end
+ atoms;
+ mov (get_element_ptr vec Abi.vec_elt_fill) (Il.Cell fill);
+
+ and get_dynamic_tydesc (idopt:node_id option) (t:Ast.ty) : Il.cell =
+ let td = next_vreg_cell Il.voidptr_t in
+ let root_desc =
+ Il.Cell (crate_rel_to_ptr
+ (get_static_tydesc idopt t 0L 0L)
+ (tydesc_rty abi))
+ in
+ let (t, param_descs) = linearize_ty_params t in
+ let descs = Array.append [| root_desc |] param_descs in
+ let n = Array.length descs in
+ let rty = referent_type abi t in
+ let (size_sz, align_sz) = Il.referent_ty_layout word_bits rty in
+ let size = calculate_sz_in_current_frame size_sz in
+ let align = calculate_sz_in_current_frame align_sz in
+ let descs_ptr = next_vreg_cell Il.voidptr_t in
+ if (Array.length descs) > 0
+ then
+ (* FIXME: this relies on knowledge that spills are contiguous. *)
+ let spills =
+ Array.map (fun _ -> next_spill_cell Il.voidptr_t) descs
+ in
+ Array.iteri (fun i t -> mov spills.(n-(i+1)) t) descs;
+ lea descs_ptr (fst (need_mem_cell spills.(n-1)))
+ else
+ mov descs_ptr zero;
+ trans_upcall "upcall_get_type_desc" td
+ [| Il.Cell (curr_crate_ptr());
+ size; align; imm (Int64.of_int n);
+ Il.Cell descs_ptr |];
+ td
+
+ and get_tydesc (idopt:node_id option) (ty:Ast.ty) : Il.cell =
+ log cx "getting tydesc for %a" Ast.sprintf_ty ty;
+ match ty with
+ Ast.TY_param (idx, _) ->
+ (get_ty_param_in_current_frame idx)
+ | t when has_parametric_types t ->
+ (get_dynamic_tydesc idopt t)
+ | _ ->
+ (crate_rel_to_ptr (get_static_tydesc idopt ty
+ (ty_sz abi ty)
+ (ty_align abi ty))
+ (tydesc_rty abi))
+
+ and exterior_ctrl_cell (cell:Il.cell) (off:int) : Il.cell =
+ let (rc_mem, _) = need_mem_cell (deref_imm cell (word_n off)) in
+ word_at rc_mem
+
+ and exterior_rc_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_rc_slot_field_refcnt
+
+ and exterior_gc_ctrl_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_gc_slot_field_ctrl
+
+ and exterior_gc_next_cell (cell:Il.cell) : Il.cell =
+ exterior_ctrl_cell cell Abi.exterior_gc_slot_field_next
+
+ and exterior_allocation_size
+ (slot:Ast.slot)
+ : Il.operand =
+ let header_sz =
+ match slot_mem_ctrl slot with
+ MEM_gc -> word_n Abi.exterior_gc_header_size
+ | MEM_rc_opaque
+ | MEM_rc_struct -> word_n Abi.exterior_rc_header_size
+ | MEM_interior -> bug () "exterior_allocation_size of MEM_interior"
+ in
+ let t = slot_ty slot in
+ let refty_sz =
+ Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi t)
+ in
+ match refty_sz with
+ SIZE_fixed _ -> imm (Int64.add (ty_sz abi t) header_sz)
+ | _ ->
+ let ty_params = get_ty_params_of_current_frame() in
+ let refty_sz = calculate_sz ty_params refty_sz in
+ let v = next_vreg word_ty in
+ let vc = Il.Reg (v, word_ty) in
+ mov vc refty_sz;
+ add_to vc (imm header_sz);
+ Il.Cell vc;
+
+ and iter_tag_slots
+ (ty_params:Il.cell)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (ttag:Ast.ty_tag)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let tag_keys = sorted_htab_keys ttag in
+ let src_tag = get_element_ptr src_cell 0 in
+ let dst_tag = get_element_ptr dst_cell 0 in
+ let src_union = get_element_ptr_dyn ty_params src_cell 1 in
+ let dst_union = get_element_ptr_dyn ty_params dst_cell 1 in
+ let tmp = next_vreg_cell word_ty in
+ f dst_tag src_tag word_slot curr_iso;
+ mov tmp (Il.Cell src_tag);
+ Array.iteri
+ begin
+ fun i key ->
+ (iflog (fun _ ->
+ annotate (Printf.sprintf "tag case #%i == %a" i
+ Ast.sprintf_name key)));
+ let jmps =
+ trans_compare Il.JNE (Il.Cell tmp) (imm (Int64.of_int i))
+ in
+ let ttup = Hashtbl.find ttag key in
+ iter_tup_slots
+ (get_element_ptr_dyn ty_params)
+ (get_variant_ptr dst_union i)
+ (get_variant_ptr src_union i)
+ ttup f curr_iso;
+ List.iter patch jmps
+ end
+ tag_keys
+
+ and get_iso_tag tiso =
+ tiso.Ast.iso_group.(tiso.Ast.iso_index)
+
+
+ and seq_unit_slot (seq:Ast.ty) : Ast.slot =
+ match seq with
+ Ast.TY_vec s -> s
+ | Ast.TY_str -> (interior_slot (Ast.TY_mach TY_u8))
+ | _ -> bug () "seq_unit_slot of non-vec, non-str type"
+
+
+ and iter_seq_slots
+ (ty_params:Il.cell)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (unit_slot:Ast.slot)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let unit_sz = slot_sz_with_ty_params ty_params unit_slot in
+ (*
+ * Unlike most of the iter_ty_slots helpers; this one allocates a
+ * vreg and so has to be aware of when it's iterating over 2
+ * sequences of cells or just 1.
+ *)
+ check_exterior_rty src_cell;
+ check_exterior_rty dst_cell;
+ if dst_cell = src_cell
+ then
+ begin
+ let src_cell = deref src_cell in
+ let data =
+ get_element_ptr_dyn ty_params src_cell Abi.vec_elt_data
+ in
+ let len = get_element_ptr src_cell Abi.vec_elt_fill in
+ let ptr = next_vreg_cell Il.voidptr_t in
+ let lim = next_vreg_cell Il.voidptr_t in
+ lea lim (fst (need_mem_cell data));
+ mov ptr (Il.Cell lim);
+ add_to lim (Il.Cell len);
+ let back_jmp_target = mark () in
+ let fwd_jmps = trans_compare Il.JAE (Il.Cell ptr) (Il.Cell lim) in
+ let unit_cell =
+ deref (ptr_cast ptr (slot_referent_type abi unit_slot))
+ in
+ f unit_cell unit_cell unit_slot curr_iso;
+ add_to ptr unit_sz;
+ check_interrupt_flag ();
+ emit (Il.jmp Il.JMP (Il.CodeLabel back_jmp_target));
+ List.iter patch fwd_jmps;
+ end
+ else
+ begin
+ bug () "Unsupported form of seq iter: src != dst."
+ end
+
+
+ and iter_ty_slots_full
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (dst_cell:Il.cell)
+ (src_cell:Il.cell)
+ (f:Il.cell -> Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ (*
+ * FIXME: this will require some reworking if we support
+ * rec, tag or tup slots that fit in a vreg. It requires
+ * addrs presently.
+ *)
+ match ty with
+ Ast.TY_rec entries ->
+ iter_rec_slots
+ (get_element_ptr_dyn ty_params) dst_cell src_cell
+ entries f curr_iso
+
+ | Ast.TY_tup slots ->
+ iter_tup_slots
+ (get_element_ptr_dyn ty_params) dst_cell src_cell
+ slots f curr_iso
+
+ | Ast.TY_tag tag ->
+ iter_tag_slots ty_params dst_cell src_cell tag f curr_iso
+
+ | Ast.TY_iso tiso ->
+ let ttag = get_iso_tag tiso in
+ iter_tag_slots ty_params dst_cell src_cell ttag f (Some tiso)
+
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> bug () "Attempting to iterate over fn/pred/obj slots"
+
+ | Ast.TY_vec _
+ | Ast.TY_str ->
+ let unit_slot = seq_unit_slot ty in
+ iter_seq_slots ty_params dst_cell src_cell unit_slot f curr_iso
+
+ | _ -> ()
+
+ (*
+ * This just calls iter_ty_slots_full with your cell as both src and
+ * dst, with an adaptor function that discards the dst slots of the
+ * parallel traversal and and calls your provided function on the
+ * passed-in src slots.
+ *)
+ and iter_ty_slots
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (f:Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_ty_slots_full ty_params ty cell cell
+ (fun _ src_cell slot curr_iso -> f src_cell slot curr_iso)
+ curr_iso
+
+ and drop_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_param (i, _) ->
+ iflog (fun _ -> annotate
+ (Printf.sprintf "drop_ty: parametric drop %#d" i));
+ aliasing false cell
+ begin
+ fun cell ->
+ trans_call_simple_dynamic_glue
+ i Abi.tydesc_field_drop_glue ty_params cell
+ end
+
+ | Ast.TY_fn _ ->
+ begin
+ let binding = get_element_ptr cell Abi.binding_field_binding in
+ let null_jmp = null_check binding in
+ (* Drop non-null bindings. *)
+ (* FIXME (issue #58): this is completely wrong,
+ * need a second thunk that generates code to make
+ * use of a runtime type descriptor extracted from
+ * a binding tuple. For now this only works by
+ * accident.
+ *)
+ drop_slot ty_params binding
+ (exterior_slot Ast.TY_int) curr_iso;
+ patch null_jmp
+ end
+
+ | Ast.TY_obj _ ->
+ begin
+ let binding = get_element_ptr cell Abi.binding_field_binding in
+ let null_jmp = null_check 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 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. *)
+ trans_call_dynamic_glue tydesc
+ Abi.tydesc_field_obj_drop_glue None [| binding |];
+ patch null_dtor_jmp;
+ (* Drop the body. *)
+ trans_call_dynamic_glue tydesc
+ Abi.tydesc_field_drop_glue None [| ty_params; alias body |];
+ trans_free binding;
+ mov binding zero;
+ patch rc_jmp;
+ patch null_jmp
+ end
+
+
+ | _ ->
+ iter_ty_slots ty_params ty cell (drop_slot ty_params) curr_iso
+
+ and mark_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> ()
+ | _ ->
+ iter_ty_slots ty_params ty cell (mark_slot ty_params) curr_iso
+
+ and clone_ty
+ (ty_params:Il.cell)
+ (clone_task:Il.cell)
+ (ty:Ast.ty)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_chan _ ->
+ trans_upcall "upcall_clone_chan" dst
+ [| (Il.Cell clone_task); (Il.Cell src) |]
+ | Ast.TY_task
+ | Ast.TY_port _
+ | _ when type_has_state ty
+ -> bug () "cloning mutable type"
+ | _ when i64_le (ty_sz abi ty) word_sz
+ -> mov dst (Il.Cell src)
+ | Ast.TY_fn _
+ | Ast.TY_obj _ -> ()
+ | _ ->
+ iter_ty_slots_full ty_params ty dst src
+ (clone_slot ty_params clone_task) curr_iso
+
+ and copy_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iflog (fun _ ->
+ annotate ("copy_ty: referent data of type " ^
+ (Ast.fmt_to_str Ast.fmt_ty ty)));
+ match ty with
+ Ast.TY_nil
+ | Ast.TY_bool
+ | Ast.TY_mach _
+ | Ast.TY_int
+ | Ast.TY_uint
+ | Ast.TY_native _
+ | Ast.TY_type
+ | Ast.TY_char ->
+ iflog
+ (fun _ -> annotate
+ (Printf.sprintf "copy_ty: simple mov (%Ld byte scalar)"
+ (ty_sz abi ty)));
+ mov dst (Il.Cell src)
+
+ | Ast.TY_param (i, _) ->
+ iflog
+ (fun _ -> annotate
+ (Printf.sprintf "copy_ty: parametric copy %#d" i));
+ aliasing false src
+ begin
+ fun src ->
+ let td = get_ty_param ty_params i in
+ 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; |]
+ end
+
+ | Ast.TY_fn _
+ | Ast.TY_obj _ ->
+ begin
+ let src_item = get_element_ptr src Abi.binding_field_item in
+ let dst_item = get_element_ptr dst Abi.binding_field_item in
+ let src_binding = get_element_ptr src Abi.binding_field_binding in
+ let dst_binding = get_element_ptr dst Abi.binding_field_binding in
+ mov dst_item (Il.Cell src_item);
+ let null_jmp = null_check src_binding in
+ (* Copy if we have a src binding. *)
+ (* FIXME (issue #58): this is completely wrong, call
+ * through to the binding's self-copy fptr. For now
+ * this only works by accident.
+ *)
+ trans_copy_slot ty_params true
+ dst_binding (exterior_slot Ast.TY_int)
+ src_binding (exterior_slot Ast.TY_int)
+ curr_iso;
+ patch null_jmp
+ end
+
+ | _ ->
+ iter_ty_slots_full ty_params ty dst src
+ (fun dst src slot curr_iso ->
+ trans_copy_slot ty_params true
+ dst slot src slot curr_iso)
+ curr_iso
+
+ and free_ty
+ (ty_params:Il.cell)
+ (ty:Ast.ty)
+ (cell:Il.cell)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ match ty with
+ Ast.TY_port _ -> trans_del_port cell
+ | Ast.TY_chan _ -> trans_del_chan cell
+ | Ast.TY_task -> trans_kill_task cell
+ | Ast.TY_vec s ->
+ iter_seq_slots ty_params cell cell s
+ (fun _ src slot iso -> drop_slot ty_params src slot iso) curr_iso;
+ trans_free cell
+
+ | _ -> trans_free cell
+
+ and maybe_iso
+ (curr_iso:Ast.ty_iso option)
+ (t:Ast.ty)
+ : Ast.ty =
+ match (curr_iso, t) with
+ (Some iso, Ast.TY_idx n) ->
+ Ast.TY_iso { iso with Ast.iso_index = n }
+ | (None, Ast.TY_idx _) ->
+ bug () "TY_idx outside TY_iso"
+ | _ -> t
+
+ and maybe_enter_iso
+ (t:Ast.ty)
+ (curr_iso:Ast.ty_iso option)
+ : Ast.ty_iso option =
+ match t with
+ Ast.TY_iso tiso -> Some tiso
+ | _ -> curr_iso
+
+ and mark_slot
+ (ty_params:Il.cell)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty slot in
+ match slot_mem_ctrl slot with
+ MEM_gc ->
+ note_gc_step slot "mark GC slot: check for null:";
+ emit (Il.cmp (Il.Cell cell) zero);
+ let null_cell_jump = mark () in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ let gc_word = exterior_gc_ctrl_cell cell in
+ let tmp = next_vreg_cell Il.voidptr_t in
+ (* if this has been marked already, jump to exit.*)
+ note_gc_step slot "mark GC slot: check for mark:";
+ emit (Il.binary Il.AND tmp (Il.Cell gc_word) one);
+ let already_marked_jump = mark () in
+ emit (Il.jmp Il.JZ Il.CodeNone);
+ (* Set mark bit in allocation header. *)
+ note_gc_step slot "mark GC slot: mark:";
+ emit (Il.binary Il.OR gc_word (Il.Cell gc_word) one);
+ (* Iterate over exterior slots marking outgoing links. *)
+ log cx "slot rty: %s" (cell_str cell);
+ let (body_mem, _) =
+ need_mem_cell
+ (get_element_ptr (deref cell)
+ Abi.exterior_gc_slot_field_body)
+ in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ lea tmp body_mem;
+ trans_call_simple_static_glue
+ (get_mark_glue ty curr_iso)
+ ty_params tmp;
+ patch null_cell_jump;
+ patch already_marked_jump;
+ note_gc_step slot "mark GC slot: done marking:";
+
+ | MEM_interior when type_is_structured ty ->
+ (iflog (fun _ ->
+ annotate ("mark interior slot " ^
+ (Ast.fmt_to_str Ast.fmt_slot slot))));
+ let (mem, _) = need_mem_cell cell in
+ let tmp = next_vreg_cell Il.voidptr_t in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ lea tmp mem;
+ trans_call_simple_static_glue
+ (get_mark_glue ty curr_iso)
+ ty_params tmp
+
+ | _ -> ()
+
+ and check_exterior_rty cell =
+ match cell with
+ Il.Reg (_, Il.AddrTy (Il.StructTy fields))
+ | Il.Mem (_, Il.ScalarTy (Il.AddrTy (Il.StructTy fields)))
+ when (((Array.length fields) > 0) && (fields.(0) = word_rty)) -> ()
+ | _ -> bug ()
+ "expected plausibly-exterior cell, got %s"
+ (Il.string_of_referent_ty (Il.cell_referent_ty cell))
+
+ and clone_slot
+ (ty_params:Il.cell)
+ (clone_task:Il.cell)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (dst_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty dst_slot in
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_exterior _ ->
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let dst = deref_slot true dst dst_slot in
+ let glue_fix = get_clone_glue (slot_ty dst_slot) curr_iso in
+ trans_call_static_glue
+ (code_fixup_to_ptr_operand glue_fix)
+ (Some dst)
+ [| alias ty_params; src; clone_task |]
+
+ | Ast.MODE_alias _ -> bug () "cloning into alias slot"
+ | Ast.MODE_interior _ ->
+ clone_ty ty_params clone_task ty dst src curr_iso
+
+ and drop_slot_in_current_frame
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ drop_slot (get_ty_params_of_current_frame()) cell slot curr_iso
+
+ and null_check (cell:Il.cell) : quad_idx =
+ emit (Il.cmp (Il.Cell cell) zero);
+ let j = mark() in
+ emit (Il.jmp Il.JE Il.CodeNone);
+ j
+
+ and drop_refcount_and_cmp (rc:Il.cell) : quad_idx =
+ iflog (fun _ -> annotate "drop refcount and maybe free");
+ 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 drop_slot
+ (ty_params:Il.cell)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let ty = slot_ty slot in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let slot = {slot with Ast.slot_ty = Some ty} in
+ let mctrl = slot_mem_ctrl slot in
+ match mctrl with
+ MEM_rc_opaque ->
+ (* Refcounted opaque objects we handle without glue functions. *)
+ let _ = check_exterior_rty cell in
+ let null_jmp = null_check cell in
+ let j = drop_refcount_and_cmp (exterior_rc_cell cell) in
+ free_ty ty_params ty cell curr_iso;
+ (* Null the slot out to prevent double-free if the frame
+ * unwinds.
+ *)
+ mov cell zero;
+ patch j;
+ patch null_jmp
+
+ | MEM_gc
+ | MEM_rc_struct ->
+ (* Refcounted "structured exterior" objects we handle via
+ * glue functions.
+ *)
+
+ (*
+ * 'GC memory' is treated similarly, just happens to have
+ * an extra couple cells on the front.
+ *)
+
+ (* FIXME (issue #25): check to see that the exterior has
+ * further exterior members; if it doesn't we can elide the
+ * call to the glue function. *)
+ let _ = check_exterior_rty cell in
+ let null_jmp = null_check cell in
+ let rc = exterior_rc_cell cell in
+ let _ = note_gc_step slot "dropping refcount on " in
+ let _ = trace_word cx.ctxt_sess.Session.sess_trace_gc rc in
+ let j = drop_refcount_and_cmp rc in
+ trans_call_simple_static_glue
+ (get_free_glue ty mctrl curr_iso)
+ ty_params cell;
+ (* Null the slot out to prevent double-free if the frame
+ * unwinds.
+ *)
+ mov cell zero;
+ patch j;
+ patch null_jmp
+
+ | MEM_interior when type_is_structured ty ->
+ (iflog (fun _ ->
+ annotate ("drop interior slot " ^
+ (Ast.fmt_to_str Ast.fmt_slot slot))));
+ let (mem, _) = need_mem_cell cell in
+ let vr = next_vreg_cell Il.voidptr_t in
+ lea vr mem;
+ trans_call_simple_static_glue
+ (get_drop_glue ty curr_iso)
+ ty_params vr
+
+ | MEM_interior ->
+ (* Interior allocation of all-interior value: free directly. *)
+ let ty = maybe_iso curr_iso ty in
+ drop_ty ty_params ty cell curr_iso
+
+ and note_drop_step ty step =
+ if cx.ctxt_sess.Session.sess_trace_drop ||
+ cx.ctxt_sess.Session.sess_log_trans
+ then
+ let slotstr = Ast.fmt_to_str Ast.fmt_ty ty in
+ let str = step ^ " " ^ slotstr in
+ begin
+ annotate str;
+ trace_str cx.ctxt_sess.Session.sess_trace_drop str
+ end
+
+ and note_gc_step slot step =
+ if cx.ctxt_sess.Session.sess_trace_gc ||
+ cx.ctxt_sess.Session.sess_log_trans
+ then
+ let mctrl_str =
+ match slot_mem_ctrl slot with
+ MEM_gc -> "MEM_gc"
+ | MEM_rc_struct -> "MEM_rc_struct"
+ | MEM_rc_opaque -> "MEM_rc_struct"
+ | MEM_interior -> "MEM_rc_struct"
+ in
+ let slotstr = Ast.fmt_to_str Ast.fmt_slot slot in
+ let str = step ^ " " ^ mctrl_str ^ " " ^ slotstr in
+ begin
+ annotate str;
+ trace_str cx.ctxt_sess.Session.sess_trace_gc str
+ end
+
+ (* Returns the offset of the slot-body in the initialized allocation. *)
+ and init_exterior_slot (cell:Il.cell) (slot:Ast.slot) : unit =
+ match slot_mem_ctrl slot with
+ MEM_gc ->
+ iflog (fun _ -> annotate "init GC exterior: malloc");
+ let sz = exterior_allocation_size slot in
+ (*
+ * Malloc and then immediately shift down to point to
+ * the pseudo-rc cell.
+ *)
+ note_gc_step slot "init GC exterior: malloc slot:";
+ trans_malloc cell sz;
+ add_to cell
+ (imm (word_n Abi.exterior_gc_malloc_return_adjustment));
+ note_gc_step slot "init GC exterior: load control word";
+ let ctrl = exterior_gc_ctrl_cell cell in
+ let tydesc = get_tydesc None (slot_ty slot) in
+ let rc = exterior_rc_cell cell in
+ note_gc_step slot "init GC exterior: set refcount";
+ mov rc one;
+ trace_word cx.ctxt_sess.Session.sess_trace_gc rc;
+ mov ctrl (Il.Cell tydesc);
+ note_gc_step slot "init GC exterior: load chain next-ptr";
+ let next = exterior_gc_next_cell cell in
+ let chain = tp_imm (word_n Abi.task_field_gc_alloc_chain) in
+ mov next (Il.Cell chain);
+ note_gc_step slot "init GC exterior: link GC mem to chain";
+ mov chain (Il.Cell cell);
+ note_gc_step slot "init GC exterior: done initializing"
+
+ | MEM_rc_opaque
+ | MEM_rc_struct ->
+ iflog (fun _ -> annotate "init RC exterior: malloc");
+ let sz = exterior_allocation_size slot in
+ trans_malloc cell sz;
+ iflog (fun _ -> annotate "init RC exterior: load refcount");
+ let rc = exterior_rc_cell cell in
+ mov rc one
+
+ | MEM_interior -> bug () "init_exterior_slot of MEM_interior"
+
+ and deref_slot
+ (initializing:bool)
+ (cell:Il.cell)
+ (slot:Ast.slot)
+ : Il.cell =
+ match slot.Ast.slot_mode with
+ Ast.MODE_interior _ ->
+ cell
+
+ | Ast.MODE_exterior _ ->
+ check_exterior_rty cell;
+ if initializing
+ then init_exterior_slot cell slot;
+ get_element_ptr_dyn_in_current_frame
+ (deref cell)
+ Abi.exterior_rc_slot_field_body
+
+ | Ast.MODE_alias _ ->
+ if initializing
+ then cell
+ else deref cell
+
+ and trans_copy_tup
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell)
+ (src:Il.cell)
+ (slots:Ast.ty_tup)
+ : unit =
+ Array.iteri
+ begin
+ fun i slot ->
+ let sub_dst_cell = get_element_ptr_dyn ty_params dst i in
+ let sub_src_cell = get_element_ptr_dyn ty_params src i in
+ trans_copy_slot
+ ty_params initializing
+ sub_dst_cell slot sub_src_cell slot None
+ end
+ slots
+
+ and trans_copy_slot
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ let anno (weight:string) : unit =
+ iflog
+ begin
+ fun _ ->
+ annotate
+ (Printf.sprintf "%sweight copy: %a <- %a"
+ weight
+ Ast.sprintf_slot dst_slot
+ Ast.sprintf_slot src_slot)
+ end;
+ in
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ match (slot_mem_ctrl src_slot,
+ slot_mem_ctrl dst_slot) with
+
+ | (MEM_rc_opaque, MEM_rc_opaque)
+ | (MEM_gc, MEM_gc)
+ | (MEM_rc_struct, MEM_rc_struct) ->
+ (* Lightweight copy: twiddle refcounts, move pointer. *)
+ anno "refcounted light";
+ add_to (exterior_rc_cell src) one;
+ if not initializing
+ then
+ drop_slot ty_params dst dst_slot None;
+ mov dst (Il.Cell src)
+
+ | _ ->
+ (* Heavyweight copy: duplicate 1 level of the referent. *)
+ anno "heavy";
+ trans_copy_slot_heavy ty_params initializing
+ dst dst_slot src src_slot curr_iso
+
+ (* NB: heavyweight copying here does not mean "producing a deep
+ * clone of the entire data tree rooted at the src operand". It means
+ * "replicating a single level of the tree".
+ *
+ * There is no general-recursion entailed in performing a heavy
+ * copy. There is only "one level" to each heavy copy call.
+ *
+ * In other words, this is a lightweight copy:
+ *
+ * [dstptr] <-copy- [srcptr]
+ * \ |
+ * \ |
+ * [some record.rc++]
+ * |
+ * [some other record]
+ *
+ * Whereas this is a heavyweight copy:
+ *
+ * [dstptr] <-copy- [srcptr]
+ * | |
+ * | |
+ * [some record] [some record]
+ * | |
+ * [some other record]
+ *
+ *)
+
+ and trans_copy_slot_heavy
+ (ty_params:Il.cell)
+ (initializing:bool)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ iflog (fun _ ->
+ annotate ("heavy copy: slot preparation"));
+
+ let ty = slot_ty src_slot in
+ let ty = maybe_iso curr_iso ty in
+ let curr_iso = maybe_enter_iso ty curr_iso in
+ let dst_slot = { dst_slot with Ast.slot_ty = Some ty } in
+ let src_slot = { src_slot with Ast.slot_ty = Some ty } in
+ let dst = deref_slot initializing dst dst_slot in
+ let src = deref_slot false src src_slot in
+ copy_ty ty_params ty dst src curr_iso
+
+ and trans_copy
+ (initializing:bool)
+ (dst:Ast.lval)
+ (src:Ast.expr)
+ : unit =
+ let (dst_cell, dst_slot) = trans_lval_maybe_init initializing dst in
+ match (slot_ty dst_slot, src) with
+ (Ast.TY_vec _,
+ Ast.EXPR_binary (Ast.BINOP_add,
+ Ast.ATOM_lval a, Ast.ATOM_lval b))
+ | (Ast.TY_str,
+ Ast.EXPR_binary (Ast.BINOP_add,
+ Ast.ATOM_lval a, Ast.ATOM_lval b)) ->
+ (*
+ * Translate str or vec
+ *
+ * s = a + b
+ *
+ * as
+ *
+ * s = a;
+ * s += b;
+ *)
+ let (a_cell, a_slot) = trans_lval a in
+ let (b_cell, b_slot) = trans_lval b in
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ initializing dst_cell dst_slot
+ a_cell a_slot None;
+ trans_vec_append dst_cell dst_slot
+ (Il.Cell b_cell) (slot_ty b_slot)
+
+
+ | (Ast.TY_obj caller_obj_ty,
+ Ast.EXPR_unary (Ast.UNOP_cast t, a)) ->
+ let src_ty = atom_type cx a in
+ let _ = assert (not (is_prim_type (src_ty))) in
+ begin
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ let _ = assert (t = (Ast.TY_obj caller_obj_ty)) in
+ let callee_obj_ty =
+ match atom_type cx a with
+ Ast.TY_obj t -> t
+ | _ -> bug () "obj cast from non-obj type"
+ in
+ let src_cell = need_cell (trans_atom a) in
+ let src_slot = interior_slot src_ty in
+
+ (* FIXME: this is wrong. It treats the underlying obj-state
+ * as the same as the callee and simply substitutes the
+ * forwarding vtbl, which would be great if it had any way
+ * convey the callee vtbl to the forwarding functions. But it
+ * doesn't. Instead, we have to malloc a fresh 3-word
+ * refcounted obj to hold the callee's vtbl+state pair, copy
+ * that in as the state here.
+ *)
+ let _ =
+ trans_copy_slot (get_ty_params_of_current_frame())
+ initializing
+ dst_cell dst_slot
+ src_cell src_slot
+ in
+ let caller_vtbl_oper =
+ get_forwarding_vtbl caller_obj_ty callee_obj_ty
+ in
+ let caller_obj =
+ deref_slot initializing dst_cell dst_slot
+ in
+ let caller_vtbl =
+ get_element_ptr caller_obj Abi.binding_field_item
+ in
+ mov caller_vtbl caller_vtbl_oper
+ end
+
+ | (_, Ast.EXPR_binary _)
+ | (_, Ast.EXPR_unary _)
+ | (_, Ast.EXPR_atom (Ast.ATOM_literal _)) ->
+ (*
+ * Translations of these expr types yield vregs,
+ * so copy is just MOV into the lval.
+ *)
+ let src_operand = trans_expr src in
+ mov (deref_slot false dst_cell dst_slot) src_operand
+
+ | (_, 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
+ else
+ (* Possibly-large structure copying *)
+ let (src_cell, src_slot) = trans_lval src_lval in
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ initializing
+ dst_cell dst_slot
+ src_cell src_slot
+ None
+
+ and trans_copy_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.binding_field_item
+ in
+ let dst_pair_binding_cell =
+ get_element_ptr dst_cell Abi.binding_field_binding
+ in
+
+ mov dst_pair_item_cell (crate_rel_imm fix);
+ mov dst_pair_binding_cell zero
+
+
+ and trans_init_structural_from_atoms
+ (dst:Il.cell)
+ (dst_slots:Ast.slot array)
+ (atoms:Ast.atom array)
+ : unit =
+ Array.iteri
+ begin
+ fun i atom ->
+ trans_init_slot_from_atom
+ CLONE_none
+ (get_element_ptr_dyn_in_current_frame dst i)
+ dst_slots.(i)
+ atom
+ end
+ atoms
+
+ and trans_init_rec_update
+ (dst:Il.cell)
+ (dst_slots:Ast.slot array)
+ (trec:Ast.ty_rec)
+ (atab:(Ast.ident * Ast.mode * bool * Ast.atom) array)
+ (base:Ast.lval)
+ : unit =
+ Array.iteri
+ begin
+ fun i (fml_ident, _) ->
+ let fml_entry _ (act_ident, _, _, atom) =
+ if act_ident = fml_ident then Some atom else None
+ in
+ let slot = dst_slots.(i) in
+ match arr_search atab fml_entry with
+ Some atom ->
+ trans_init_slot_from_atom
+ CLONE_none
+ (get_element_ptr_dyn_in_current_frame dst i)
+ slot
+ atom
+ | None ->
+ let (src, _) = trans_lval base in
+ trans_copy_slot
+ (get_ty_params_of_current_frame()) true
+ (get_element_ptr_dyn_in_current_frame dst i) slot
+ (get_element_ptr_dyn_in_current_frame src i) slot
+ None
+ end
+ trec
+
+ and trans_init_slot_from_atom
+ (clone:clone_ctrl)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (atom:Ast.atom)
+ : unit =
+ let is_alias_cell =
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_alias _ -> true
+ | _ -> false
+ in
+ match atom with
+ | Ast.ATOM_literal _ ->
+ let src = trans_atom atom in
+ if is_alias_cell
+ then
+ match clone with
+ CLONE_none ->
+ (*
+ * FIXME: this won't work on mutable aliases, it
+ * doesn't know to reload. Try something
+ * else.
+ *)
+ mov dst (Il.Cell (alias (Il.Mem (force_to_mem src))))
+ | _ ->
+ bug () "attempting to clone alias cell"
+ else
+ mov (deref_slot true dst dst_slot) src
+ | Ast.ATOM_lval src_lval ->
+ let (src, src_slot) = trans_lval src_lval in
+ trans_init_slot_from_cell clone dst dst_slot src src_slot
+
+ and trans_init_slot_from_cell
+ (clone:clone_ctrl)
+ (dst:Il.cell) (dst_slot:Ast.slot)
+ (src:Il.cell) (src_slot:Ast.slot)
+ : unit =
+ assert (slot_ty src_slot = slot_ty dst_slot);
+ let is_alias_cell =
+ match dst_slot.Ast.slot_mode with
+ Ast.MODE_alias _ -> true
+ | _ -> false
+ in
+ match clone with
+ CLONE_chan clone_task ->
+ let clone =
+ if (type_contains_chan (slot_ty src_slot))
+ then CLONE_all clone_task
+ else CLONE_none
+ in
+ trans_init_slot_from_cell clone dst dst_slot src src_slot
+ | CLONE_none ->
+ if is_alias_cell
+ then mov dst (Il.Cell (alias src))
+ else
+ trans_copy_slot
+ (get_ty_params_of_current_frame())
+ true dst dst_slot src src_slot None
+ | CLONE_all clone_task ->
+ if is_alias_cell
+ then bug () "attempting to clone alias cell"
+ else
+ clone_slot
+ (get_ty_params_of_current_frame())
+ clone_task dst src dst_slot None
+
+ and trans_be_fn
+ (cx:ctxt)
+ (dst_cell:Il.cell)
+ (flv:Ast.lval)
+ (ty_params:Ast.ty array)
+ (args:Ast.atom array)
+ : unit =
+ let (ptr, fn_ty) = trans_callee flv in
+ let cc = call_ctrl flv in
+ let call = { call_ctrl = cc;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = ty_params;
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = call_iterator_args None;
+ call_indirect_args = call_indirect_args flv cc }
+ in
+ (* FIXME: true if caller is object fn *)
+ let caller_is_closure = false in
+ log cx "trans_be_fn: %s call to lval %a"
+ (call_ctrl_string cc) Ast.sprintf_lval flv;
+ trans_be (fun () -> Ast.sprintf_lval () flv) caller_is_closure call
+
+ and trans_prepare_fn_call
+ (initializing:bool)
+ (cx:ctxt)
+ (dst_cell:Il.cell)
+ (flv:Ast.lval)
+ (ty_params:Ast.ty array)
+ (fco:for_each_ctrl option)
+ (args:Ast.atom array)
+ : Il.operand =
+ let (ptr, fn_ty) = trans_callee flv in
+ let cc = call_ctrl flv in
+ let call = { call_ctrl = cc;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = ty_params;
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = call_iterator_args fco;
+ call_indirect_args = call_indirect_args flv cc }
+ in
+ iflog
+ begin
+ fun _ ->
+ log cx "trans_prepare_fn_call: %s call to lval %a"
+ (call_ctrl_string cc) Ast.sprintf_lval flv;
+ log cx "lval type: %a" Ast.sprintf_ty fn_ty;
+ Array.iteri (fun i t -> log cx "ty param %d = %a"
+ i Ast.sprintf_ty t)
+ ty_params;
+ end;
+ trans_prepare_call initializing (fun () -> Ast.sprintf_lval () flv) call
+
+ and trans_call_pred_and_check
+ (constr:Ast.constr)
+ (flv:Ast.lval)
+ (args:Ast.atom array)
+ : unit =
+ let (ptr, fn_ty) = trans_callee flv in
+ let dst_cell = Il.Mem (force_to_mem imm_false) in
+ let call = { call_ctrl = call_ctrl flv;
+ call_callee_ptr = ptr;
+ call_callee_ty = fn_ty;
+ call_callee_ty_params = [| |];
+ call_output = dst_cell;
+ call_args = args;
+ call_iterator_args = [| |];
+ call_indirect_args = [| |] }
+ in
+ iflog (fun _ -> annotate "predicate call");
+ let fn_ptr =
+ trans_prepare_call true (fun _ -> Ast.sprintf_lval () flv) call
+ in
+ call_code (code_of_operand fn_ptr);
+ iflog (fun _ -> annotate "predicate check/fail");
+ let jmp = trans_compare Il.JE (Il.Cell dst_cell) imm_true in
+ let errstr = Printf.sprintf "predicate check: %a"
+ Ast.sprintf_constr constr
+ in
+ trans_cond_fail errstr jmp
+
+ and trans_init_closure
+ (closure_cell:Il.cell)
+ (target_fn_ptr:Il.operand)
+ (target_binding_ptr:Il.operand)
+ (bound_arg_slots:Ast.slot array)
+ (bound_args:Ast.atom array)
+ : unit =
+
+ let rc_cell = get_element_ptr closure_cell 0 in
+ let targ_cell = get_element_ptr closure_cell 1 in
+ let args_cell = get_element_ptr closure_cell 2 in
+
+ iflog (fun _ -> annotate "init closure refcount");
+ mov rc_cell one;
+ iflog (fun _ -> annotate "set closure target code ptr");
+ mov (get_element_ptr targ_cell 0) (reify_ptr target_fn_ptr);
+ iflog (fun _ -> annotate "set closure target binding ptr");
+ mov (get_element_ptr targ_cell 1) (reify_ptr target_binding_ptr);
+
+ iflog (fun _ -> annotate "set closure bound args");
+ copy_bound_args args_cell bound_arg_slots bound_args
+
+ and trans_bind_fn
+ (initializing:bool)
+ (cc:call_ctrl)
+ (bind_id:node_id)
+ (dst:Ast.lval)
+ (flv:Ast.lval)
+ (fn_sig:Ast.ty_sig)
+ (args:Ast.atom option array)
+ : unit =
+ let (dst_cell, _) = trans_lval_maybe_init initializing dst in
+ let (target_ptr, _) = trans_callee flv in
+ let arg_bound_flags = Array.map bool_of_option args in
+ let arg_slots =
+ arr_map2
+ (fun arg_slot bound_flag ->
+ if bound_flag then Some arg_slot else None)
+ fn_sig.Ast.sig_input_slots
+ arg_bound_flags
+ 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
+ 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.binding_field_item in
+ let closure_cell =
+ ptr_cast
+ (get_element_ptr dst_cell Abi.binding_field_binding)
+ (Il.ScalarTy (Il.AddrTy (closure_rty)))
+ in
+ iflog (fun _ -> annotate "assign glue-code to fn slot of pair");
+ mov fn_cell (crate_rel_imm glue_fixup);
+ iflog (fun _ ->
+ annotate "heap-allocate closure to binding slot of pair");
+ trans_malloc closure_cell (imm closure_sz);
+ trans_init_closure
+ (deref closure_cell)
+ target_fn_ptr target_binding_ptr
+ bound_arg_slots bound_args
+
+
+ and trans_arg0 (arg_cell:Il.cell) (output_cell:Il.cell) : unit =
+ (* Emit arg0 of any call: the output slot. *)
+ iflog (fun _ -> annotate "fn-call arg 0: output slot");
+ trans_init_slot_from_cell
+ CLONE_none
+ arg_cell (word_write_alias_slot abi)
+ output_cell word_slot
+
+ and trans_arg1 (arg_cell:Il.cell) : unit =
+ (* Emit arg1 of any call: the task pointer. *)
+ iflog (fun _ -> annotate "fn-call arg 1: task pointer");
+ trans_init_slot_from_cell
+ CLONE_none
+ arg_cell word_slot
+ abi.Abi.abi_tp_cell word_slot
+
+ and trans_argN
+ (clone:clone_ctrl)
+ (arg_cell:Il.cell)
+ (arg_slot:Ast.slot)
+ (arg:Ast.atom)
+ : unit =
+ trans_init_slot_from_atom clone arg_cell arg_slot arg
+
+ and code_of_cell (cell:Il.cell) : Il.code =
+ match cell with
+ Il.Mem (_, Il.ScalarTy (Il.AddrTy Il.CodeTy))
+ | Il.Reg (_, Il.AddrTy Il.CodeTy) -> Il.CodePtr (Il.Cell cell)
+ | _ ->
+ bug () "expected code-pointer cell, found %s"
+ (cell_str cell)
+
+ and code_of_operand (operand:Il.operand) : Il.code =
+ match operand with
+ Il.Cell c -> code_of_cell c
+ | Il.ImmPtr (_, Il.CodeTy) -> Il.CodePtr operand
+ | _ ->
+ bug () "expected code-pointer operand, got %s"
+ (oper_str operand)
+
+ and ty_arg_slots (ty:Ast.ty) : Ast.slot array =
+ match ty with
+ Ast.TY_fn (tsig, _) -> tsig.Ast.sig_input_slots
+ | _ -> bug () "Trans.ty_arg_slots on non-callable type: %a"
+ Ast.sprintf_ty ty
+
+ and copy_fn_args
+ (tail_area:bool)
+ (clone:clone_ctrl)
+ (call:call)
+ : unit =
+
+ let n_ty_params = Array.length call.call_callee_ty_params in
+ let all_callee_args_rty =
+ let clo =
+ if call.call_ctrl = CALL_direct
+ then None
+ else (Some Il.OpaqueTy)
+ in
+ call_args_referent_type cx n_ty_params call.call_callee_ty clo
+ in
+ let all_callee_args_cell =
+ callee_args_cell tail_area all_callee_args_rty
+ in
+
+ let _ = iflog (fun _ -> annotate
+ (Printf.sprintf
+ "copying fn args to %d-ty-param call with rty: %s\n"
+ n_ty_params (Il.string_of_referent_ty
+ all_callee_args_rty)))
+ in
+ let callee_arg_slots = ty_arg_slots call.call_callee_ty in
+ let callee_output_cell =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr
+ in
+ let callee_task_cell =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr
+ in
+ let callee_ty_params =
+ get_element_ptr all_callee_args_cell Abi.calltup_elt_ty_params
+ in
+ let callee_args =
+ get_element_ptr_dyn_in_current_frame
+ all_callee_args_cell Abi.calltup_elt_args
+ in
+ let callee_iterator_args =
+ 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
+ let n_indirects = Array.length call.call_indirect_args in
+
+ Array.iteri
+ begin
+ fun i arg_atom ->
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf "fn-call arg %d of %d (+ %d indirect)"
+ i n_args n_indirects));
+ trans_argN
+ clone
+ (get_element_ptr_dyn_in_current_frame callee_args i)
+ callee_arg_slots.(i)
+ arg_atom
+ end
+ call.call_args;
+
+ Array.iteri
+ begin
+ fun i iterator_arg_operand ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf "fn-call iterator-arg %d of %d"
+ i n_iterators));
+ mov
+ (get_element_ptr_dyn_in_current_frame callee_iterator_args i)
+ iterator_arg_operand
+ end
+ call.call_iterator_args;
+
+ Array.iteri
+ begin
+ fun i indirect_arg_operand ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf "fn-call indirect-arg %d of %d"
+ i n_indirects));
+ mov
+ (get_element_ptr_dyn_in_current_frame callee_indirect_args i)
+ indirect_arg_operand
+ end
+ call.call_indirect_args;
+
+ Array.iteri
+ begin
+ fun i ty_param ->
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf "fn-call ty param %d of %d"
+ i n_ty_params));
+ trans_init_slot_from_cell CLONE_none
+ (get_element_ptr callee_ty_params i) word_slot
+ (get_tydesc None ty_param) word_slot
+ end
+ call.call_callee_ty_params;
+
+ trans_arg1 callee_task_cell;
+
+ trans_arg0 callee_output_cell call.call_output
+
+
+
+ and call_code (code:Il.code) : unit =
+ let vr = next_vreg_cell Il.voidptr_t in
+ emit (Il.call vr code);
+
+
+ and copy_bound_args
+ (dst_cell:Il.cell)
+ (bound_arg_slots:Ast.slot array)
+ (bound_args:Ast.atom array)
+ : unit =
+ let n_slots = Array.length bound_arg_slots in
+ Array.iteri
+ begin
+ fun i slot ->
+ iflog (fun _ ->
+ annotate (Printf.sprintf
+ "copy bound arg %d of %d" i n_slots));
+ trans_argN CLONE_none
+ (get_element_ptr dst_cell i)
+ slot bound_args.(i)
+ end
+ bound_arg_slots
+
+ and merge_bound_args
+ (all_self_args_rty:Il.referent_ty)
+ (all_callee_args_rty:Il.referent_ty)
+ (arg_slots:Ast.slot array)
+ (arg_bound_flags:bool array)
+ : unit =
+ begin
+ (*
+ * NB: 'all_*_args', both self and callee, are always 4-tuples:
+ *
+ * [out_ptr, task_ptr, [args], [indirect_args]]
+ *
+ * The first few bindings here just destructure those via GEP.
+ *
+ *)
+ let all_self_args_cell = caller_args_cell all_self_args_rty in
+ let all_callee_args_cell = callee_args_cell false all_callee_args_rty in
+
+ 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
+ in
+ let callee_args_cell =
+ 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
+ in
+
+ let n_args = Array.length arg_bound_flags in
+ let bound_i = ref 0 in
+ let unbound_i = ref 0 in
+
+ iflog (fun _ -> annotate "copy out-ptr");
+ mov
+ (get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr)
+ (Il.Cell (get_element_ptr all_self_args_cell
+ Abi.calltup_elt_out_ptr));
+
+ iflog (fun _ -> annotate "copy task-ptr");
+ mov
+ (get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr)
+ (Il.Cell (get_element_ptr all_self_args_cell
+ Abi.calltup_elt_task_ptr));
+
+ iflog (fun _ -> annotate "extract closure indirect-arg");
+ let closure_cell =
+ deref (get_element_ptr self_indirect_args_cell
+ Abi.indirect_args_elt_closure)
+ in
+ let closure_args_cell = get_element_ptr closure_cell 2 in
+
+ 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_copy_slot
+ self_ty_params_cell
+ true dst_cell slot src_cell slot None;
+ incr (if is_bound then bound_i else unbound_i);
+ done;
+ assert ((!bound_i + !unbound_i) == n_args)
+ end
+
+
+ and callee_fn_ptr
+ (fptr:Il.operand)
+ (cc:call_ctrl)
+ : Il.operand =
+ match cc with
+ CALL_direct
+ | CALL_vtbl -> fptr
+ | CALL_indirect ->
+ (* fptr is a pair [disp, binding*] *)
+ let pair_cell = need_cell (reify_ptr fptr) in
+ let disp_cell = get_element_ptr pair_cell Abi.binding_field_item in
+ Il.Cell (crate_rel_to_ptr (Il.Cell disp_cell) Il.CodeTy)
+
+ and callee_binding_ptr
+ (pair_lval:Ast.lval)
+ (cc:call_ctrl)
+ : Il.operand =
+ if cc = CALL_direct
+ then zero
+ else
+ let (pair_cell, _) = trans_lval pair_lval in
+ Il.Cell (get_element_ptr pair_cell Abi.binding_field_binding)
+
+ and call_ctrl flv : call_ctrl =
+ if lval_is_static cx flv
+ then CALL_direct
+ else
+ if lval_is_obj_vtbl cx flv
+ then CALL_vtbl
+ else CALL_indirect
+
+ and call_ctrl_string cc =
+ match cc with
+ CALL_direct -> "direct"
+ | CALL_indirect -> "indirect"
+ | CALL_vtbl -> "vtbl"
+
+ and call_iterator_args
+ (fco:for_each_ctrl option)
+ : Il.operand array =
+ match fco with
+ None -> [| |]
+ | Some fco ->
+ begin
+ iflog (fun _ -> annotate "calculate iterator args");
+ [| reify_ptr (code_fixup_to_ptr_operand fco.for_each_fixup);
+ Il.Cell (Il.Reg (abi.Abi.abi_fp_reg, Il.voidptr_t)); |]
+ end
+
+ and call_indirect_args
+ (flv:Ast.lval)
+ (cc:call_ctrl)
+ : Il.operand array =
+ begin
+ match cc with
+ CALL_direct -> [| |]
+ | CALL_indirect -> [| callee_binding_ptr flv cc |]
+ | CALL_vtbl ->
+ begin
+ match flv with
+ (*
+ * FIXME: will need to pass both words of obj if we add
+ * a 'self' value for self-dispatch within objs.
+ *)
+ Ast.LVAL_ext (base, _) -> [| callee_binding_ptr base cc |]
+ | _ ->
+ bug (lval_base_id flv)
+ "call_indirect_args on obj-fn without base obj"
+ end
+ end
+
+ and trans_be
+ (logname:(unit -> string))
+ (caller_is_closure:bool)
+ (call:call)
+ : unit =
+ let callee_fptr = callee_fn_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
+ (if call.call_ctrl = CALL_direct then None else (Some Il.OpaqueTy))
+ in
+ let callee_argsz =
+ force_sz (Il.referent_ty_size word_bits callee_args_rty)
+ in
+ let closure_rty =
+ if caller_is_closure
+ then Some Il.OpaqueTy
+ else None
+ in
+ let caller_args_rty = current_fn_args_rty closure_rty in
+ let caller_argsz =
+ force_sz (Il.referent_ty_size word_bits caller_args_rty)
+ in
+ iflog (fun _ -> annotate
+ (Printf.sprintf "copy args for tail call to %s" (logname ())));
+ copy_fn_args true CLONE_none call;
+ drop_slots_at_curr_stmt();
+ abi.Abi.abi_emit_fn_tail_call (emitter())
+ (force_sz (current_fn_callsz()))
+ caller_argsz callee_code callee_argsz;
+
+
+ and trans_prepare_call
+ ((*initializing*)_:bool)
+ (logname:(unit -> string))
+ (call:call)
+ : Il.operand =
+
+ let callee_fptr = callee_fn_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 CLONE_none call;
+ iflog (fun _ -> annotate (Printf.sprintf "call %s" (logname ())));
+ (* FIXME (issue #24): we need to actually handle writing to an
+ * already-initialised slot. Currently we blindly assume we're
+ * initializing, overwrite the slot; this is ok if we're writing
+ * to an interior output slot, but we'll leak any exteriors as we
+ * do that. *)
+ callee_fptr
+
+ and callee_drop_slot
+ (k:Ast.slot_key)
+ (slot_id:node_id)
+ (slot:Ast.slot)
+ : unit =
+ iflog (fun _ ->
+ annotate (Printf.sprintf "callee_drop_slot %d = %s "
+ (int_of_node slot_id)
+ (Ast.fmt_to_str Ast.fmt_slot_key k)));
+ drop_slot_in_current_frame (cell_of_block_slot slot_id) slot None
+
+
+ and trans_alt_tag { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } =
+ let ((lval_cell:Il.cell), { Ast.slot_ty = ty_opt }) = trans_lval lval in
+ let lval_ty =
+ match ty_opt with
+ Some ty -> ty
+ | None -> bug cx "expected lval type"
+ in
+
+ let trans_arm { node = (pat, block) } : quad_idx =
+ (* Translates the pattern and returns the addresses of the branch
+ * instructions, which are taken if the match fails. *)
+ let rec trans_pat pat cell (ty:Ast.ty) =
+ match pat with
+ Ast.PAT_lit lit ->
+ let operand = trans_lit lit in
+ emit (Il.cmp (Il.Cell cell) operand);
+ let next_jump = mark() in
+ emit (Il.jmp Il.JNE Il.CodeNone);
+ [ next_jump ]
+
+ | Ast.PAT_tag (ident, pats) ->
+ let ty_tag =
+ match ty with
+ Ast.TY_tag tag_ty -> tag_ty
+ | Ast.TY_iso ti -> (ti.Ast.iso_group).(ti.Ast.iso_index)
+ | _ -> bug cx "expected tag type"
+ in
+ let tag_keys = sorted_htab_keys ty_tag in
+ let tag_name = Ast.NAME_base (Ast.BASE_ident ident) in
+ let tag_number = arr_idx tag_keys tag_name in
+ let ty_tup = Hashtbl.find ty_tag tag_name in
+
+ let tag_cell:Il.cell = get_element_ptr cell 0 in
+ let union_cell = get_element_ptr_dyn_in_current_frame cell 1 in
+
+ emit (Il.cmp
+ (Il.Cell tag_cell)
+ (imm (Int64.of_int tag_number)));
+ let next_jump = mark() in
+ emit (Il.jmp Il.JNE Il.CodeNone);
+
+ let tup_cell:Il.cell = get_variant_ptr union_cell tag_number in
+
+ let trans_elem_pat i elem_pat : quad_idx list =
+ let elem_cell =
+ get_element_ptr_dyn_in_current_frame tup_cell i
+ in
+ let elem_ty =
+ match ty_tup.(i).Ast.slot_ty with
+ Some ty -> ty
+ | None -> bug cx "expected element type"
+ in
+ trans_pat elem_pat elem_cell elem_ty
+ in
+
+ let elem_jumps = Array.mapi trans_elem_pat pats in
+ next_jump::(List.concat (Array.to_list elem_jumps))
+
+ | Ast.PAT_slot ({ node = dst_slot; id = dst_id }, _) ->
+ let dst_cell = cell_of_block_slot dst_id in
+ let src_cell = Il.Cell cell in
+ mov (deref_slot true dst_cell dst_slot) src_cell;
+ [] (* irrefutable *)
+
+ | Ast.PAT_wild -> [] (* irrefutable *)
+ in
+
+ let next_jumps = trans_pat pat lval_cell lval_ty in
+ trans_block block;
+ let last_jump = mark() in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ List.iter patch next_jumps;
+ last_jump
+ in
+ let last_jumps = Array.map trans_arm arms in
+ Array.iter patch last_jumps
+
+ and drop_slots_at_curr_stmt _ : unit =
+ let stmt = Stack.top curr_stmt in
+ match htab_search cx.ctxt_post_stmt_slot_drops stmt with
+ None -> ()
+ | Some slots ->
+ List.iter
+ begin
+ fun slot_id ->
+ let slot = get_slot cx slot_id in
+ let k = Hashtbl.find cx.ctxt_slot_keys slot_id in
+ iflog (fun _ ->
+ annotate
+ (Printf.sprintf
+ "post-stmt, drop_slot %d = %s "
+ (int_of_node slot_id)
+ (Ast.fmt_to_str Ast.fmt_slot_key k)));
+ drop_slot_in_current_frame
+ (cell_of_block_slot slot_id) slot None
+ end
+ slots
+
+ and trans_stmt (stmt:Ast.stmt) : unit =
+ (* Helper to localize errors by stmt, at minimum. *)
+ try
+ iflog
+ begin
+ fun _ ->
+ let s = Ast.fmt_to_str Ast.fmt_stmt_body stmt in
+ log cx "translating stmt: %s" s;
+ annotate s;
+ end;
+ Stack.push stmt.id curr_stmt;
+ trans_stmt_full stmt;
+ begin
+ match stmt.node with
+ Ast.STMT_be _
+ | Ast.STMT_ret _ -> ()
+ | _ -> drop_slots_at_curr_stmt();
+ end;
+ ignore (Stack.pop curr_stmt);
+ with
+ Semant_err (None, msg) -> raise (Semant_err ((Some stmt.id), msg))
+
+
+ and maybe_init (id:node_id) (action:string) (dst:Ast.lval) : bool =
+ let b = Hashtbl.mem cx.ctxt_copy_stmt_is_init id in
+ let act = if b then ("initializing-" ^ action) else action in
+ iflog
+ (fun _ ->
+ annotate (Printf.sprintf "%s on dst lval %a"
+ act Ast.sprintf_lval dst));
+ b
+
+
+ and trans_set_outptr (at:Ast.atom) : unit =
+ let (dst_mem, _) =
+ need_mem_cell
+ (deref (wordptr_at (fp_imm out_mem_disp)))
+ in
+ let atom_ty = atom_type cx at in
+ let dst_slot = interior_slot atom_ty in
+ let dst_ty = referent_type abi atom_ty in
+ let dst_cell = Il.Mem (dst_mem, dst_ty) in
+ trans_init_slot_from_atom
+ CLONE_none dst_cell dst_slot at
+
+
+ and trans_for_loop (fo:Ast.stmt_for) : unit =
+ let ty_params = get_ty_params_of_current_frame () in
+ let (dst_slot, _) = fo.Ast.for_slot in
+ let dst_cell = cell_of_block_slot dst_slot.id in
+ let (head_stmts, seq) = fo.Ast.for_seq in
+ let (seq_cell, seq_slot) = trans_lval_full false seq in
+ let unit_slot = seq_unit_slot (slot_ty seq_slot) in
+ Array.iter trans_stmt head_stmts;
+ iter_seq_slots ty_params seq_cell seq_cell unit_slot
+ begin
+ fun _ src_cell unit_slot curr_iso ->
+ trans_copy_slot
+ ty_params true
+ dst_cell dst_slot.node
+ src_cell unit_slot curr_iso;
+ trans_block fo.Ast.for_body;
+ end
+ None
+
+ and trans_for_each_loop (stmt_id:node_id) (fe:Ast.stmt_for_each) : unit =
+ let id = fe.Ast.for_each_body.id in
+ let g = GLUE_loop_body id in
+ let name = glue_str cx g in
+ let fix = new_fixup name in
+ let framesz = get_framesz cx id in
+ let callsz = get_callsz cx id in
+ let spill = Hashtbl.find cx.ctxt_spill_fixups id in
+ push_new_emitter_with_vregs (Some id);
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ iflog (fun _ -> annotate "finished prologue");
+ trans_block fe.Ast.for_each_body;
+ trans_glue_frame_exit fix spill g;
+
+ (*
+ * We've now emitted the body helper-fn. Next, set up a loop that
+ * calls the iter and passes the helper-fn in.
+ *)
+ emit (Il.Enter
+ (Hashtbl.find
+ cx.ctxt_block_fixups
+ fe.Ast.for_each_head.id));
+ let (dst_slot, _) = fe.Ast.for_each_slot in
+ let dst_cell = cell_of_block_slot dst_slot.id in
+ let (flv, args) = fe.Ast.for_each_call in
+ let ty_params =
+ match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
+ Some params -> params
+ | None -> [| |]
+ in
+ let depth = Hashtbl.find cx.ctxt_stmt_loop_depths stmt_id in
+ let fc = { for_each_fixup = fix; for_each_depth = depth } in
+ iflog (fun _ ->
+ log cx "for-each at depth %d\n" depth);
+ let fn_ptr =
+ trans_prepare_fn_call true cx dst_cell flv ty_params (Some fc) args
+ in
+ call_code (code_of_operand fn_ptr);
+ emit Il.Leave;
+
+ and trans_put (atom_opt:Ast.atom option) : unit =
+ begin
+ match atom_opt with
+ None -> ()
+ | Some at -> trans_set_outptr at
+ end;
+ let block_fptr = Il.Cell (get_iter_block_fn_for_current_frame ()) in
+ 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 |]
+
+ and trans_vec_append dst_cell dst_slot src_oper src_ty =
+ let (dst_elt_slot, trim_trailing_null) =
+ match slot_ty dst_slot with
+ Ast.TY_str -> (interior_slot (Ast.TY_mach TY_u8), true)
+ | Ast.TY_vec e -> (e, false)
+ | _ -> bug () "unexpected dst type in trans_vec_append"
+ in
+ match src_ty with
+ Ast.TY_str
+ | Ast.TY_vec _ ->
+ let src_cell = need_cell src_oper in
+ let src_vec = deref src_cell in
+ let src_fill = get_element_ptr src_vec Abi.vec_elt_fill in
+ let src_elt_slot =
+ match src_ty with
+ Ast.TY_str -> interior_slot (Ast.TY_mach TY_u8)
+ | Ast.TY_vec e -> e
+ | _ -> bug () "unexpected src type in trans_vec_append"
+ in
+ let dst_vec = deref dst_cell in
+ let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
+ if trim_trailing_null
+ then sub_from dst_fill (imm 1L);
+ trans_upcall "upcall_vec_grow"
+ dst_cell
+ [| Il.Cell dst_cell;
+ Il.Cell src_fill |];
+
+ (*
+ * By now, dst_cell points to a vec/str with room for us
+ * to add to.
+ *)
+
+ (* Reload dst vec, fill; might have changed. *)
+ let dst_vec = deref dst_cell in
+ let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
+
+ (* Copy loop: *)
+ let pty s = Il.AddrTy (slot_referent_type abi s) in
+ let dptr = next_vreg_cell (pty dst_elt_slot) in
+ let sptr = next_vreg_cell (pty src_elt_slot) in
+ let dlim = next_vreg_cell (pty dst_elt_slot) in
+ let dst_elt_sz = slot_sz_in_current_frame dst_elt_slot in
+ let src_elt_sz = slot_sz_in_current_frame src_elt_slot in
+ let dst_data =
+ get_element_ptr_dyn_in_current_frame
+ dst_vec Abi.vec_elt_data
+ in
+ let src_data =
+ get_element_ptr_dyn_in_current_frame
+ src_vec Abi.vec_elt_data
+ in
+ lea dptr (fst (need_mem_cell dst_data));
+ lea sptr (fst (need_mem_cell src_data));
+ add_to dptr (Il.Cell dst_fill);
+ mov dlim (Il.Cell dptr);
+ add_to dlim (Il.Cell src_fill);
+ let fwd_jmp = mark () in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ let back_jmp_targ = mark () in
+ (* copy slot *)
+ trans_copy_slot
+ (get_ty_params_of_current_frame()) true
+ (deref dptr) dst_elt_slot
+ (deref sptr) src_elt_slot
+ None;
+ add_to dptr dst_elt_sz;
+ add_to sptr src_elt_sz;
+ patch fwd_jmp;
+ check_interrupt_flag ();
+ let back_jmp =
+ trans_compare Il.JB (Il.Cell dptr) (Il.Cell dlim) in
+ List.iter
+ (fun j -> patch_existing j back_jmp_targ) back_jmp;
+ let v = next_vreg_cell word_ty in
+ mov v (Il.Cell src_fill);
+ add_to dst_fill (Il.Cell v);
+ | t ->
+ begin
+ bug () "unsupported vector-append type %a" Ast.sprintf_ty t
+ end
+
+
+ and trans_copy_binop dst binop a_src =
+ let (dst_cell, dst_slot) = trans_lval_maybe_init false dst in
+ let src_oper = trans_atom a_src in
+ match slot_ty dst_slot with
+ Ast.TY_str
+ | Ast.TY_vec _ when binop = Ast.BINOP_add ->
+ trans_vec_append dst_cell dst_slot src_oper (atom_type cx a_src)
+ | _ ->
+ let dst_cell = deref_slot false dst_cell dst_slot in
+ let op = trans_binop binop in
+ emit (Il.binary op dst_cell (Il.Cell dst_cell) src_oper);
+
+
+
+ and trans_stmt_full (stmt:Ast.stmt) : unit =
+ match stmt.node with
+
+ Ast.STMT_log a ->
+ begin
+ match atom_type cx a with
+ (* NB: If you extend this, be sure to update the
+ * typechecking code in type.ml as well. *)
+ Ast.TY_str -> trans_log_str a
+ | Ast.TY_int | Ast.TY_uint | Ast.TY_bool
+ | Ast.TY_char | Ast.TY_mach (TY_u8)
+ | Ast.TY_mach (TY_u16) | Ast.TY_mach (TY_u32)
+ | Ast.TY_mach (TY_i8) | Ast.TY_mach (TY_i16)
+ | Ast.TY_mach (TY_i32) ->
+ trans_log_int a
+ | _ -> bugi cx stmt.id "unimplemented logging type"
+ end
+
+ | Ast.STMT_check_expr e ->
+ begin
+ match expr_type cx e with
+ Ast.TY_bool -> trans_check_expr e
+ | _ -> bugi cx stmt.id "check expr on non-bool"
+ end
+
+ | Ast.STMT_yield ->
+ trans_yield ()
+
+ | Ast.STMT_fail ->
+ trans_fail ()
+
+ | Ast.STMT_join task ->
+ trans_join task
+
+ | Ast.STMT_send (chan,src) ->
+ trans_send chan src
+
+ | Ast.STMT_spawn (dst, domain, plv, args) ->
+ trans_spawn (maybe_init stmt.id "spawn" dst) dst domain plv args
+
+ | Ast.STMT_recv (dst, chan) ->
+ trans_recv (maybe_init stmt.id "recv" dst) dst chan
+
+ | Ast.STMT_copy (dst, e_src) ->
+ trans_copy (maybe_init stmt.id "copy" dst) dst e_src
+
+ | Ast.STMT_copy_binop (dst, binop, a_src) ->
+ trans_copy_binop dst binop a_src
+
+ | Ast.STMT_call (dst, flv, args) ->
+ begin
+ let init = maybe_init stmt.id "call" dst in
+ let ty = lval_ty cx flv in
+ let ty_params =
+ match
+ htab_search
+ cx.ctxt_call_lval_params (lval_base_id flv)
+ with
+ Some params -> params
+ | None -> [| |]
+ in
+ match ty with
+ Ast.TY_fn _ ->
+ let (dst_cell, _) = trans_lval_maybe_init init dst in
+ let fn_ptr =
+ trans_prepare_fn_call init cx dst_cell flv
+ ty_params None args
+ in
+ call_code (code_of_operand fn_ptr)
+ | _ -> bug () "Calling unexpected lval."
+ end
+
+ | Ast.STMT_bind (dst, flv, args) ->
+ begin
+ let init = maybe_init stmt.id "bind" dst in
+ match lval_ty cx flv with
+ Ast.TY_fn (tsig, _) ->
+ trans_bind_fn
+ init (call_ctrl flv) stmt.id dst flv tsig args
+ | _ -> bug () "Binding unexpected lval."
+ end
+
+ | Ast.STMT_init_rec (dst, atab, base) ->
+ let (slot_cell, slot) = trans_lval_init dst in
+ let (trec, dst_slots) =
+ match slot_ty slot with
+ Ast.TY_rec trec -> (trec, Array.map snd trec)
+ | _ ->
+ bugi cx stmt.id
+ "non-rec destination type in stmt_init_rec"
+ in
+ let dst_cell = deref_slot true slot_cell slot in
+ begin
+ match base with
+ None ->
+ let atoms =
+ Array.map (fun (_, _, _, atom) -> atom) atab
+ in
+ trans_init_structural_from_atoms
+ dst_cell dst_slots atoms
+ | Some base_lval ->
+ trans_init_rec_update
+ dst_cell dst_slots trec atab base_lval
+ end
+
+ | Ast.STMT_init_tup (dst, mode_atoms) ->
+ let (slot_cell, slot) = trans_lval_init dst in
+ let dst_slots =
+ match slot_ty slot with
+ Ast.TY_tup ttup -> ttup
+ | _ ->
+ bugi cx stmt.id
+ "non-tup destination type in stmt_init_tup"
+ in
+ let atoms = Array.map (fun (_, _, atom) -> atom) mode_atoms in
+ let dst_cell = deref_slot true slot_cell slot in
+ trans_init_structural_from_atoms dst_cell dst_slots atoms
+
+
+ | Ast.STMT_init_str (dst, s) ->
+ trans_init_str dst s
+
+ | Ast.STMT_init_vec (dst, _, atoms) ->
+ trans_init_vec dst atoms
+
+ | Ast.STMT_init_port dst ->
+ trans_init_port dst
+
+ | Ast.STMT_init_chan (dst, port) ->
+ begin
+ match port with
+ None ->
+ let (dst_cell, _) =
+ trans_lval_init dst
+ in
+ mov dst_cell imm_false
+ | Some p ->
+ trans_init_chan dst p
+ end
+
+ | Ast.STMT_block block ->
+ trans_block block
+
+ | Ast.STMT_while sw ->
+ let (head_stmts, head_expr) = sw.Ast.while_lval in
+ let fwd_jmp = mark () in
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ let block_begin = mark () in
+ trans_block sw.Ast.while_body;
+ patch fwd_jmp;
+ Array.iter trans_stmt head_stmts;
+ check_interrupt_flag ();
+ let back_jmps = trans_cond false head_expr in
+ List.iter (fun j -> patch_existing j block_begin) back_jmps;
+
+ | Ast.STMT_if si ->
+ let skip_thn_jmps = trans_cond true si.Ast.if_test in
+ trans_block si.Ast.if_then;
+ begin
+ match si.Ast.if_else with
+ None -> List.iter patch skip_thn_jmps
+ | Some els ->
+ let skip_els_jmp = mark () in
+ begin
+ emit (Il.jmp Il.JMP Il.CodeNone);
+ List.iter patch skip_thn_jmps;
+ trans_block els;
+ patch skip_els_jmp
+ end
+ end
+
+ | Ast.STMT_check (preds, calls) ->
+ Array.iteri
+ (fun i (fn, args) -> trans_call_pred_and_check preds.(i) fn args)
+ calls
+
+ | Ast.STMT_ret atom_opt ->
+ begin
+ match atom_opt with
+ None -> ()
+ | Some at -> trans_set_outptr at
+ end;
+ drop_slots_at_curr_stmt();
+ Stack.push (mark()) (Stack.top epilogue_jumps);
+ emit (Il.jmp Il.JMP Il.CodeNone)
+
+ | Ast.STMT_be (flv, args) ->
+ let ty = lval_ty cx flv in
+ let ty_params =
+ match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
+ Some params -> params
+ | None -> [| |]
+ in
+ begin
+ match ty with
+ Ast.TY_fn (tsig, _) ->
+ let result_ty = slot_ty tsig.Ast.sig_output_slot in
+ let (dst_mem, _) =
+ need_mem_cell
+ (deref (wordptr_at (fp_imm out_mem_disp)))
+ in
+ let dst_rty = referent_type abi result_ty in
+ let dst_cell = Il.Mem (dst_mem, dst_rty) in
+ trans_be_fn cx dst_cell flv ty_params args
+
+ | _ -> bug () "Calling unexpected lval."
+ end
+
+ | Ast.STMT_put atom_opt ->
+ trans_put atom_opt
+
+ | Ast.STMT_alt_tag stmt_alt_tag -> trans_alt_tag stmt_alt_tag
+
+ | Ast.STMT_decl _ -> ()
+
+ | Ast.STMT_for fo ->
+ trans_for_loop fo
+
+ | Ast.STMT_for_each fe ->
+ trans_for_each_loop stmt.id fe
+
+ | _ -> bugi cx stmt.id "unhandled form of statement in trans_stmt %a"
+ Ast.sprintf_stmt stmt
+
+ and capture_emitted_quads (fix:fixup) (node:node_id) : unit =
+ let e = emitter() in
+ let n_vregs = Il.num_vregs e in
+ let quads = emitted_quads e in
+ let name = path_name () in
+ let f =
+ if Stack.is_empty curr_file
+ then bugi cx node "missing file scope when capturing quads."
+ else Stack.top curr_file
+ in
+ let item_code = Hashtbl.find cx.ctxt_file_code f in
+ begin
+ iflog (fun _ ->
+ log cx "capturing quads for item #%d" (int_of_node node);
+ annotate_quads name);
+ let vr_s =
+ match htab_search cx.ctxt_spill_fixups node with
+ None -> (assert (n_vregs = 0); None)
+ | Some spill -> Some (n_vregs, spill)
+ in
+ let code = { code_fixup = fix;
+ code_quads = quads;
+ code_vregs_and_spill = vr_s; }
+ in
+ htab_put item_code node code;
+ htab_put cx.ctxt_all_item_code node code
+ end
+
+ and get_frame_glue_fns (fnid:node_id) : Il.operand =
+ let n_ty_params = n_item_ty_params cx fnid in
+ let get_frame_glue glue inner =
+ get_mem_glue glue
+ begin
+ fun mem ->
+ iter_frame_and_arg_slots cx fnid
+ begin
+ fun key slot_id slot ->
+ match htab_search cx.ctxt_slot_offsets slot_id with
+ Some off when not (slot_is_obj_state cx slot_id) ->
+ let referent_type = slot_id_referent_type slot_id in
+ let fp_cell = rty_ptr_at mem referent_type in
+ let (fp, st) = force_to_reg (Il.Cell fp_cell) in
+ let ty_params =
+ get_ty_params_of_frame fp n_ty_params
+ in
+ let slot_cell =
+ deref_off_sz ty_params (Il.Reg (fp,st)) off
+ in
+ inner key slot_id ty_params slot slot_cell
+ | _ -> ()
+ end
+ end
+ in
+ trans_crate_rel_data_operand
+ (DATA_frame_glue_fns fnid)
+ begin
+ fun _ ->
+ let mark_frame_glue_fixup =
+ get_frame_glue (GLUE_mark_frame fnid)
+ begin
+ fun _ _ ty_params slot slot_cell ->
+ mark_slot ty_params slot_cell slot None
+ end
+ in
+ let drop_frame_glue_fixup =
+ get_frame_glue (GLUE_drop_frame fnid)
+ begin
+ fun _ _ ty_params slot slot_cell ->
+ drop_slot ty_params slot_cell slot None
+ end
+ in
+ let reloc_frame_glue_fixup =
+ get_frame_glue (GLUE_reloc_frame fnid)
+ begin
+ fun _ _ _ _ _ ->
+ ()
+ end
+ in
+ table_of_crate_rel_fixups
+ [|
+ (*
+ * NB: this must match the struct-offsets given in ABI
+ * & rust runtime library.
+ *)
+ mark_frame_glue_fixup;
+ drop_frame_glue_fixup;
+ reloc_frame_glue_fixup;
+ |]
+ end
+ in
+
+ let trans_frame_entry (fnid:node_id) : unit =
+ let framesz = get_framesz cx fnid in
+ let callsz = get_callsz cx fnid in
+ Stack.push (Stack.create()) epilogue_jumps;
+ push_new_emitter_with_vregs (Some fnid);
+ iflog (fun _ -> annotate "prologue");
+ iflog (fun _ -> annotate (Printf.sprintf
+ "framesz %s"
+ (string_of_size framesz)));
+ iflog (fun _ -> annotate (Printf.sprintf
+ "callsz %s"
+ (string_of_size callsz)));
+ abi.Abi.abi_emit_fn_prologue
+ (emitter()) framesz callsz nabi_rust
+ (upcall_fixup "upcall_grow_task");
+
+ write_frame_info_ptrs (Some fnid);
+ check_interrupt_flag ();
+ iflog (fun _ -> annotate "finished prologue");
+ in
+
+ let trans_frame_exit (fnid:node_id) (drop_args:bool) : unit =
+ Stack.iter patch (Stack.pop epilogue_jumps);
+ if drop_args
+ then
+ begin
+ iflog (fun _ -> annotate "drop args");
+ iter_arg_slots cx fnid callee_drop_slot;
+ end;
+ iflog (fun _ -> annotate "epilogue");
+ abi.Abi.abi_emit_fn_epilogue (emitter());
+ capture_emitted_quads (get_fn_fixup cx fnid) fnid;
+ pop_emitter ()
+ in
+
+ let trans_fn
+ (fnid:node_id)
+ (body:Ast.block)
+ : unit =
+ trans_frame_entry fnid;
+ trans_block body;
+ trans_frame_exit fnid true;
+ in
+
+ let trans_obj_ctor
+ (obj_id:node_id)
+ (state:Ast.header_slots)
+ : unit =
+ trans_frame_entry obj_id;
+
+ let all_args_rty = current_fn_args_rty None in
+ let all_args_cell = caller_args_cell all_args_rty in
+ let frame_args =
+ get_element_ptr_dyn_in_current_frame
+ all_args_cell Abi.calltup_elt_args
+ in
+ let frame_ty_params =
+ get_element_ptr_dyn_in_current_frame
+ all_args_cell Abi.calltup_elt_ty_params
+ in
+
+ let obj_args_tup = Array.map (fun (sloti,_) -> sloti.node) state in
+ let obj_args_slot = interior_slot (Ast.TY_tup obj_args_tup) in
+ let state_ty =
+ Ast.TY_tup [| interior_slot Ast.TY_type;
+ obj_args_slot |]
+ in
+ let state_rty = slot_referent_type abi (interior_slot state_ty) in
+ let state_ptr_slot = exterior_slot state_ty in
+ let state_ptr_rty = slot_referent_type abi state_ptr_slot in
+ let state_malloc_sz =
+ calculate_sz_in_current_frame
+ (SIZE_rt_add
+ ((SIZE_fixed (word_n Abi.exterior_rc_header_size)),
+ (Il.referent_ty_size word_bits state_rty)))
+ in
+
+ let ctor_ty = Hashtbl.find cx.ctxt_all_item_types obj_id in
+ let obj_ty =
+ match ctor_ty with
+ Ast.TY_fn (tsig, _) -> slot_ty tsig.Ast.sig_output_slot
+ | _ -> bug () "object constructor doesn't have function type"
+ in
+ let vtbl_ptr = get_obj_vtbl obj_id in
+ let _ =
+ iflog (fun _ -> annotate "calculate vtbl-ptr from displacement")
+ in
+ let vtbl_cell = crate_rel_to_ptr vtbl_ptr Il.CodeTy in
+
+ let _ = iflog (fun _ -> annotate "load destination obj pair ptr") in
+ let dst_pair_cell = deref (ptr_at (fp_imm out_mem_disp) obj_ty) in
+ let dst_pair_item_cell =
+ get_element_ptr dst_pair_cell Abi.binding_field_item
+ in
+ let dst_pair_state_cell =
+ get_element_ptr dst_pair_cell Abi.binding_field_binding
+ in
+
+ (* Load first cell of pair with vtbl ptr.*)
+ iflog (fun _ -> annotate "mov vtbl-ptr to obj.item cell");
+ mov dst_pair_item_cell (Il.Cell vtbl_cell);
+
+ (* Load second cell of pair with pointer to fresh state tuple.*)
+ iflog (fun _ -> annotate "malloc state-tuple to obj.state cell");
+ trans_malloc dst_pair_state_cell state_malloc_sz;
+
+ (* Copy args into the state tuple. *)
+ let state_ptr = next_vreg_cell (need_scalar_ty state_ptr_rty) in
+ iflog (fun _ -> annotate "load obj.state ptr to vreg");
+ mov state_ptr (Il.Cell dst_pair_state_cell);
+ let state = deref state_ptr in
+ let refcnt = get_element_ptr_dyn_in_current_frame state 0 in
+ let body = get_element_ptr_dyn_in_current_frame state 1 in
+ let obj_tydesc = get_element_ptr_dyn_in_current_frame body 0 in
+ let obj_args = get_element_ptr_dyn_in_current_frame body 1 in
+ iflog (fun _ -> annotate "write refcnt=1 to obj state");
+ mov refcnt one;
+ iflog (fun _ -> annotate "get args-tup tydesc");
+ mov obj_tydesc
+ (Il.Cell (get_tydesc
+ (Some obj_id)
+ (Ast.TY_tup obj_args_tup)));
+ iflog (fun _ -> annotate "copy ctor args to obj args");
+ trans_copy_tup
+ frame_ty_params true
+ obj_args frame_args obj_args_tup;
+ (* We have to do something curious here: we can't drop the
+ * arg slots directly as in the normal frame-exit sequence,
+ * because the arg slot ids are actually given layout
+ * positions inside the object state, and are at different
+ * offsets within that state than within the current
+ * frame. So we manually drop the argument tuple here,
+ * without mentioning the arg slot ids.
+ *)
+ drop_slot frame_ty_params frame_args obj_args_slot None;
+ trans_frame_exit obj_id false;
+ in
+
+ let string_of_name_component (nc:Ast.name_component) : string =
+ match nc with
+ Ast.COMP_ident i -> i
+ | _ -> bug ()
+ "Trans.string_of_name_component on non-COMP_ident"
+ in
+
+
+ let trans_static_name_components
+ (ncs:Ast.name_component list)
+ : Il.operand =
+ let f nc =
+ trans_crate_rel_static_string_frag (string_of_name_component nc)
+ in
+ trans_crate_rel_data_operand
+ (DATA_name (Walk.name_of ncs))
+ (fun _ -> Asm.SEQ (Array.append
+ (Array.map f (Array.of_list ncs))
+ [| Asm.WORD (word_ty_mach, Asm.IMM 0L) |]))
+ in
+
+ let trans_required_fn (fnid:node_id) (blockid:node_id) : unit =
+ trans_frame_entry fnid;
+ emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups blockid));
+ let (ilib, conv) = Hashtbl.find cx.ctxt_required_items fnid in
+ let lib_num =
+ htab_search_or_add cx.ctxt_required_lib_num ilib
+ (fun _ -> Hashtbl.length cx.ctxt_required_lib_num)
+ in
+ let f = next_vreg_cell (Il.AddrTy (Il.CodeTy)) in
+ let n_ty_params = n_item_ty_params cx fnid in
+ let args_rty = direct_call_args_referent_type cx fnid in
+ let caller_args_cell = caller_args_cell args_rty in
+ begin
+ match ilib with
+ REQUIRED_LIB_rust ls ->
+ begin
+ let c_sym_num =
+ htab_search_or_add cx.ctxt_required_c_sym_num
+ (ilib, "rust_crate")
+ (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
+ in
+ let rust_sym_num =
+ htab_search_or_add cx.ctxt_required_rust_sym_num fnid
+ (fun _ -> Hashtbl.length cx.ctxt_required_rust_sym_num)
+ in
+ let path_elts = stk_elts_from_bot path in
+ let _ =
+ assert (ls.required_prefix < (List.length path_elts))
+ in
+ let relative_path_elts =
+ list_drop ls.required_prefix path_elts
+ in
+ let libstr = trans_static_string ls.required_libname in
+ let relpath =
+ trans_static_name_components relative_path_elts
+ in
+ trans_upcall "upcall_require_rust_sym" f
+ [| Il.Cell (curr_crate_ptr());
+ imm (Int64.of_int lib_num);
+ imm (Int64.of_int c_sym_num);
+ imm (Int64.of_int rust_sym_num);
+ libstr;
+ relpath |];
+
+ trans_copy_forward_args args_rty;
+
+ call_code (code_of_operand (Il.Cell f));
+ end
+
+ | REQUIRED_LIB_c ls ->
+ begin
+ let c_sym_str =
+ match htab_search cx.ctxt_required_syms fnid with
+ Some s -> s
+ | None ->
+ string_of_name_component (Stack.top path)
+ in
+ let c_sym_num =
+ (* FIXME: permit remapping symbol names to handle
+ * mangled variants.
+ *)
+ htab_search_or_add cx.ctxt_required_c_sym_num
+ (ilib, c_sym_str)
+ (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
+ in
+ let libstr = trans_static_string ls.required_libname in
+ let symstr = trans_static_string c_sym_str in
+ let check_rty_sz rty =
+ let sz = force_sz (Il.referent_ty_size word_bits rty) in
+ if sz = 0L || sz = word_sz
+ then ()
+ else bug () "bad arg or ret cell size for native require"
+ in
+ let out =
+ get_element_ptr caller_args_cell Abi.calltup_elt_out_ptr
+ in
+ let _ = check_rty_sz (pointee_type out) in
+ let args =
+ let ty_params_cell =
+ get_element_ptr caller_args_cell Abi.calltup_elt_ty_params
+ in
+ let args_cell =
+ get_element_ptr caller_args_cell Abi.calltup_elt_args
+ in
+ let n_args =
+ match args_cell with
+ Il.Mem (_, Il.StructTy elts) -> Array.length elts
+ | _ -> bug () "non-StructTy in Trans.trans_required_fn"
+ in
+ let mk_ty_param i =
+ Il.Cell (get_element_ptr ty_params_cell i)
+ in
+ let mk_arg i =
+ let arg = get_element_ptr args_cell i in
+ let _ = check_rty_sz (Il.cell_referent_ty arg) in
+ Il.Cell arg
+ in
+ Array.append
+ (Array.init n_ty_params mk_ty_param)
+ (Array.init n_args mk_arg)
+ in
+ let nabi = { nabi_convention = conv;
+ nabi_indirect = true }
+ in
+ if conv <> CONV_rust
+ then assert (n_ty_params = 0);
+ trans_upcall "upcall_require_c_sym" f
+ [| Il.Cell (curr_crate_ptr());
+ imm (Int64.of_int lib_num);
+ imm (Int64.of_int c_sym_num);
+ libstr;
+ symstr |];
+
+ abi.Abi.abi_emit_native_call_in_thunk (emitter())
+ out nabi (Il.Cell f) args;
+ end
+
+ | _ -> bug ()
+ "Trans.required_rust_fn on unexpected form of require library"
+ end;
+ emit Il.Leave;
+ match ilib with
+ REQUIRED_LIB_rust _ ->
+ trans_frame_exit fnid false;
+ | REQUIRED_LIB_c _ ->
+ trans_frame_exit fnid true;
+ | _ -> bug ()
+ "Trans.required_rust_fn on unexpected form of require library"
+ in
+
+ let trans_tag
+ (n:Ast.ident)
+ (tagid:node_id)
+ (tag:(Ast.header_tup * Ast.ty_tag * node_id))
+ : unit =
+ trans_frame_entry tagid;
+ trace_str cx.ctxt_sess.Session.sess_trace_tag
+ ("in tag constructor " ^ n);
+ let (header_tup, _, _) = tag in
+ let ctor_ty = Hashtbl.find cx.ctxt_all_item_types tagid in
+ let ttag =
+ match ctor_ty with
+ Ast.TY_fn (tsig, _) ->
+ begin
+ match slot_ty tsig.Ast.sig_output_slot with
+ Ast.TY_tag ttag -> ttag
+ | Ast.TY_iso tiso -> get_iso_tag tiso
+ | _ -> bugi cx tagid "unexpected fn type for tag constructor"
+ end
+ | _ -> bugi cx tagid "unexpected type for tag constructor"
+ in
+ let slots =
+ Array.map (fun sloti -> referent_to_slot cx sloti.id) header_tup
+ in
+ let tag_keys = sorted_htab_keys ttag in
+ let i = arr_idx tag_keys (Ast.NAME_base (Ast.BASE_ident n)) in
+ let _ = log cx "tag variant: %s -> tag value #%d" n i in
+ let out_cell = deref (ptr_at (fp_imm out_mem_disp) (Ast.TY_tag ttag)) in
+ let tag_cell = get_element_ptr out_cell 0 in
+ let union_cell = get_element_ptr_dyn_in_current_frame out_cell 1 in
+ let dst = get_variant_ptr union_cell i in
+ let dst_ty = snd (need_mem_cell dst) in
+ let src = get_explicit_args_for_current_frame () in
+ (* A clever compiler will inline this. We are not clever. *)
+ iflog (fun _ -> annotate (Printf.sprintf "write tag #%d" i));
+ mov tag_cell (imm (Int64.of_int i));
+ iflog (fun _ -> annotate ("copy tag-content tuple: dst_ty=" ^
+ (Il.string_of_referent_ty dst_ty)));
+ trans_copy_tup (get_ty_params_of_current_frame()) true dst src slots;
+ trace_str cx.ctxt_sess.Session.sess_trace_tag
+ ("finished tag constructor " ^ n);
+ trans_frame_exit tagid true;
+ in
+
+ let enter_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then Stack.push id curr_file
+ in
+
+ let leave_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then
+ if Stack.is_empty curr_file
+ then bugi cx id "Missing source file on file-scope exit."
+ else ignore (Stack.pop curr_file)
+ in
+
+ let visit_local_mod_item_pre n _ i =
+ iflog (fun _ -> log cx "translating local item #%d = %s"
+ (int_of_node i.id) (path_name()));
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f -> trans_fn i.id f.Ast.fn_body
+ | Ast.MOD_ITEM_tag t -> trans_tag n i.id t
+ | Ast.MOD_ITEM_obj ob ->
+ trans_obj_ctor i.id
+ (Array.map (fun (sloti,ident) ->
+ ({sloti with node = get_slot cx sloti.id},ident))
+ ob.Ast.obj_state)
+ | _ -> ()
+ in
+
+ let visit_required_mod_item_pre _ _ i =
+ iflog (fun _ -> log cx "translating required item #%d = %s"
+ (int_of_node i.id) (path_name()));
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f -> trans_required_fn i.id f.Ast.fn_body.id
+ | Ast.MOD_ITEM_mod _ -> ()
+ | Ast.MOD_ITEM_type _ -> ()
+ | _ -> bugi cx i.id "unsupported type of require: %s" (path_name())
+ in
+
+ let visit_obj_drop_pre obj b =
+ let g = GLUE_obj_drop obj.id in
+ let fix =
+ match htab_search cx.ctxt_glue_code g with
+ Some code -> code.code_fixup
+ | None -> bug () "visit_obj_drop_pre without assigned fixup"
+ in
+ let framesz = get_framesz cx b.id in
+ let callsz = get_callsz cx b.id in
+ let spill = Hashtbl.find cx.ctxt_spill_fixups b.id in
+ push_new_emitter_with_vregs (Some b.id);
+ iflog (fun _ -> annotate "prologue");
+ abi.Abi.abi_emit_fn_prologue (emitter())
+ framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
+ write_frame_info_ptrs None;
+ iflog (fun _ -> annotate "finished prologue");
+ trans_block b;
+ Hashtbl.remove cx.ctxt_glue_code g;
+ trans_glue_frame_exit fix spill g;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_local_obj_fn_pre _ _ fn =
+ trans_fn fn.id fn.node.Ast.fn_body
+ in
+
+ let visit_required_obj_fn_pre _ _ _ =
+ ()
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ enter_file_for fn.id;
+ begin
+ if Hashtbl.mem cx.ctxt_required_items fn.id
+ then
+ visit_required_obj_fn_pre obj ident fn
+ else
+ visit_local_obj_fn_pre obj ident fn;
+ end;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_mod_item_pre n p i =
+ enter_file_for i.id;
+ begin
+ if Hashtbl.mem cx.ctxt_required_items i.id
+ then
+ visit_required_mod_item_pre n p i
+ else
+ visit_local_mod_item_pre n p i
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_mod_item_post n p i =
+ inner.Walk.visit_mod_item_post n p i;
+ leave_file_for i.id
+ in
+
+ let visit_obj_fn_post obj ident fn =
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ leave_file_for fn.id
+ in
+
+ let visit_crate_pre crate =
+ enter_file_for crate.id;
+ inner.Walk.visit_crate_pre crate
+ in
+
+ let visit_crate_post crate =
+
+ inner.Walk.visit_crate_post crate;
+
+ let emit_aux_global_glue cx glue fix fn =
+ let glue_name = glue_str cx glue in
+ push_new_emitter_without_vregs None;
+ let e = emitter() in
+ fn e;
+ iflog (fun _ -> annotate_quads glue_name);
+ if (Il.num_vregs e) != 0
+ then bug () "%s uses nonzero vregs" glue_name;
+ pop_emitter();
+ let code =
+ { code_fixup = fix;
+ code_quads = emitted_quads e;
+ code_vregs_and_spill = None; }
+ in
+ htab_put cx.ctxt_glue_code glue code
+ in
+
+ let tab_sz htab =
+ Asm.WORD (word_ty_mach, Asm.IMM (Int64.of_int (Hashtbl.length htab)))
+ in
+
+ let crate_data =
+ (cx.ctxt_crate_fixup,
+ Asm.DEF
+ (cx.ctxt_crate_fixup,
+ Asm.SEQ [|
+ (*
+ * NB: this must match the rust_crate structure
+ * in the rust runtime library.
+ *)
+ crate_rel_word cx.ctxt_image_base_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_POS cx.ctxt_crate_fixup);
+
+ crate_rel_word cx.ctxt_debug_abbrev_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_abbrev_fixup);
+
+ crate_rel_word cx.ctxt_debug_info_fixup;
+ Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_info_fixup);
+
+ crate_rel_word cx.ctxt_activate_fixup;
+ crate_rel_word cx.ctxt_exit_task_fixup;
+ crate_rel_word cx.ctxt_unwind_fixup;
+ crate_rel_word cx.ctxt_yield_fixup;
+
+ tab_sz cx.ctxt_required_rust_sym_num;
+ tab_sz cx.ctxt_required_c_sym_num;
+ tab_sz cx.ctxt_required_lib_num;
+ |]))
+ in
+
+ (* Emit additional glue we didn't do elsewhere. *)
+ emit_aux_global_glue cx GLUE_activate
+ cx.ctxt_activate_fixup
+ abi.Abi.abi_activate;
+
+ emit_aux_global_glue cx GLUE_yield
+ cx.ctxt_yield_fixup
+ abi.Abi.abi_yield;
+
+ emit_aux_global_glue cx GLUE_unwind
+ cx.ctxt_unwind_fixup
+ (fun e -> abi.Abi.abi_unwind
+ e nabi_rust (upcall_fixup "upcall_exit"));
+
+ ignore (get_exit_task_glue ());
+
+ begin
+ match abi.Abi.abi_get_next_pc_thunk with
+ None -> ()
+ | Some (_, fix, fn) ->
+ emit_aux_global_glue cx GLUE_get_next_pc fix fn
+ end;
+
+ htab_put cx.ctxt_data
+ DATA_crate crate_data;
+
+ provide_existing_native cx SEG_data "rust_crate" cx.ctxt_crate_fixup;
+
+ leave_file_for crate.id
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_pre;
+ Walk.visit_crate_post = visit_crate_post;
+ 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;
+ }
+;;
+
+
+let fixup_assigning_visitor
+ (cx:ctxt)
+ (path:Ast.name_component Stack.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let path_name (_:unit) : string =
+ Ast.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
+ in
+
+ let enter_file_for id =
+ if Hashtbl.mem cx.ctxt_item_files id
+ then
+ begin
+ let name =
+ if Stack.is_empty path
+ then "crate root"
+ else path_name()
+ in
+ htab_put cx.ctxt_file_fixups id (new_fixup name);
+ if not (Hashtbl.mem cx.ctxt_file_code id)
+ then htab_put cx.ctxt_file_code id (Hashtbl.create 0);
+ end
+ in
+
+ let visit_mod_item_pre n p i =
+ enter_file_for i.id;
+ begin
+ match i.node.Ast.decl_item with
+
+ Ast.MOD_ITEM_tag _ ->
+ htab_put cx.ctxt_fn_fixups i.id
+ (new_fixup (path_name()));
+
+ | Ast.MOD_ITEM_fn _ ->
+ begin
+ let path = path_name () in
+ let fixup =
+ if (not cx.ctxt_sess.Session.sess_library_mode)
+ && (Some path) = cx.ctxt_main_name
+ then
+ match cx.ctxt_main_fn_fixup with
+ None -> bug () "missing main fixup in trans"
+ | Some fix -> fix
+ else
+ new_fixup path
+ in
+ htab_put cx.ctxt_fn_fixups i.id fixup;
+ end
+
+ | Ast.MOD_ITEM_obj _ ->
+ htab_put cx.ctxt_fn_fixups i.id
+ (new_fixup (path_name()));
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ htab_put cx.ctxt_fn_fixups fn.id
+ (new_fixup (path_name()));
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_drop_pre obj b =
+ let g = GLUE_obj_drop obj.id in
+ let fix = new_fixup (path_name()) in
+ let tmp_code = { code_fixup = fix;
+ code_quads = [| |];
+ code_vregs_and_spill = None; } in
+ htab_put cx.ctxt_glue_code g tmp_code;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_block_pre b =
+ htab_put cx.ctxt_block_fixups b.id (new_fixup "lexical block");
+ inner.Walk.visit_block_pre b
+ in
+
+ let visit_crate_pre c =
+ enter_file_for c.id;
+ inner.Walk.visit_crate_pre c
+ in
+
+ { inner with
+ Walk.visit_crate_pre = visit_crate_pre;
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+ Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+ Walk.visit_block_pre = visit_block_pre; }
+
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let passes =
+ [|
+ (fixup_assigning_visitor cx path
+ Walk.empty_visitor);
+ (Walk.mod_item_logging_visitor
+ (log cx "translation pass: %s")
+ path
+ (trans_visitor cx path
+ Walk.empty_visitor))
+ |];
+ in
+ log cx "translating crate";
+ begin
+ match cx.ctxt_main_name with
+ None -> ()
+ | Some m -> log cx "with main fn %s" m
+ end;
+ run_passes cx "trans" path passes (log cx "%s") crate;
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/transutil.ml b/src/boot/me/transutil.ml
new file mode 100644
index 00000000..c430e034
--- /dev/null
+++ b/src/boot/me/transutil.ml
@@ -0,0 +1,238 @@
+open Common;;
+open Semant;;
+
+(* A note on GC:
+ *
+ * We employ -- or "will employ" when the last few pieces of it are done -- a
+ * "simple" precise, mark-sweep, single-generation, per-task (thereby
+ * preemptable and relatively quick) GC scheme on mutable memory.
+ *
+ * - For the sake of this note, call any exterior of 'state' effect a gc_val.
+ *
+ * - gc_vals come from the same malloc as all other values but undergo
+ * different storage management.
+ *
+ * - Every frame has a frame_glue_fns pointer in its fp[-1] slot, written on
+ * function-entry.
+ *
+ * - gc_vals have *three* extra words at their head, not one.
+ *
+ * - A pointer to a gc_val, however, points to the third of these three
+ * words. So a certain quantity of code can treat gc_vals the same way it
+ * would treat refcounted exterior vals.
+ *
+ * - The first word at the head of a gc_val is used as a refcount, as in
+ * non-gc allocations.
+ *
+ * - The (-1)st word at the head of a gc_val is a pointer to a tydesc,
+ * with the low bit of that pointer used as a mark bit.
+ *
+ * - The (-2)nd word at the head of a gc_val is a linked-list pointer to the
+ * gc_val that was allocated (temporally) just before it. Following this
+ * list traces through all the currently active gc_vals in a task.
+ *
+ * - The task has a gc_alloc_chain field that points to the most-recent
+ * gc_val allocated.
+ *
+ * - GC glue has two phases, mark and sweep:
+ *
+ * - The mark phase walks down the frame chain, like the unwinder. It calls
+ * each frame's mark glue as it's passing through. This will mark all the
+ * reachable parts of the task's gc_vals.
+ *
+ * - The sweep phase walks down the task's gc_alloc_chain checking to see
+ * if each allocation has been marked. If marked, it has its mark-bit
+ * reset and the sweep passes it by. If unmarked, it has its tydesc
+ * free_glue called on its body, and is unlinked from the chain. The
+ * free-glue will cause the allocation to (recursively) drop all of its
+ * references and/or run dtors.
+ *
+ * - Note that there is no "special gc state" at work here; the task looks
+ * like it's running normal code that happens to not perform any gc_val
+ * allocation. Mark-bit twiddling is open-coded into all the mark
+ * functions, which know their contents; we only have to do O(frames)
+ * indirect calls to mark, the rest are static. Sweeping costs O(gc-heap)
+ * indirect calls, unfortunately, because the set of sweep functions to
+ * call is arbitrary based on allocation order.
+ *)
+
+
+type mem_ctrl =
+ MEM_rc_opaque
+ | MEM_rc_struct
+ | MEM_gc
+ | MEM_interior
+;;
+
+type clone_ctrl =
+ CLONE_none
+ | CLONE_chan of Il.cell
+ | CLONE_all of Il.cell
+;;
+
+type call_ctrl =
+ CALL_direct
+ | CALL_vtbl
+ | CALL_indirect
+;;
+
+type for_each_ctrl =
+ {
+ for_each_fixup: fixup;
+ for_each_depth: int;
+ }
+;;
+
+let word_sz (abi:Abi.abi) : int64 =
+ abi.Abi.abi_word_sz
+;;
+
+let word_n (abi:Abi.abi) (n:int) : int64 =
+ Int64.mul (word_sz abi) (Int64.of_int n)
+;;
+
+let word_bits (abi:Abi.abi) : Il.bits =
+ abi.Abi.abi_word_bits
+;;
+
+let word_ty_mach (abi:Abi.abi) : ty_mach =
+ match word_bits abi with
+ Il.Bits8 -> TY_u8
+ | Il.Bits16 -> TY_u16
+ | Il.Bits32 -> TY_u32
+ | Il.Bits64 -> TY_u64
+;;
+
+let word_ty_signed_mach (abi:Abi.abi) : ty_mach =
+ match word_bits abi with
+ Il.Bits8 -> TY_i8
+ | Il.Bits16 -> TY_i16
+ | Il.Bits32 -> TY_i32
+ | Il.Bits64 -> TY_i64
+;;
+
+
+let slot_mem_ctrl (slot:Ast.slot) : mem_ctrl =
+ let ty = slot_ty slot in
+ match ty with
+ Ast.TY_port _
+ | Ast.TY_chan _
+ | Ast.TY_task
+ | Ast.TY_vec _
+ | Ast.TY_str -> MEM_rc_opaque
+ | _ ->
+ match slot.Ast.slot_mode with
+ Ast.MODE_exterior _ when type_is_structured ty ->
+ if type_has_state ty
+ then MEM_gc
+ else MEM_rc_struct
+ | Ast.MODE_exterior _ ->
+ MEM_rc_opaque
+ | _ ->
+ MEM_interior
+;;
+
+
+let iter_block_slots
+ (cx:Semant.ctxt)
+ (block_id:node_id)
+ (fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
+ : unit =
+ let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
+ Hashtbl.iter
+ begin
+ fun key slot_id ->
+ let slot = referent_to_slot cx slot_id in
+ fn key slot_id slot
+ end
+ block_slots
+;;
+
+let iter_frame_slots
+ (cx:Semant.ctxt)
+ (frame_id:node_id)
+ (fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
+ : unit =
+ let blocks = Hashtbl.find cx.ctxt_frame_blocks frame_id in
+ List.iter (fun block -> iter_block_slots cx block fn) blocks
+;;
+
+let iter_arg_slots
+ (cx:Semant.ctxt)
+ (frame_id:node_id)
+ (fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
+ : unit =
+ match htab_search cx.ctxt_frame_args frame_id with
+ None -> ()
+ | Some ls ->
+ List.iter
+ begin
+ fun slot_id ->
+ let key = Hashtbl.find cx.ctxt_slot_keys slot_id in
+ let slot = referent_to_slot cx slot_id in
+ fn key slot_id slot
+ end
+ ls
+;;
+
+let iter_frame_and_arg_slots
+ (cx:Semant.ctxt)
+ (frame_id:node_id)
+ (fn:Ast.slot_key -> node_id -> Ast.slot -> unit)
+ : unit =
+ iter_frame_slots cx frame_id fn;
+ iter_arg_slots cx frame_id fn;
+;;
+
+let next_power_of_two (x:int64) : int64 =
+ let xr = ref (Int64.sub x 1L) in
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 1);
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 2);
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 4);
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 8);
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 16);
+ xr := Int64.logor (!xr) (Int64.shift_right_logical (!xr) 32);
+ Int64.add 1L (!xr)
+;;
+
+let iter_tup_slots
+ (get_element_ptr:'a -> int -> 'a)
+ (dst_ptr:'a)
+ (src_ptr:'a)
+ (slots:Ast.ty_tup)
+ (f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ Array.iteri
+ begin
+ fun i slot ->
+ f (get_element_ptr dst_ptr i)
+ (get_element_ptr src_ptr i)
+ slot curr_iso
+ end
+ slots
+;;
+
+let iter_rec_slots
+ (get_element_ptr:'a -> int -> 'a)
+ (dst_ptr:'a)
+ (src_ptr:'a)
+ (entries:Ast.ty_rec)
+ (f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
+ (curr_iso:Ast.ty_iso option)
+ : unit =
+ iter_tup_slots get_element_ptr dst_ptr src_ptr
+ (Array.map snd entries) f curr_iso
+;;
+
+
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
new file mode 100644
index 00000000..2d4dd94a
--- /dev/null
+++ b/src/boot/me/type.ml
@@ -0,0 +1,1294 @@
+open Common;;
+open Semant;;
+
+type tyspec =
+ TYSPEC_equiv of tyvar
+ | TYSPEC_all
+ | TYSPEC_resolved of (Ast.ty_param array) * Ast.ty
+ | TYSPEC_callable of (tyvar * tyvar array) (* out, ins *)
+ | TYSPEC_collection of tyvar (* vec or str *)
+ | TYSPEC_comparable (* comparable with = and != *)
+ | TYSPEC_plusable (* nums, vecs, and strings *)
+ | TYSPEC_dictionary of dict
+ | TYSPEC_integral (* int-like *)
+ | TYSPEC_loggable
+ | TYSPEC_numeric (* int-like or float-like *)
+ | TYSPEC_ordered (* comparable with < etc. *)
+ | TYSPEC_record of dict
+ | TYSPEC_tuple of tyvar array (* heterogeneous tuple *)
+ | TYSPEC_vector of tyvar
+ | TYSPEC_app of (tyvar * Ast.ty array)
+
+and dict = (Ast.ident, tyvar) Hashtbl.t
+
+and tyvar = tyspec ref;;
+
+(* Signatures for binary operators. *)
+type binopsig =
+ BINOPSIG_bool_bool_bool (* bool * bool -> bool *)
+ | BINOPSIG_comp_comp_bool (* comparable a * comparable a -> bool *)
+ | BINOPSIG_ord_ord_bool (* ordered a * ordered a -> bool *)
+ | BINOPSIG_integ_integ_integ (* integral a * integral a -> integral a *)
+ | BINOPSIG_num_num_num (* numeric a * numeric a -> numeric a *)
+ | BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *)
+;;
+
+let rec tyspec_to_str (ts:tyspec) : string =
+
+ let fmt = Format.fprintf in
+ let fmt_ident (ff:Format.formatter) (i:Ast.ident) : unit =
+ fmt ff "%s" i
+ in
+ let fmt_obox ff = Format.pp_open_box ff 4 in
+ let fmt_cbox ff = Format.pp_close_box ff () in
+ let fmt_obr ff = fmt ff "<" in
+ let fmt_cbr ff = fmt ff ">" in
+ let fmt_obb ff = (fmt_obox ff; fmt_obr ff) in
+ let fmt_cbb ff = (fmt_cbox ff; fmt_cbr ff) in
+
+ let rec fmt_fields (flav:string) (ff:Format.formatter) (flds:dict) : unit =
+ fmt_obb ff;
+ fmt ff "%s :" flav;
+ let fmt_entry ident tv =
+ fmt ff "@\n";
+ fmt_ident ff ident;
+ fmt ff " : ";
+ fmt_tyspec ff (!tv);
+ in
+ Hashtbl.iter fmt_entry flds;
+ fmt_cbb ff
+
+ and fmt_app ff tv args =
+ begin
+ assert (Array.length args <> 0);
+ fmt_obb ff;
+ fmt ff "app(";
+ fmt_tyspec ff (!tv);
+ fmt ff ")";
+ Ast.fmt_app_args ff args;
+ fmt_cbb ff;
+ end
+
+ and fmt_tvs ff tvs =
+ fmt_obox ff;
+ let fmt_tv i tv =
+ if i <> 0
+ then fmt ff ", ";
+ fmt_tyspec ff (!tv)
+ in
+ Array.iteri fmt_tv tvs;
+ fmt_cbox ff;
+
+ and fmt_tyspec ff ts =
+ match ts with
+ TYSPEC_all -> fmt ff "<?>"
+ | TYSPEC_comparable -> fmt ff "<comparable>"
+ | TYSPEC_plusable -> fmt ff "<plusable>"
+ | TYSPEC_integral -> fmt ff "<integral>"
+ | TYSPEC_loggable -> fmt ff "<loggable>"
+ | TYSPEC_numeric -> fmt ff "<numeric>"
+ | TYSPEC_ordered -> fmt ff "<ordered>"
+ | TYSPEC_resolved (params, ty) ->
+ if Array.length params <> 0
+ then
+ begin
+ fmt ff "abs";
+ Ast.fmt_decl_params ff params;
+ fmt ff "(";
+ Ast.fmt_ty ff ty;
+ fmt ff ")"
+ end
+ else
+ Ast.fmt_ty ff ty
+
+ | TYSPEC_equiv tv ->
+ fmt_tyspec ff (!tv)
+
+ | TYSPEC_callable (out, ins) ->
+ fmt_obb ff;
+ fmt ff "callable fn(";
+ fmt_tvs ff ins;
+ fmt ff ") -> ";
+ fmt_tyspec ff (!out);
+ fmt_cbb ff;
+
+ | TYSPEC_collection tv ->
+ fmt_obb ff;
+ fmt ff "collection : ";
+ fmt_tyspec ff (!tv);
+ fmt_cbb ff;
+
+ | TYSPEC_tuple tvs ->
+ fmt ff "(";
+ fmt_tvs ff tvs;
+ fmt ff ")";
+
+ | TYSPEC_vector tv ->
+ fmt_obb ff;
+ fmt ff "vector ";
+ fmt_tyspec ff (!tv);
+ fmt_cbb ff;
+
+ | TYSPEC_dictionary dct ->
+ fmt_fields "dictionary" ff dct
+
+ | TYSPEC_record dct ->
+ fmt_fields "record" ff dct
+
+ | TYSPEC_app (tv, args) ->
+ fmt_app ff tv args
+
+ in
+ let buf = Buffer.create 16 in
+ let bf = Format.formatter_of_buffer buf in
+ begin
+ fmt_tyspec bf ts;
+ Format.pp_print_flush bf ();
+ Buffer.contents buf
+ end
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_type
+ then thunk ()
+ else ()
+;;
+
+let rec resolve_tyvar (tv:tyvar) : tyvar =
+ match !tv with
+ TYSPEC_equiv subtv -> resolve_tyvar subtv
+ | _ -> tv
+;;
+
+let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
+ let log cx = Session.log "type"
+ cx.ctxt_sess.Session.sess_log_type
+ cx.ctxt_sess.Session.sess_log_out
+ in
+ let retval_tvs = Stack.create () in
+ let push_retval_tv tv =
+ Stack.push tv retval_tvs
+ in
+ let pop_retval_tv _ =
+ ignore (Stack.pop retval_tvs)
+ in
+ let retval_tv _ =
+ Stack.top retval_tvs
+ in
+ let (bindings:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 10 in
+ let (item_params:(node_id, tyvar array) Hashtbl.t) = Hashtbl.create 10 in
+ let (lval_tyvars:(node_id, tyvar) Hashtbl.t) = Hashtbl.create 0 in
+
+ let path = Stack.create () in
+
+ let visitor (cx:ctxt) (inner:Walk.visitor) : Walk.visitor =
+
+ let rec unify_slot
+ (slot:Ast.slot)
+ (id_opt:node_id option)
+ (tv:tyvar) : unit =
+ match id_opt with
+ Some id -> unify_tyvars (Hashtbl.find bindings id) tv
+ | None ->
+ match slot.Ast.slot_ty with
+ None -> bug () "untyped unidentified slot"
+ | Some ty -> unify_ty ty tv
+
+ and check_sane_tyvar tv =
+ match !tv with
+ TYSPEC_resolved (_, (Ast.TY_named _)) ->
+ bug () "named-type in type checker"
+ | _ -> ()
+
+ and unify_tyvars (av:tyvar) (bv:tyvar) : unit =
+ iflog cx (fun _ ->
+ log cx "unifying types:";
+ log cx "input tyvar A: %s" (tyspec_to_str !av);
+ log cx "input tyvar B: %s" (tyspec_to_str !bv));
+ check_sane_tyvar av;
+ check_sane_tyvar bv;
+
+ unify_tyvars' av bv;
+
+ iflog cx (fun _ ->
+ log cx "unified types:";
+ log cx "output tyvar A: %s" (tyspec_to_str !av);
+ log cx "output tyvar B: %s" (tyspec_to_str !bv));
+ check_sane_tyvar av;
+ check_sane_tyvar bv;
+
+ and unify_tyvars' (av:tyvar) (bv:tyvar) : unit =
+ let (a, b) = ((resolve_tyvar av), (resolve_tyvar bv)) in
+ let fail () =
+ err None "mismatched types: %s vs. %s" (tyspec_to_str !av)
+ (tyspec_to_str !bv);
+ in
+
+ let merge_dicts a b =
+ let c = Hashtbl.create ((Hashtbl.length a) + (Hashtbl.length b)) in
+ let merge ident tv_a =
+ if Hashtbl.mem c ident
+ then unify_tyvars (Hashtbl.find c ident) tv_a
+ else Hashtbl.add c ident tv_a
+ in
+ Hashtbl.iter (Hashtbl.add c) b;
+ Hashtbl.iter merge a;
+ c
+ in
+
+ let unify_dict_with_record_fields
+ (dct:dict)
+ (fields:Ast.ty_rec)
+ : unit =
+ let rec find_slot (query:Ast.ident) i : Ast.slot =
+ if i = Array.length fields
+ then fail ()
+ else match fields.(i) with
+ (ident, slot) ->
+ if ident = query then slot
+ else find_slot query (i + 1)
+ in
+
+ let check_entry ident tv =
+ unify_slot (find_slot ident 0) None tv
+ in
+ Hashtbl.iter check_entry dct
+ in
+
+ let unify_dict_with_obj_fns
+ (dct:dict)
+ (fns:(Ast.ident,Ast.ty_fn) Hashtbl.t) : unit =
+ let check_entry (query:Ast.ident) tv : unit =
+ match htab_search fns query with
+ None -> fail ()
+ | Some fn -> unify_ty (Ast.TY_fn fn) tv
+ in
+ Hashtbl.iter check_entry dct
+ in
+
+ let rec is_comparable_or_ordered (comparable:bool) (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_mach _ | Ast.TY_int | Ast.TY_uint
+ | Ast.TY_char | Ast.TY_str -> true
+ | Ast.TY_any | Ast.TY_nil | Ast.TY_bool | Ast.TY_chan _
+ | Ast.TY_port _ | Ast.TY_task | Ast.TY_tup _ | Ast.TY_vec _
+ | Ast.TY_rec _ | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_idx _ ->
+ comparable
+ | Ast.TY_fn _ | Ast.TY_obj _
+ | Ast.TY_param _ | Ast.TY_native _ | Ast.TY_type -> false
+ | Ast.TY_named _ -> bug () "unexpected named type"
+ | Ast.TY_constrained (ty, _) ->
+ is_comparable_or_ordered comparable ty
+ in
+
+ let floating (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true
+ | _ -> false
+ in
+
+ let integral (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_int | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16
+ | Ast.TY_mach TY_u32 | Ast.TY_mach TY_u64 | Ast.TY_mach TY_i8
+ | Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
+ | Ast.TY_mach TY_i64 ->
+ true
+ | _ -> false
+ in
+
+ let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in
+
+ let plusable (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_str -> true
+ | Ast.TY_vec _ -> true
+ | _ -> numeric ty
+ in
+
+ let loggable (ty:Ast.ty) : bool =
+ match ty with
+ Ast.TY_str | Ast.TY_bool | Ast.TY_int | Ast.TY_uint
+ | Ast.TY_char
+ | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16 | Ast.TY_mach TY_u32
+ | Ast.TY_mach TY_i8 | Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
+ -> true
+ | _ -> false
+ in
+
+ let result =
+ match (!a, !b) with
+ (TYSPEC_equiv _, _) | (_, TYSPEC_equiv _) ->
+ bug () "equiv found even though tyvar was resolved"
+
+ | (TYSPEC_all, other) | (other, TYSPEC_all) -> other
+
+ (* resolved *)
+
+ | (TYSPEC_resolved (params_a, ty_a),
+ TYSPEC_resolved (params_b, ty_b)) ->
+ if params_a <> params_b || ty_a <> ty_b
+ then fail()
+ else TYSPEC_resolved (params_a, ty_a)
+
+ | (TYSPEC_resolved (params, ty),
+ TYSPEC_callable (out_tv, in_tvs))
+ | (TYSPEC_callable (out_tv, in_tvs),
+ TYSPEC_resolved (params, ty)) ->
+ let unify_in_slot i in_slot =
+ unify_slot in_slot None in_tvs.(i)
+ in
+ begin
+ match ty with
+ Ast.TY_fn ({
+ Ast.sig_input_slots = in_slots;
+ Ast.sig_output_slot = out_slot
+ }, _) ->
+ if Array.length in_slots != Array.length in_tvs
+ then fail ();
+ unify_slot out_slot None out_tv;
+ Array.iteri unify_in_slot in_slots
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_collection tv)
+ | (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_vec slot -> unify_slot slot None tv
+ | Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_comparable)
+ | (TYSPEC_comparable, TYSPEC_resolved (params, ty)) ->
+ if not (is_comparable_or_ordered true ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_resolved (params, ty)) ->
+ if not (plusable ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_dictionary dct)
+ | (TYSPEC_dictionary dct, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_rec fields ->
+ unify_dict_with_record_fields dct fields
+ | Ast.TY_obj (_, fns) ->
+ unify_dict_with_obj_fns dct fns
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_resolved (params, ty)) ->
+ if not (integral ty)
+ then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_resolved (params, ty)) ->
+ if not (loggable ty)
+ then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_resolved (params, ty)) ->
+ if not (numeric ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_resolved (params, ty)) ->
+ if not (is_comparable_or_ordered false ty) then fail ()
+ else TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_app (tv, args))
+ | (TYSPEC_app (tv, args), TYSPEC_resolved (params, ty)) ->
+ let ty = rebuild_ty_under_params ty params args false in
+ unify_ty ty tv;
+ TYSPEC_resolved ([| |], ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_record dct)
+ | (TYSPEC_record dct, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_rec fields ->
+ unify_dict_with_record_fields dct fields
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_tuple tvs)
+ | (TYSPEC_tuple tvs, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_tup (elem_slots:Ast.slot array) ->
+ if (Array.length elem_slots) < (Array.length tvs)
+ then fail ()
+ else
+ let check_elem i tv =
+ unify_slot (elem_slots.(i)) None tv
+ in
+ Array.iteri check_elem tvs
+ | _ -> fail ()
+ end;
+ TYSPEC_resolved (params, ty)
+
+ | (TYSPEC_resolved (params, ty), TYSPEC_vector tv)
+ | (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) ->
+ begin
+ match ty with
+ Ast.TY_vec slot ->
+ unify_slot slot None tv;
+ TYSPEC_resolved (params, ty)
+ | _ -> fail ()
+ end
+
+ (* callable *)
+
+ | (TYSPEC_callable (a_out_tv, a_in_tvs),
+ TYSPEC_callable (b_out_tv, b_in_tvs)) ->
+ unify_tyvars a_out_tv b_out_tv;
+ let check_in_tv i a_in_tv =
+ unify_tyvars a_in_tv b_in_tvs.(i)
+ in
+ Array.iteri check_in_tv a_in_tvs;
+ TYSPEC_callable (a_out_tv, a_in_tvs)
+
+ | (TYSPEC_callable _, TYSPEC_collection _)
+ | (TYSPEC_callable _, TYSPEC_comparable)
+ | (TYSPEC_callable _, TYSPEC_plusable)
+ | (TYSPEC_callable _, TYSPEC_dictionary _)
+ | (TYSPEC_callable _, TYSPEC_integral)
+ | (TYSPEC_callable _, TYSPEC_loggable)
+ | (TYSPEC_callable _, TYSPEC_numeric)
+ | (TYSPEC_callable _, TYSPEC_ordered)
+ | (TYSPEC_callable _, TYSPEC_app _)
+ | (TYSPEC_callable _, TYSPEC_record _)
+ | (TYSPEC_callable _, TYSPEC_tuple _)
+ | (TYSPEC_callable _, TYSPEC_vector _)
+ | (TYSPEC_collection _, TYSPEC_callable _)
+ | (TYSPEC_comparable, TYSPEC_callable _)
+ | (TYSPEC_plusable, TYSPEC_callable _)
+ | (TYSPEC_dictionary _, TYSPEC_callable _)
+ | (TYSPEC_integral, TYSPEC_callable _)
+ | (TYSPEC_loggable, TYSPEC_callable _)
+ | (TYSPEC_numeric, TYSPEC_callable _)
+ | (TYSPEC_ordered, TYSPEC_callable _)
+ | (TYSPEC_app _, TYSPEC_callable _)
+ | (TYSPEC_record _, TYSPEC_callable _)
+ | (TYSPEC_tuple _, TYSPEC_callable _)
+ | (TYSPEC_vector _, TYSPEC_callable _) -> fail ()
+
+ (* collection *)
+
+ | (TYSPEC_collection av, TYSPEC_collection bv) ->
+ unify_tyvars av bv;
+ TYSPEC_collection av
+
+ | (TYSPEC_collection av, TYSPEC_comparable)
+ | (TYSPEC_comparable, TYSPEC_collection av) ->
+ TYSPEC_collection av
+
+ | (TYSPEC_collection v, TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_collection v) -> TYSPEC_collection v
+
+ | (TYSPEC_collection _, TYSPEC_dictionary _)
+ | (TYSPEC_collection _, TYSPEC_integral)
+ | (TYSPEC_collection _, TYSPEC_loggable)
+ | (TYSPEC_collection _, TYSPEC_numeric)
+ | (TYSPEC_collection _, TYSPEC_ordered)
+ | (TYSPEC_collection _, TYSPEC_app _)
+ | (TYSPEC_collection _, TYSPEC_record _)
+ | (TYSPEC_collection _, TYSPEC_tuple _)
+ | (TYSPEC_dictionary _, TYSPEC_collection _)
+ | (TYSPEC_integral, TYSPEC_collection _)
+ | (TYSPEC_loggable, TYSPEC_collection _)
+ | (TYSPEC_numeric, TYSPEC_collection _)
+ | (TYSPEC_ordered, TYSPEC_collection _)
+ | (TYSPEC_app _, TYSPEC_collection _)
+ | (TYSPEC_record _, TYSPEC_collection _)
+ | (TYSPEC_tuple _, TYSPEC_collection _) -> fail ()
+
+ | (TYSPEC_collection av, TYSPEC_vector bv)
+ | (TYSPEC_vector bv, TYSPEC_collection av) ->
+ unify_tyvars av bv;
+ TYSPEC_vector av
+
+ (* comparable *)
+
+ | (TYSPEC_comparable, TYSPEC_comparable) -> TYSPEC_comparable
+
+ | (TYSPEC_comparable, TYSPEC_plusable)
+ | (TYSPEC_plusable, TYSPEC_comparable) -> TYSPEC_plusable
+
+ | (TYSPEC_comparable, TYSPEC_dictionary dict)
+ | (TYSPEC_dictionary dict, TYSPEC_comparable) ->
+ TYSPEC_dictionary dict
+
+ | (TYSPEC_comparable, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_comparable) -> TYSPEC_integral
+
+ | (TYSPEC_comparable, TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_comparable) -> TYSPEC_loggable
+
+ | (TYSPEC_comparable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_comparable) -> TYSPEC_numeric
+
+ | (TYSPEC_comparable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_comparable) -> TYSPEC_ordered
+
+ | (TYSPEC_comparable, TYSPEC_app _)
+ | (TYSPEC_app _, TYSPEC_comparable) -> fail ()
+
+ | (TYSPEC_comparable, TYSPEC_record r)
+ | (TYSPEC_record r, TYSPEC_comparable) -> TYSPEC_record r
+
+ | (TYSPEC_comparable, TYSPEC_tuple t)
+ | (TYSPEC_tuple t, TYSPEC_comparable) -> TYSPEC_tuple t
+
+ | (TYSPEC_comparable, TYSPEC_vector v)
+ | (TYSPEC_vector v, TYSPEC_comparable) -> TYSPEC_vector v
+
+ (* plusable *)
+
+ | (TYSPEC_plusable, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_dictionary _)
+ | (TYSPEC_dictionary _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_plusable) -> TYSPEC_integral
+
+ | (TYSPEC_plusable, TYSPEC_loggable)
+ | (TYSPEC_loggable, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_plusable) -> TYSPEC_numeric
+
+ | (TYSPEC_plusable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_plusable) -> TYSPEC_plusable
+
+ | (TYSPEC_plusable, TYSPEC_record _)
+ | (TYSPEC_record _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_tuple _)
+ | (TYSPEC_tuple _, TYSPEC_plusable) -> fail ()
+
+ | (TYSPEC_plusable, TYSPEC_vector v)
+ | (TYSPEC_vector v, TYSPEC_plusable) -> TYSPEC_vector v
+
+ | (TYSPEC_plusable, TYSPEC_app _)
+ | (TYSPEC_app _, TYSPEC_plusable) -> fail ()
+
+ (* dictionary *)
+
+ | (TYSPEC_dictionary da, TYSPEC_dictionary db) ->
+ TYSPEC_dictionary (merge_dicts da db)
+
+ | (TYSPEC_dictionary _, TYSPEC_integral)
+ | (TYSPEC_dictionary _, TYSPEC_loggable)
+ | (TYSPEC_dictionary _, TYSPEC_numeric)
+ | (TYSPEC_dictionary _, TYSPEC_ordered)
+ | (TYSPEC_dictionary _, TYSPEC_app _)
+ | (TYSPEC_integral, TYSPEC_dictionary _)
+ | (TYSPEC_loggable, TYSPEC_dictionary _)
+ | (TYSPEC_numeric, TYSPEC_dictionary _)
+ | (TYSPEC_ordered, TYSPEC_dictionary _)
+ | (TYSPEC_app _, TYSPEC_dictionary _) -> fail ()
+
+ | (TYSPEC_dictionary d, TYSPEC_record r)
+ | (TYSPEC_record r, TYSPEC_dictionary d) ->
+ TYSPEC_record (merge_dicts d r)
+
+ | (TYSPEC_dictionary _, TYSPEC_tuple _)
+ | (TYSPEC_dictionary _, TYSPEC_vector _)
+ | (TYSPEC_tuple _, TYSPEC_dictionary _)
+ | (TYSPEC_vector _, TYSPEC_dictionary _) -> fail ()
+
+ (* integral *)
+
+ | (TYSPEC_integral, TYSPEC_integral)
+ | (TYSPEC_integral, TYSPEC_loggable)
+ | (TYSPEC_integral, TYSPEC_numeric)
+ | (TYSPEC_integral, TYSPEC_ordered)
+ | (TYSPEC_loggable, TYSPEC_integral)
+ | (TYSPEC_numeric, TYSPEC_integral)
+ | (TYSPEC_ordered, TYSPEC_integral) -> TYSPEC_integral
+
+ | (TYSPEC_integral, TYSPEC_app _)
+ | (TYSPEC_integral, TYSPEC_record _)
+ | (TYSPEC_integral, TYSPEC_tuple _)
+ | (TYSPEC_integral, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_integral)
+ | (TYSPEC_record _, TYSPEC_integral)
+ | (TYSPEC_tuple _, TYSPEC_integral)
+ | (TYSPEC_vector _, TYSPEC_integral) -> fail ()
+
+ (* loggable *)
+
+ | (TYSPEC_loggable, TYSPEC_loggable) -> TYSPEC_loggable
+
+ | (TYSPEC_loggable, TYSPEC_numeric)
+ | (TYSPEC_numeric, TYSPEC_loggable) -> TYSPEC_numeric
+
+ | (TYSPEC_loggable, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_loggable) -> TYSPEC_ordered
+
+ | (TYSPEC_loggable, TYSPEC_app _)
+ | (TYSPEC_loggable, TYSPEC_record _)
+ | (TYSPEC_loggable, TYSPEC_tuple _)
+ | (TYSPEC_loggable, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_loggable)
+ | (TYSPEC_record _, TYSPEC_loggable)
+ | (TYSPEC_tuple _, TYSPEC_loggable)
+ | (TYSPEC_vector _, TYSPEC_loggable) -> fail ()
+
+ (* numeric *)
+
+ | (TYSPEC_numeric, TYSPEC_numeric) -> TYSPEC_numeric
+
+ | (TYSPEC_numeric, TYSPEC_ordered)
+ | (TYSPEC_ordered, TYSPEC_numeric) -> TYSPEC_ordered
+
+ | (TYSPEC_numeric, TYSPEC_app _)
+ | (TYSPEC_numeric, TYSPEC_record _)
+ | (TYSPEC_numeric, TYSPEC_tuple _)
+ | (TYSPEC_numeric, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_numeric)
+ | (TYSPEC_record _, TYSPEC_numeric)
+ | (TYSPEC_tuple _, TYSPEC_numeric)
+ | (TYSPEC_vector _, TYSPEC_numeric) -> fail ()
+
+ (* ordered *)
+
+ | (TYSPEC_ordered, TYSPEC_ordered) -> TYSPEC_ordered
+
+ | (TYSPEC_ordered, TYSPEC_app _)
+ | (TYSPEC_ordered, TYSPEC_record _)
+ | (TYSPEC_ordered, TYSPEC_tuple _)
+ | (TYSPEC_ordered, TYSPEC_vector _)
+ | (TYSPEC_app _, TYSPEC_ordered)
+ | (TYSPEC_record _, TYSPEC_ordered)
+ | (TYSPEC_tuple _, TYSPEC_ordered)
+ | (TYSPEC_vector _, TYSPEC_ordered) -> fail ()
+
+ (* app *)
+
+ | (TYSPEC_app (tv_a, args_a),
+ TYSPEC_app (tv_b, args_b)) ->
+ if args_a <> args_b
+ then fail()
+ else
+ begin
+ unify_tyvars tv_a tv_b;
+ TYSPEC_app (tv_a, args_a)
+ end
+
+ | (TYSPEC_app _, TYSPEC_record _)
+ | (TYSPEC_app _, TYSPEC_tuple _)
+ | (TYSPEC_app _, TYSPEC_vector _)
+ | (TYSPEC_record _, TYSPEC_app _)
+ | (TYSPEC_tuple _, TYSPEC_app _)
+ | (TYSPEC_vector _, TYSPEC_app _) -> fail ()
+
+ (* record *)
+
+ | (TYSPEC_record da, TYSPEC_record db) ->
+ TYSPEC_record (merge_dicts da db)
+
+ | (TYSPEC_record _, TYSPEC_tuple _)
+ | (TYSPEC_record _, TYSPEC_vector _)
+ | (TYSPEC_tuple _, TYSPEC_record _)
+ | (TYSPEC_vector _, TYSPEC_record _) -> fail ()
+
+ (* tuple *)
+
+ | (TYSPEC_tuple tvs_a, TYSPEC_tuple tvs_b) ->
+ let len_a = Array.length tvs_a in
+ let len_b = Array.length tvs_b in
+ let max_len = max len_a len_b in
+ let init_tuple_elem i =
+ if i >= len_a
+ then tvs_b.(i)
+ else if i >= len_b
+ then tvs_a.(i)
+ else begin
+ unify_tyvars tvs_a.(i) tvs_b.(i);
+ tvs_a.(i)
+ end
+ in
+ TYSPEC_tuple (Array.init max_len init_tuple_elem)
+
+ | (TYSPEC_tuple _, TYSPEC_vector _)
+ | (TYSPEC_vector _, TYSPEC_tuple _) -> fail ()
+
+ (* vector *)
+
+ | (TYSPEC_vector av, TYSPEC_vector bv) ->
+ unify_tyvars av bv;
+ TYSPEC_vector av
+ in
+ let c = ref result in
+ a := TYSPEC_equiv c;
+ b := TYSPEC_equiv c
+
+ and unify_ty (ty:Ast.ty) (tv:tyvar) : unit =
+ unify_tyvars (ref (TYSPEC_resolved ([||], ty))) tv
+ in
+
+ let rec unify_atom (atom:Ast.atom) (tv:tyvar) : unit =
+ match atom with
+ Ast.ATOM_literal { node = literal; id = _ } ->
+ let ty = match literal with
+ Ast.LIT_nil -> Ast.TY_nil
+ | Ast.LIT_bool _ -> Ast.TY_bool
+ | Ast.LIT_mach (mty, _, _) -> Ast.TY_mach mty
+ | Ast.LIT_int (_, _) -> Ast.TY_int
+ | Ast.LIT_uint (_, _) -> Ast.TY_uint
+ | Ast.LIT_char _ -> Ast.TY_char
+ in
+ unify_ty ty tv
+ | Ast.ATOM_lval lval -> unify_lval lval tv
+
+ and unify_expr (expr:Ast.expr) (tv:tyvar) : unit =
+ match expr with
+ Ast.EXPR_binary (binop, lhs, rhs) ->
+ let binop_sig = match binop with
+ Ast.BINOP_eq
+ | Ast.BINOP_ne -> BINOPSIG_comp_comp_bool
+
+ | Ast.BINOP_lt
+ | Ast.BINOP_le
+ | Ast.BINOP_ge
+ | Ast.BINOP_gt -> BINOPSIG_ord_ord_bool
+
+ | Ast.BINOP_or
+ | Ast.BINOP_and
+ | Ast.BINOP_xor
+ | Ast.BINOP_lsl
+ | Ast.BINOP_lsr
+ | Ast.BINOP_asr -> BINOPSIG_integ_integ_integ
+
+ | Ast.BINOP_add -> BINOPSIG_plus_plus_plus
+
+ | Ast.BINOP_sub
+ | Ast.BINOP_mul
+ | Ast.BINOP_div
+ | Ast.BINOP_mod -> BINOPSIG_num_num_num
+
+ | Ast.BINOP_send -> bug () "BINOP_send found in expr"
+ in
+ begin
+ match binop_sig with
+ BINOPSIG_bool_bool_bool ->
+ unify_atom lhs
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_atom rhs
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_comp_comp_bool ->
+ let tv_a = ref TYSPEC_comparable in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_ord_ord_bool ->
+ let tv_a = ref TYSPEC_ordered in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_ty Ast.TY_bool tv
+ | BINOPSIG_integ_integ_integ ->
+ let tv_a = ref TYSPEC_integral in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ | BINOPSIG_num_num_num ->
+ let tv_a = ref TYSPEC_numeric in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ | BINOPSIG_plus_plus_plus ->
+ let tv_a = ref TYSPEC_plusable in
+ unify_atom lhs tv_a;
+ unify_atom rhs tv_a;
+ unify_tyvars tv tv_a
+ end
+ | Ast.EXPR_unary (unop, atom) ->
+ begin
+ match unop with
+ Ast.UNOP_not ->
+ unify_atom atom
+ (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+ unify_ty Ast.TY_bool tv
+ | Ast.UNOP_bitnot ->
+ let tv_a = ref TYSPEC_integral in
+ unify_atom atom tv_a;
+ unify_tyvars tv tv_a
+ | Ast.UNOP_neg ->
+ let tv_a = ref TYSPEC_numeric in
+ unify_atom atom tv_a;
+ unify_tyvars tv tv_a
+ | Ast.UNOP_cast t ->
+ (*
+ * FIXME: check cast-validity in post-typecheck pass.
+ * Only some casts make sense.
+ *)
+ let tv_a = ref TYSPEC_all in
+ let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
+ unify_atom atom tv_a;
+ unify_ty t tv
+ end
+ | Ast.EXPR_atom atom -> unify_atom atom tv
+
+ and unify_lval' (lval:Ast.lval) (tv:tyvar) : unit =
+ let note_args args =
+ iflog cx (fun _ -> log cx "noting lval '%a' type arguments: %a"
+ Ast.sprintf_lval lval Ast.sprintf_app_args args);
+ Hashtbl.add
+ cx.ctxt_call_lval_params
+ (lval_base_id lval)
+ args;
+ in
+ match lval with
+ Ast.LVAL_base nbi ->
+ let referent = Hashtbl.find cx.ctxt_lval_to_referent nbi.id in
+ begin
+ match Hashtbl.find cx.ctxt_all_defns referent with
+ DEFN_slot slot ->
+ iflog cx
+ begin
+ fun _ ->
+ let tv = Hashtbl.find bindings referent in
+ log cx "lval-base slot tyspec for %a = %s"
+ Ast.sprintf_lval lval (tyspec_to_str (!tv));
+ end;
+ unify_slot slot (Some referent) tv
+
+ | _ ->
+ let spec = (!(Hashtbl.find bindings referent)) in
+ let _ =
+ iflog cx
+ begin
+ fun _ ->
+ log cx "lval-base item tyspec for %a = %s"
+ Ast.sprintf_lval lval (tyspec_to_str spec);
+ log cx "unifying with supplied spec %s"
+ (tyspec_to_str !tv)
+ end
+ in
+ let tv =
+ match nbi.node with
+ Ast.BASE_ident _ -> tv
+ | Ast.BASE_app (_, args) ->
+ note_args args;
+ ref (TYSPEC_app (tv, args))
+ | _ -> err None "bad lval / tyspec combination"
+ in
+ unify_tyvars (ref spec) tv
+ end
+ | Ast.LVAL_ext (base, comp) ->
+ let base_ts = match comp with
+ Ast.COMP_named (Ast.COMP_ident id) ->
+ let names = Hashtbl.create 1 in
+ Hashtbl.add names id tv;
+ TYSPEC_dictionary names
+
+ | Ast.COMP_named (Ast.COMP_app (id, args)) ->
+ note_args args;
+ let tv = ref (TYSPEC_app (tv, args)) in
+ let names = Hashtbl.create 1 in
+ Hashtbl.add names id tv;
+ TYSPEC_dictionary names
+
+ | Ast.COMP_named (Ast.COMP_idx i) ->
+ let init j = if i + 1 == j then tv else ref TYSPEC_all in
+ TYSPEC_tuple (Array.init (i + 1) init)
+
+ | Ast.COMP_atom atom ->
+ unify_atom atom (ref (TYSPEC_resolved ([||], Ast.TY_int)));
+ TYSPEC_collection tv
+ in
+ let base_tv = ref base_ts in
+ unify_lval' base base_tv;
+ match !(resolve_tyvar base_tv) with
+ TYSPEC_resolved (_, ty) ->
+ unify_ty (slot_ty (project_type_to_slot ty comp)) tv
+ | _ ->
+ ()
+
+ and unify_lval (lval:Ast.lval) (tv:tyvar) : unit =
+ let id = lval_base_id lval in
+ (* Fetch lval with type components resolved. *)
+ let lval = Hashtbl.find cx.ctxt_all_lvals id in
+ iflog cx (fun _ -> log cx
+ "fetched resolved version of lval #%d = %a"
+ (int_of_node id) Ast.sprintf_lval lval);
+ Hashtbl.add lval_tyvars id tv;
+ unify_lval' lval tv
+
+ in
+ let gen_atom_tvs atoms =
+ let gen_atom_tv atom =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ tv
+ in
+ Array.map gen_atom_tv atoms
+ in
+ let visit_stmt_pre_full (stmt:Ast.stmt) : unit =
+
+ let check_callable out_tv callee args =
+ let in_tvs = gen_atom_tvs args in
+ let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in
+ unify_lval callee callee_tv;
+ in
+ match stmt.node with
+ Ast.STMT_spawn (out, _, callee, args) ->
+ let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_nil)) in
+ unify_lval out (ref (TYSPEC_resolved ([||], Ast.TY_task)));
+ check_callable out_tv callee args
+
+ | Ast.STMT_init_rec (lval, fields, Some base) ->
+ let dct = Hashtbl.create 10 in
+ let tvrec = ref (TYSPEC_record dct) in
+ let add_field (ident, _, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ Hashtbl.add dct ident tv
+ in
+ Array.iter add_field fields;
+ let tvbase = ref TYSPEC_all in
+ unify_lval base tvbase;
+ unify_tyvars tvrec tvbase;
+ unify_lval lval tvrec
+
+ | Ast.STMT_init_rec (lval, fields, None) ->
+ let dct = Hashtbl.create 10 in
+ let add_field (ident, _, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ Hashtbl.add dct ident tv
+ in
+ Array.iter add_field fields;
+ unify_lval lval (ref (TYSPEC_record dct))
+
+ | Ast.STMT_init_tup (lval, members) ->
+ let member_to_tv (_, _, atom) =
+ let tv = ref TYSPEC_all in
+ unify_atom atom tv;
+ tv
+ in
+ let member_tvs = Array.map member_to_tv members in
+ unify_lval lval (ref (TYSPEC_tuple member_tvs))
+
+ | Ast.STMT_init_vec (lval, _, atoms) ->
+ let tv = ref TYSPEC_all in
+ let unify_with_tv atom = unify_atom atom tv in
+ Array.iter unify_with_tv atoms;
+ unify_lval lval (ref (TYSPEC_vector tv))
+
+ | Ast.STMT_init_str (lval, _) ->
+ unify_lval lval (ref (TYSPEC_resolved ([||], Ast.TY_str)))
+
+ | Ast.STMT_copy (lval, expr) ->
+ let tv = ref TYSPEC_all in
+ unify_expr expr tv;
+ unify_lval lval tv
+
+ | Ast.STMT_copy_binop (lval, binop, at) ->
+ let tv = ref TYSPEC_all in
+ unify_expr (Ast.EXPR_binary (binop, Ast.ATOM_lval lval, at)) tv;
+ unify_lval lval tv;
+
+ | Ast.STMT_call (out, callee, args) ->
+ let out_tv = ref TYSPEC_all in
+ unify_lval out out_tv;
+ check_callable out_tv callee args
+
+ | Ast.STMT_log atom -> unify_atom atom (ref TYSPEC_loggable)
+
+ | Ast.STMT_check_expr expr ->
+ unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool)))
+
+ | Ast.STMT_check (_, check_calls) ->
+ let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_bool)) in
+ Array.iter
+ (fun (callee, args) ->
+ check_callable out_tv callee args)
+ check_calls
+
+ | Ast.STMT_while { Ast.while_lval = (_, expr); Ast.while_body = _ } ->
+ unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool)))
+
+ | Ast.STMT_if { Ast.if_test = if_test } ->
+ unify_expr if_test (ref (TYSPEC_resolved ([||], Ast.TY_bool)));
+
+ | Ast.STMT_decl _ -> ()
+
+ (* FIXME: deal with difference between return-type vs. put-type *)
+ | Ast.STMT_ret atom_opt
+ | Ast.STMT_put atom_opt ->
+ begin
+ match atom_opt with
+ None -> unify_ty Ast.TY_nil (retval_tv())
+ | Some atom -> unify_atom atom (retval_tv())
+ end
+
+ | Ast.STMT_be (callee, args) ->
+ check_callable (retval_tv()) callee args
+
+ | Ast.STMT_bind (bound, callee, arg_opts) ->
+ (* FIXME: handle binding type parameters eventually. *)
+ let out_tv = ref TYSPEC_all in
+ let residue = ref [] in
+ let gen_atom_opt_tvs atoms =
+ let gen_atom_tv atom_opt =
+ let tv = ref TYSPEC_all in
+ begin
+ match atom_opt with
+ None -> residue := tv :: (!residue);
+ | Some atom -> unify_atom atom tv
+ end;
+ tv
+ in
+ Array.map gen_atom_tv atoms
+ in
+
+ let in_tvs = gen_atom_opt_tvs arg_opts in
+ let arg_residue_tvs = Array.of_list (List.rev (!residue)) in
+ let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in
+ let bound_tv = ref (TYSPEC_callable (out_tv, arg_residue_tvs)) in
+ unify_lval callee callee_tv;
+ unify_lval bound bound_tv
+
+ | Ast.STMT_for_each fe ->
+ let out_tv = ref TYSPEC_all in
+ let (si, _) = fe.Ast.for_each_slot in
+ let (callee, args) = fe.Ast.for_each_call in
+ unify_slot si.node (Some si.id) out_tv;
+ check_callable out_tv callee args
+
+ | Ast.STMT_for fo ->
+ 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
+ unify_lval seq seq_tv;
+ unify_slot si.node (Some si.id) mem_tv
+
+ (* FIXME (issue #52): plenty more to handle here. *)
+ | _ ->
+ log cx "warning: not typechecking stmt %s\n"
+ (Ast.sprintf_stmt () stmt)
+ in
+
+ let visit_stmt_pre (stmt:Ast.stmt) : unit =
+ try
+ visit_stmt_pre_full stmt;
+ (*
+ * Reset any item-parameters that were resolved to types
+ * during inference for this statement.
+ *)
+ Hashtbl.iter
+ (fun _ params -> Array.iter (fun tv -> tv := TYSPEC_all) params)
+ item_params;
+ with
+ Semant_err (None, msg) ->
+ raise (Semant_err ((Some stmt.id), msg))
+ in
+
+ let enter_fn fn retspec =
+ let out = fn.Ast.fn_output_slot in
+ push_retval_tv (ref retspec);
+ unify_slot out.node (Some out.id) (retval_tv())
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ enter_fn fn.node TYSPEC_all;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_fn_post obj ident fn =
+ inner.Walk.visit_obj_fn_post obj ident fn;
+ pop_retval_tv ();
+ in
+
+ let visit_mod_item_pre n p mod_item =
+ begin
+ try
+ match mod_item.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn fn ->
+ enter_fn fn TYSPEC_all
+
+ | _ -> ()
+ with Semant_err (None, msg) ->
+ raise (Semant_err ((Some mod_item.id), msg))
+ end;
+ inner.Walk.visit_mod_item_pre n p mod_item
+ in
+
+ let path_name (_:unit) : string =
+ string_of_name (Walk.path_to_name path)
+ in
+
+ let visit_mod_item_post n p mod_item =
+ inner.Walk.visit_mod_item_post n p mod_item;
+ match mod_item.node.Ast.decl_item with
+
+ | Ast.MOD_ITEM_fn _ ->
+ pop_retval_tv ();
+ if (Some (path_name())) = cx.ctxt_main_name
+ then
+ begin
+ match Hashtbl.find cx.ctxt_all_item_types mod_item.id with
+ Ast.TY_fn (tsig, _) ->
+ begin
+ let vec_str =
+ interior_slot (Ast.TY_vec
+ (interior_slot Ast.TY_str))
+ in
+ match tsig.Ast.sig_input_slots with
+ [| |] -> ()
+ | [| vs |] when vs = vec_str -> ()
+ | _ -> err (Some mod_item.id)
+ "main fn has bad type signature"
+ end
+ | _ ->
+ err (Some mod_item.id) "main item is not a function"
+ end
+ | _ -> ()
+ 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_stmt_pre = visit_stmt_pre
+ }
+
+ in
+ try
+ let auto_queue = Queue.create () in
+
+ let init_slot_tyvar id defn =
+ match defn with
+ DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = None } ->
+ Queue.add id auto_queue;
+ Hashtbl.add bindings id (ref TYSPEC_all)
+ | DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = Some ty } ->
+ let _ = iflog cx (fun _ -> log cx "initial slot #%d type: %a"
+ (int_of_node id) Ast.sprintf_ty ty)
+ in
+ Hashtbl.add bindings id (ref (TYSPEC_resolved ([||], ty)))
+ | _ -> ()
+ in
+
+ let init_item_tyvar id ty =
+ let _ = iflog cx (fun _ -> log cx "initial item #%d type: %a"
+ (int_of_node id) Ast.sprintf_ty ty)
+ in
+ let params =
+ match Hashtbl.find cx.ctxt_all_defns id with
+ DEFN_item i -> Array.map (fun p -> p.node) i.Ast.decl_params
+ | DEFN_obj_fn _ -> [| |]
+ | DEFN_obj_drop _ -> [| |]
+ | DEFN_loop_body _ -> [| |]
+ | _ -> err (Some id) "expected item defn for item tyvar"
+ in
+ let spec = TYSPEC_resolved (params, ty) in
+ Hashtbl.add bindings id (ref spec)
+ in
+
+ let init_mod_dict id defn =
+ let rec tv_of_item id item =
+ match item.Ast.decl_item with
+ Ast.MOD_ITEM_mod (_, items) ->
+ if Hashtbl.mem bindings id
+ then Hashtbl.find bindings id
+ else
+ let dict = htab_map items
+ (fun i item -> (i, tv_of_item item.id item.node))
+ in
+ let spec = TYSPEC_dictionary dict in
+ let tv = ref spec in
+ Hashtbl.add bindings id tv;
+ tv
+ | _ ->
+ Hashtbl.find bindings id
+ in
+ match defn with
+ DEFN_item ({ Ast.decl_item=Ast.MOD_ITEM_mod _ } as item) ->
+ ignore (tv_of_item id item)
+ | _ -> ()
+ in
+ Hashtbl.iter init_slot_tyvar cx.ctxt_all_defns;
+ Hashtbl.iter init_item_tyvar cx.ctxt_all_item_types;
+ 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
+ (visitor cx Walk.empty_visitor)))
+ crate;
+
+ let update_auto_tyvar id ty =
+ let defn = Hashtbl.find cx.ctxt_all_defns id in
+ match defn with
+ DEFN_slot slot_defn ->
+ Hashtbl.replace cx.ctxt_all_defns id
+ (DEFN_slot { slot_defn with Ast.slot_ty = Some ty })
+ | _ -> bug () "check_auto_tyvar: no slot defn"
+ in
+
+ let get_resolved_ty tv id =
+ let ts = !(resolve_tyvar tv) in
+ match ts with
+ TYSPEC_resolved ([||], ty) -> ty
+ | TYSPEC_vector (tv) ->
+ begin
+ match !(resolve_tyvar tv) with
+ TYSPEC_resolved ([||], ty) ->
+ (Ast.TY_vec (interior_slot ty))
+ | _ ->
+ err (Some id)
+ "unresolved vector-element type in %s (%d)"
+ (tyspec_to_str ts) (int_of_node id)
+ end
+ | _ -> err (Some id)
+ "unresolved type %s (%d)"
+ (tyspec_to_str ts)
+ (int_of_node id)
+ in
+
+ let check_auto_tyvar id =
+ let tv = Hashtbl.find bindings id in
+ let ty = get_resolved_ty tv id in
+ update_auto_tyvar id ty
+ in
+
+ let record_lval_ty id tv =
+ let ty = get_resolved_ty tv id in
+ Hashtbl.add cx.ctxt_all_lval_types id ty
+ in
+
+ Queue.iter check_auto_tyvar auto_queue;
+ Hashtbl.iter record_lval_ty lval_tyvars;
+ with Semant_err (ido, str) -> report_err cx ido str
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
+
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
new file mode 100644
index 00000000..4671d0f4
--- /dev/null
+++ b/src/boot/me/typestate.ml
@@ -0,0 +1,1089 @@
+open Semant;;
+open Common;;
+
+
+let log cx = Session.log "typestate"
+ cx.ctxt_sess.Session.sess_log_typestate
+ cx.ctxt_sess.Session.sess_log_out
+;;
+
+let iflog cx thunk =
+ if cx.ctxt_sess.Session.sess_log_typestate
+ then thunk ()
+ else ()
+;;
+
+let name_base_to_slot_key (nb:Ast.name_base) : Ast.slot_key =
+ match nb with
+ Ast.BASE_ident ident -> Ast.KEY_ident ident
+ | Ast.BASE_temp tmp -> Ast.KEY_temp tmp
+ | Ast.BASE_app _ -> bug () "name_base_to_slot_key on parametric name"
+;;
+
+let determine_constr_key
+ (cx:ctxt)
+ (scopes:(scope list))
+ (formal_base:node_id option)
+ (c:Ast.constr)
+ : constr_key =
+
+ let cid =
+ match lookup_by_name cx scopes c.Ast.constr_name with
+ Some (_, cid) ->
+ if referent_is_item cx cid
+ then
+ begin
+ match Hashtbl.find cx.ctxt_all_item_types cid with
+ Ast.TY_fn (_, taux) ->
+ begin
+ if taux.Ast.fn_effect = Ast.PURE
+ then cid
+ else err (Some cid) "impure function used in constraint"
+ end
+ | _ -> bug () "bad type of predicate"
+ end
+ else
+ bug () "slot used as predicate"
+ | None -> bug () "predicate not found"
+ in
+
+ let constr_arg_of_carg carg =
+ match carg with
+ Ast.CARG_path pth ->
+ let rec node_base_of pth =
+ match pth with
+ Ast.CARG_base Ast.BASE_formal ->
+ begin
+ match formal_base with
+ Some id -> id
+ | None ->
+ bug () "formal symbol * used in free constraint"
+ end
+ | Ast.CARG_ext (pth, _) -> node_base_of pth
+ | Ast.CARG_base (Ast.BASE_named nb) ->
+ begin
+ match lookup_by_name cx scopes (Ast.NAME_base nb) with
+ None -> bug () "constraint-arg not found"
+ | Some (_, aid) ->
+ if referent_is_slot cx aid
+ then
+ if type_has_state
+ (slot_ty (referent_to_slot cx aid))
+ then err (Some aid)
+ "predicate applied to slot of mutable type"
+ else aid
+ else
+ (* Items are always constant, they're ok.
+ * Weird to be using them in a constr, but ok. *)
+ aid
+ end
+ in
+ Constr_arg_node (node_base_of pth, pth)
+
+ | Ast.CARG_lit lit -> Constr_arg_lit lit
+ in
+ Constr_pred (cid, Array.map constr_arg_of_carg c.Ast.constr_args)
+;;
+
+let fmt_constr_key cx ckey =
+ match ckey with
+ Constr_pred (cid, args) ->
+ let fmt_constr_arg carg =
+ match carg with
+ Constr_arg_lit lit ->
+ Ast.fmt_to_str Ast.fmt_lit lit
+ | Constr_arg_node (id, pth) ->
+ let rec fmt_pth pth =
+ match pth with
+ Ast.CARG_base _ ->
+ if referent_is_slot cx id
+ then
+ let key = Hashtbl.find cx.ctxt_slot_keys id in
+ Ast.fmt_to_str Ast.fmt_slot_key key
+ else
+ let n = Hashtbl.find cx.ctxt_all_item_names id in
+ Ast.fmt_to_str Ast.fmt_name n
+ | Ast.CARG_ext (pth, nc) ->
+ let b = fmt_pth pth in
+ b ^ (Ast.fmt_to_str Ast.fmt_name_component nc)
+ in
+ fmt_pth pth
+ in
+ let pred_name = Hashtbl.find cx.ctxt_all_item_names cid in
+ Printf.sprintf "%s(%s)"
+ (Ast.fmt_to_str Ast.fmt_name pred_name)
+ (String.concat ", "
+ (List.map
+ fmt_constr_arg
+ (Array.to_list args)))
+
+ | Constr_init n when Hashtbl.mem cx.ctxt_slot_keys n ->
+ Printf.sprintf "<init #%d = %s>"
+ (int_of_node n)
+ (Ast.fmt_to_str Ast.fmt_slot_key (Hashtbl.find cx.ctxt_slot_keys n))
+ | Constr_init n ->
+ Printf.sprintf "<init #%d>" (int_of_node n)
+;;
+
+let entry_keys header constrs resolver =
+ let init_keys =
+ Array.map
+ (fun (sloti, _) -> (Constr_init sloti.id))
+ header
+ in
+ let names =
+ Array.map
+ (fun (_, ident) -> (Some (Ast.BASE_ident ident)))
+ header
+ in
+ let input_constrs =
+ Array.map (apply_names_to_constr names) constrs in
+ let input_keys = Array.map resolver input_constrs in
+ (input_keys, init_keys)
+;;
+
+let obj_keys ob resolver =
+ entry_keys ob.Ast.obj_state ob.Ast.obj_constrs resolver
+;;
+
+let fn_keys fn resolver =
+ entry_keys fn.Ast.fn_input_slots fn.Ast.fn_input_constrs resolver
+;;
+
+let constr_id_assigning_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (idref:int ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let resolve_constr_to_key
+ (formal_base:node_id)
+ (constr:Ast.constr)
+ : constr_key =
+ determine_constr_key cx (!scopes) (Some formal_base) constr
+ in
+
+ let note_constr_key key =
+ if not (Hashtbl.mem cx.ctxt_constr_ids key)
+ then
+ begin
+ let cid = Constr (!idref) in
+ iflog cx
+ (fun _ -> log cx "assigning constr id #%d to constr %s"
+ (!idref) (fmt_constr_key cx key));
+ incr idref;
+ htab_put cx.ctxt_constrs cid key;
+ htab_put cx.ctxt_constr_ids key cid;
+ end
+ in
+
+ let note_keys = Array.iter note_constr_key in
+
+ let visit_mod_item_pre n p i =
+ let resolver = resolve_constr_to_key i.id in
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let (input_keys, init_keys) = fn_keys f resolver in
+ note_keys input_keys;
+ note_keys init_keys
+ | Ast.MOD_ITEM_obj ob ->
+ let (input_keys, init_keys) = obj_keys ob resolver in
+ note_keys input_keys;
+ note_keys init_keys
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_constr_pre formal_base c =
+ let key = determine_constr_key cx (!scopes) formal_base c in
+ note_constr_key key;
+ inner.Walk.visit_constr_pre formal_base c
+ in
+ (*
+ * We want to generate, for any call site, a variant of
+ * the callee's entry typestate specialized to the arguments
+ * that the caller passes.
+ *
+ * Also, for any slot-decl node, we have to generate a
+ * variant of Constr_init for the slot (because the slot is
+ * the sort of thing that can vary in init-ness over time).
+ *)
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_call (_, lv, args) ->
+ let referent = lval_to_referent cx (lval_base_id lv) in
+ let referent_ty = lval_ty cx lv in
+ begin
+ match referent_ty with
+ Ast.TY_fn (tsig,_) ->
+ let constrs = tsig.Ast.sig_input_constrs in
+ let names = atoms_to_names args in
+ let constrs' =
+ Array.map (apply_names_to_constr names) constrs
+ in
+ Array.iter (visit_constr_pre (Some referent)) constrs'
+
+ | _ -> ()
+ end
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_slot_identified_pre s =
+ note_constr_key (Constr_init s.id);
+ inner.Walk.visit_slot_identified_pre s
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_slot_identified_pre = visit_slot_identified_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_constr_pre = visit_constr_pre }
+;;
+
+let bitmap_assigning_visitor
+ (cx:ctxt)
+ (idref:int ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_stmt_pre s =
+ iflog cx (fun _ -> log cx "building %d-entry bitmap for node %d"
+ (!idref) (int_of_node s.id));
+ htab_put cx.ctxt_preconditions s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_postconditions s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_prestates s.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_poststates s.id (Bits.create (!idref) false);
+ inner.Walk.visit_stmt_pre s
+ in
+ let visit_block_pre b =
+ iflog cx (fun _ -> log cx "building %d-entry bitmap for node %d"
+ (!idref) (int_of_node b.id));
+ htab_put cx.ctxt_preconditions b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_postconditions b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_prestates b.id (Bits.create (!idref) false);
+ htab_put cx.ctxt_poststates b.id (Bits.create (!idref) false);
+ inner.Walk.visit_block_pre b
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+let condition_assigning_visitor
+ (cx:ctxt)
+ (scopes:(scope list) ref)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let raise_bits (bitv:Bits.t) (keys:constr_key array) : unit =
+ Array.iter
+ (fun key ->
+ let cid = Hashtbl.find cx.ctxt_constr_ids key in
+ let i = int_of_constr cid in
+ iflog cx (fun _ -> log cx "setting bit %d, constraint %s"
+ i (fmt_constr_key cx key));
+ Bits.set bitv (int_of_constr cid) true)
+ keys
+ in
+
+ let slot_inits ss = Array.map (fun s -> Constr_init s) ss in
+
+ let raise_postcondition (id:node_id) (keys:constr_key array) : unit =
+ let bitv = Hashtbl.find cx.ctxt_postconditions id in
+ raise_bits bitv keys
+ in
+
+ let raise_precondition (id:node_id) (keys:constr_key array) : unit =
+ let bitv = Hashtbl.find cx.ctxt_preconditions id in
+ raise_bits bitv keys
+ in
+
+ let resolve_constr_to_key
+ (formal_base:node_id option)
+ (constr:Ast.constr)
+ : constr_key =
+ determine_constr_key cx (!scopes) formal_base constr
+ in
+
+ let raise_entry_state input_keys init_keys block =
+ iflog cx
+ (fun _ -> log cx
+ "setting entry state as block %d postcondition (\"entry\" prestate)"
+ (int_of_node block.id));
+ raise_postcondition block.id input_keys;
+ raise_postcondition block.id init_keys;
+ iflog cx (fun _ -> log cx "done setting block postcondition")
+ in
+
+ let visit_mod_item_pre n p i =
+ begin
+ match i.node.Ast.decl_item with
+ Ast.MOD_ITEM_fn f ->
+ let (input_keys, init_keys) =
+ fn_keys f (resolve_constr_to_key (Some i.id))
+ in
+ raise_entry_state input_keys init_keys f.Ast.fn_body
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_mod_item_pre n p i
+ in
+
+ let visit_obj_fn_pre obj ident fn =
+ let (obj_input_keys, obj_init_keys) =
+ obj_keys obj.node (resolve_constr_to_key (Some obj.id))
+ in
+ let (fn_input_keys, fn_init_keys) =
+ fn_keys fn.node (resolve_constr_to_key (Some fn.id))
+ in
+ raise_entry_state obj_input_keys obj_init_keys fn.node.Ast.fn_body;
+ raise_entry_state fn_input_keys fn_init_keys fn.node.Ast.fn_body;
+ inner.Walk.visit_obj_fn_pre obj ident fn
+ in
+
+ let visit_obj_drop_pre obj b =
+ let (obj_input_keys, obj_init_keys) =
+ obj_keys obj.node (resolve_constr_to_key (Some obj.id))
+ in
+ raise_entry_state obj_input_keys obj_init_keys b;
+ inner.Walk.visit_obj_drop_pre obj b
+ in
+
+ let visit_callable_pre s dst lv args =
+ let referent_ty = lval_ty cx lv in
+ begin
+ match referent_ty with
+ Ast.TY_fn (tsig,_) ->
+ let formal_constrs = tsig.Ast.sig_input_constrs in
+ let names = atoms_to_names args in
+ let constrs =
+ Array.map (apply_names_to_constr names) formal_constrs
+ in
+ let keys = Array.map (resolve_constr_to_key None) constrs in
+ raise_precondition s.id keys
+ | _ -> ()
+ end;
+ begin
+ let postcond =
+ slot_inits (lval_slots cx dst)
+ in
+ raise_postcondition s.id postcond
+ end
+ in
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+ Ast.STMT_check (constrs, _) ->
+ let postcond = Array.map (resolve_constr_to_key None) constrs in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_recv (dst, src) ->
+ let precond = slot_inits (lval_slots cx src) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_send (dst, src) ->
+ let precond = Array.append
+ (slot_inits (lval_slots cx dst))
+ (slot_inits (lval_slots cx src))
+ in
+ raise_precondition s.id precond;
+
+ | Ast.STMT_init_rec (dst, entries, base) ->
+ let base_slots =
+ begin
+ match base with
+ None -> [| |]
+ | Some lval -> lval_slots cx lval
+ end
+ in
+ let precond = slot_inits
+ (Array.append (rec_inputs_slots cx entries) base_slots)
+ in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_tup (dst, modes_atoms) ->
+ let precond = slot_inits
+ (tup_inputs_slots cx modes_atoms)
+ in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | 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_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_str (dst, _) ->
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_port dst ->
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_init_chan (dst, port) ->
+ let precond = slot_inits (lval_option_slots cx port) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_copy (dst, src) ->
+ let precond = slot_inits (expr_slots cx src) in
+ let postcond = slot_inits (lval_slots cx dst) in
+ raise_precondition s.id precond;
+ raise_postcondition s.id postcond
+
+ | Ast.STMT_copy_binop (dst, _, src) ->
+ let dst_init = slot_inits (lval_slots cx dst) in
+ let src_init = slot_inits (atom_slots cx src) in
+ let precond = Array.append dst_init src_init in
+ raise_precondition s.id precond;
+
+ | Ast.STMT_spawn (dst, _, lv, args)
+ | Ast.STMT_call (dst, lv, args) ->
+ visit_callable_pre s dst lv args
+
+ | Ast.STMT_bind (dst, lv, args_opt) ->
+ let args = arr_map_partial args_opt (fun a -> a) in
+ visit_callable_pre s dst lv args
+
+ | Ast.STMT_ret (Some at) ->
+ let precond = slot_inits (atom_slots cx at) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_put (Some at) ->
+ let precond = slot_inits (atom_slots cx at) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_join lval ->
+ let precond = slot_inits (lval_slots cx lval) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_log atom ->
+ let precond = slot_inits (atom_slots cx atom) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_check_expr expr ->
+ let precond = slot_inits (expr_slots cx expr) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_while sw ->
+ let (_, expr) = sw.Ast.while_lval in
+ let precond = slot_inits (expr_slots cx expr) in
+ raise_precondition s.id precond
+
+ | Ast.STMT_alt_tag at ->
+ let precond = slot_inits (lval_slots cx at.Ast.alt_tag_lval) in
+ let visit_arm { node = (pat, block) } =
+ (* FIXME: propagate tag-carried constrs here. *)
+ let rec get_slots pat =
+ match pat with
+ Ast.PAT_slot header_slot -> [| header_slot |]
+ | Ast.PAT_tag (_, pats) ->
+ Array.concat (List.map get_slots (Array.to_list pats))
+ | _ -> [| |]
+ in
+ let header_slots = get_slots pat in
+ let (input_keys, init_keys) =
+ entry_keys header_slots [| |] (resolve_constr_to_key None)
+ in
+ raise_entry_state input_keys init_keys block
+ in
+ raise_precondition s.id precond;
+ Array.iter visit_arm at.Ast.alt_tag_arms
+
+ | Ast.STMT_for_each fe ->
+ let (si, _) = fe.Ast.for_each_slot in
+ let block_entry_state = [| Constr_init si.id |] in
+ raise_postcondition fe.Ast.for_each_body.id block_entry_state
+
+ | Ast.STMT_for fo ->
+ let (si, _) = fo.Ast.for_slot in
+ let block_entry_state = [| Constr_init si.id |] in
+ raise_postcondition fo.Ast.for_body.id block_entry_state
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+ { inner with
+ Walk.visit_mod_item_pre = visit_mod_item_pre;
+ Walk.visit_obj_fn_pre = visit_obj_fn_pre;
+ Walk.visit_obj_drop_pre = visit_obj_drop_pre;
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let lset_add (x:node_id) (xs:node_id list) : node_id list =
+ if List.mem x xs
+ then xs
+ else x::xs
+;;
+
+let lset_remove (x:node_id) (xs:node_id list) : node_id list =
+ List.filter (fun a -> not (a = x)) xs
+;;
+
+let lset_union (xs:node_id list) (ys:node_id list) : node_id list =
+ List.fold_left (fun ns n -> lset_add n ns) xs ys
+;;
+
+let lset_diff (xs:node_id list) (ys:node_id list) : node_id list =
+ List.fold_left (fun ns n -> lset_remove n ns) xs ys
+;;
+
+let lset_fmt lset =
+ "[" ^
+ (String.concat ", "
+ (List.map
+ (fun n -> string_of_int (int_of_node n)) lset)) ^
+ "]"
+;;
+
+type node_graph = (node_id, (node_id list)) Hashtbl.t;;
+
+let graph_sequence_building_visitor
+ (cx:ctxt)
+ (graph:node_graph)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ (* Flow each stmt to its sequence-successor. *)
+ let visit_stmts stmts =
+ let len = Array.length stmts in
+ for i = 0 to len - 2
+ do
+ let stmt = stmts.(i) in
+ let next = stmts.(i+1) in
+ log cx "sequential stmt edge %d -> %d"
+ (int_of_node stmt.id) (int_of_node next.id);
+ htab_put graph stmt.id [next.id]
+ done;
+ (* Flow last node to nowhere. *)
+ if len > 0
+ then htab_put graph stmts.(len-1).id []
+ in
+
+ let visit_stmt_pre s =
+ (* Sequence the prelude nodes on special stmts. *)
+ begin
+ match s.node with
+ Ast.STMT_while sw ->
+ let (stmts, _) = sw.Ast.while_lval in
+ visit_stmts stmts
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_block_pre b =
+ visit_stmts b.node;
+ inner.Walk.visit_block_pre b
+ in
+
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+let add_flow_edges (graph:node_graph) (n:node_id) (dsts:node_id list) : unit =
+ let existing = Hashtbl.find graph n in
+ Hashtbl.replace graph n (lset_union existing dsts)
+;;
+
+let remove_flow_edges
+ (graph:node_graph)
+ (n:node_id)
+ (dsts:node_id list)
+ : unit =
+ let existing = Hashtbl.find graph n in
+ Hashtbl.replace graph n (lset_diff existing dsts)
+;;
+
+let graph_general_block_structure_building_visitor
+ ((*cx*)_:ctxt)
+ (graph:node_graph)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let stmts = Stack.create () in
+
+ let visit_stmt_pre s =
+ Stack.push s stmts;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_stmt_post s =
+ inner.Walk.visit_stmt_post s;
+ ignore (Stack.pop stmts)
+ in
+
+ let visit_block_pre b =
+ begin
+ let len = Array.length b.node in
+
+ (* Flow container-stmt to block, save existing out-edges for below. *)
+ let dsts =
+ if Stack.is_empty stmts
+ then []
+ else
+ let s = Stack.top stmts in
+ let dsts = Hashtbl.find graph s.id in
+ add_flow_edges graph s.id [b.id];
+ dsts
+ in
+
+ (*
+ * If block has len,
+ * then flow block to block.node.(0) and block.node.(len-1) to dsts
+ * else flow block to dsts
+ *
+ * so AST:
+ *
+ * block#n{ stmt#0 ... stmt#k };
+ * stmt#j;
+ *
+ * turns into graph:
+ *
+ * block#n -> stmt#0 -> ... -> stmt#k -> stmt#j
+ *
+ *)
+
+ if len > 0
+ then
+ begin
+ htab_put graph b.id [b.node.(0).id];
+ add_flow_edges graph b.node.(len-1).id dsts
+ end
+ else
+ htab_put graph b.id dsts
+ end;
+ inner.Walk.visit_block_pre b
+ in
+
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_stmt_post = visit_stmt_post;
+ Walk.visit_block_pre = visit_block_pre }
+;;
+
+
+let graph_special_block_structure_building_visitor
+ ((*cx*)_:ctxt)
+ (graph:(node_id, (node_id list)) Hashtbl.t)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ let visit_stmt_pre s =
+ begin
+ match s.node with
+
+ | Ast.STMT_if sif ->
+ (*
+ * Drop implicit stmt-bypass edge(s);
+ * can only flow to inner block(s).
+ *)
+ let block_ids =
+ [sif.Ast.if_then.id] @
+ match sif.Ast.if_else with
+ None -> []
+ | Some eb -> [eb.id]
+ in
+ Hashtbl.replace graph s.id block_ids
+
+ | Ast.STMT_while sw ->
+ (* There are a bunch of rewirings to do on 'while' nodes. *)
+
+ begin
+ let dsts = Hashtbl.find graph s.id in
+ let body = sw.Ast.while_body in
+ let succ_stmts =
+ List.filter (fun x -> not (x = body.id)) dsts
+ in
+
+ let (pre_loop_stmts, _) = sw.Ast.while_lval in
+ let loop_head_id =
+ (* Splice loop prelude into flow graph, save loop-head
+ * node.
+ *)
+ let slen = Array.length pre_loop_stmts in
+ if slen > 0
+ then
+ begin
+ remove_flow_edges graph s.id [body.id];
+ add_flow_edges graph s.id [pre_loop_stmts.(0).id];
+ add_flow_edges graph
+ pre_loop_stmts.(slen-1).id [body.id];
+ pre_loop_stmts.(slen - 1).id
+ end
+ else
+ body.id
+ in
+
+ (* Always flow s into the loop prelude; prelude may end
+ * loop.
+ *)
+ remove_flow_edges graph s.id succ_stmts;
+ add_flow_edges graph loop_head_id succ_stmts;
+
+ (* Flow loop-end to loop-head. *)
+ let blen = Array.length body.node in
+ if blen > 0
+ then add_flow_edges graph
+ body.node.(blen - 1).id [loop_head_id]
+ else add_flow_edges graph
+ body.id [loop_head_id]
+ end
+
+ | Ast.STMT_alt_tag at ->
+ let dsts = Hashtbl.find graph s.id in
+ let arm_blocks =
+ let arm_block_id { node = (_, block) } = block.id in
+ Array.to_list (Array.map arm_block_id at.Ast.alt_tag_arms)
+ in
+ let succ_stmts =
+ List.filter (fun x -> not (List.mem x arm_blocks)) dsts
+ in
+ remove_flow_edges graph s.id succ_stmts
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_post s
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let find_roots
+ (graph:(node_id, (node_id list)) Hashtbl.t)
+ : (node_id,unit) Hashtbl.t =
+ let roots = Hashtbl.create 0 in
+ Hashtbl.iter (fun src _ -> Hashtbl.replace roots src ()) graph;
+ Hashtbl.iter (fun _ dsts ->
+ List.iter (fun d -> Hashtbl.remove roots d) dsts) graph;
+ roots
+;;
+
+let run_dataflow cx graph : unit =
+ let roots = find_roots graph in
+ let nodes = Queue.create () in
+ let progress = ref true in
+ let fmt_constr_bitv bitv =
+ String.concat ", "
+ (List.map
+ (fun i ->
+ fmt_constr_key cx
+ (Hashtbl.find cx.ctxt_constrs (Constr i)))
+ (Bits.to_list bitv))
+ in
+ let set_bits dst src =
+ if Bits.copy dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx "made progress setting bits"))
+ in
+ let intersect_bits dst src =
+ if Bits.intersect dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx
+ "made progress intersecting bits"))
+ in
+ let raise_bits dst src =
+ if Bits.union dst src
+ then (progress := true;
+ iflog cx (fun _ -> log cx
+ "made progress unioning bits"))
+ in
+ let iter = ref 0 in
+ let written = Hashtbl.create 0 in
+ Hashtbl.iter (fun n _ -> Queue.push n nodes) roots;
+ while !progress do
+ incr iter;
+ progress := false;
+ iflog cx (fun _ -> log cx "dataflow pass %d" (!iter));
+ Queue.iter
+ begin
+ fun node ->
+ let prestate = Hashtbl.find cx.ctxt_prestates node in
+ let postcond = Hashtbl.find cx.ctxt_postconditions node in
+ let poststate = Hashtbl.find cx.ctxt_poststates node in
+ iflog cx (fun _ -> log cx "stmt %d: '%s'" (int_of_node node)
+ (match htab_search cx.ctxt_all_stmts node with
+ None -> "??"
+ | Some stmt -> Ast.fmt_to_str Ast.fmt_stmt stmt));
+ iflog cx (fun _ -> log cx "stmt %d:" (int_of_node node));
+ iflog cx (fun _ -> log cx
+ " prestate %s" (fmt_constr_bitv prestate));
+ raise_bits poststate prestate;
+ raise_bits poststate postcond;
+ iflog cx (fun _ -> log cx
+ " poststate %s" (fmt_constr_bitv poststate));
+ Hashtbl.replace written node ();
+ let successors = Hashtbl.find graph node in
+ let i = int_of_node node in
+ iflog cx (fun _ -> log cx
+ "out-edges for %d: %s" i (lset_fmt successors));
+ List.iter
+ begin
+ fun succ ->
+ let succ_prestates =
+ Hashtbl.find cx.ctxt_prestates succ
+ in
+ if Hashtbl.mem written succ
+ then
+ begin
+ intersect_bits succ_prestates poststate;
+ Hashtbl.replace written succ ()
+ end
+ else
+ begin
+ progress := true;
+ Queue.push succ nodes;
+ set_bits succ_prestates poststate
+ end
+ end
+ successors
+ end
+ nodes
+ done
+;;
+
+let typestate_verify_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+ let visit_stmt_pre s =
+ let prestate = Hashtbl.find cx.ctxt_prestates s.id in
+ let precond = Hashtbl.find cx.ctxt_preconditions s.id in
+ List.iter
+ (fun i ->
+ if not (Bits.get prestate i)
+ then
+ let ckey = Hashtbl.find cx.ctxt_constrs (Constr i) in
+ let constr_str = fmt_constr_key cx ckey in
+ err (Some s.id)
+ "Unsatisfied precondition constraint %s at stmt %d: %s"
+ constr_str
+ (int_of_node s.id)
+ (Ast.fmt_to_str Ast.fmt_stmt
+ (Hashtbl.find cx.ctxt_all_stmts s.id)))
+ (Bits.to_list precond);
+ inner.Walk.visit_stmt_pre s
+ in
+ { inner with
+ Walk.visit_stmt_pre = visit_stmt_pre }
+;;
+
+let lifecycle_visitor
+ (cx:ctxt)
+ (inner:Walk.visitor)
+ : Walk.visitor =
+
+ (*
+ * This visitor doesn't *calculate* part of the typestate; it uses
+ * the typestates calculated in earlier passes to extract "summaries"
+ * of slot-lifecycle events into the ctxt tables
+ * ctxt_copy_stmt_is_init and ctxt_post_stmt_slot_drops. These are
+ * used later on in translation.
+ *)
+
+ let (live_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 mark_slot_init sl =
+ Stack.push sl (Stack.top live_block_slots)
+ in
+
+
+ let visit_block_pre b =
+ Stack.push (Stack.create()) live_block_slots;
+ begin
+ match htab_search implicit_init_block_slots b.id with
+ None -> ()
+ | Some slot -> mark_slot_init slot
+ end;
+ inner.Walk.visit_block_pre b
+ in
+
+ let note_drops stmt slots =
+ iflog cx
+ begin
+ fun _ ->
+ log cx "implicit drop of %d slots after stmt %a: "
+ (List.length slots)
+ Ast.sprintf_stmt stmt;
+ List.iter (fun s -> log cx "drop: %a"
+ Ast.sprintf_slot_key
+ (Hashtbl.find cx.ctxt_slot_keys s))
+ slots
+ end;
+ htab_put cx.ctxt_post_stmt_slot_drops stmt.id slots
+ in
+
+ let visit_block_post b =
+ inner.Walk.visit_block_post b;
+ let blk_live = Stack.pop live_block_slots in
+ let stmts = b.node in
+ let len = Array.length stmts in
+ if len > 0
+ then
+ begin
+ let s = stmts.(len-1) in
+ match s.node with
+ 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
+ end;
+ in
+
+ let visit_stmt_pre s =
+ begin
+ let init_lval lv_dst =
+ let dst_slots = lval_slots cx lv_dst in
+ Array.iter mark_slot_init dst_slots;
+ in
+ match s.node with
+ Ast.STMT_copy (lv_dst, _)
+ | Ast.STMT_call (lv_dst, _, _)
+ | Ast.STMT_spawn (lv_dst, _, _, _)
+ | Ast.STMT_recv (lv_dst, _)
+ | Ast.STMT_bind (lv_dst, _, _) ->
+ let prestate = Hashtbl.find cx.ctxt_prestates s.id in
+ let poststate = Hashtbl.find cx.ctxt_poststates s.id in
+ let dst_slots = lval_slots cx lv_dst in
+ let is_initializing slot =
+ let cid =
+ Hashtbl.find cx.ctxt_constr_ids (Constr_init slot)
+ in
+ let i = int_of_constr cid in
+ (not (Bits.get prestate i)) && (Bits.get poststate i)
+ in
+ let initializing =
+ List.exists is_initializing (Array.to_list dst_slots)
+ in
+ if initializing
+ then
+ begin
+ Hashtbl.add cx.ctxt_copy_stmt_is_init s.id ();
+ init_lval lv_dst
+ end;
+
+ | Ast.STMT_init_rec (lv_dst, _, _)
+ | Ast.STMT_init_tup (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, _) ->
+ init_lval lv_dst
+
+ | Ast.STMT_for f ->
+ log cx "noting implicit init for slot %d in for-block %d"
+ (int_of_node (fst f.Ast.for_slot).id)
+ (int_of_node (f.Ast.for_body.id));
+ htab_put implicit_init_block_slots
+ f.Ast.for_body.id
+ (fst f.Ast.for_slot).id
+
+ | Ast.STMT_for_each f ->
+ log cx "noting implicit init for slot %d in for_each-block %d"
+ (int_of_node (fst f.Ast.for_each_slot).id)
+ (int_of_node (f.Ast.for_each_body.id));
+ htab_put implicit_init_block_slots
+ f.Ast.for_each_body.id
+ (fst f.Ast.for_each_slot).id
+
+
+ | _ -> ()
+ end;
+ inner.Walk.visit_stmt_pre s
+ in
+
+ let visit_stmt_post s =
+ inner.Walk.visit_stmt_post s;
+ match s.node with
+ Ast.STMT_ret _
+ | Ast.STMT_be _ ->
+ let stks = stk_elts_from_top live_block_slots in
+ let slots = List.concat (List.map stk_elts_from_top stks) in
+ note_drops s slots
+ | _ -> ()
+ in
+
+ { inner with
+ Walk.visit_block_pre = visit_block_pre;
+ Walk.visit_block_post = visit_block_post;
+ Walk.visit_stmt_pre = visit_stmt_pre;
+ Walk.visit_stmt_post = visit_stmt_post
+ }
+;;
+
+let process_crate
+ (cx:ctxt)
+ (crate:Ast.crate)
+ : unit =
+ let path = Stack.create () in
+ let (scopes:(scope list) ref) = ref [] in
+ let constr_id = ref 0 in
+ let (graph:(node_id, (node_id list)) Hashtbl.t) = Hashtbl.create 0 in
+ let setup_passes =
+ [|
+ (scope_stack_managing_visitor scopes
+ (constr_id_assigning_visitor cx scopes constr_id
+ Walk.empty_visitor));
+ (bitmap_assigning_visitor cx constr_id
+ Walk.empty_visitor);
+ (scope_stack_managing_visitor scopes
+ (condition_assigning_visitor cx scopes
+ Walk.empty_visitor));
+ (graph_sequence_building_visitor cx graph
+ Walk.empty_visitor);
+ (graph_general_block_structure_building_visitor cx graph
+ Walk.empty_visitor);
+ (graph_special_block_structure_building_visitor cx graph
+ Walk.empty_visitor);
+ |]
+ in
+ let verify_passes =
+ [|
+ (scope_stack_managing_visitor scopes
+ (typestate_verify_visitor cx
+ Walk.empty_visitor))
+ |]
+ in
+ let aux_passes =
+ [|
+ (lifecycle_visitor cx
+ Walk.empty_visitor)
+ |]
+ in
+ run_passes cx "typestate setup" path setup_passes (log cx "%s") crate;
+ run_dataflow cx 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
+;;
+
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml
new file mode 100644
index 00000000..3486bb16
--- /dev/null
+++ b/src/boot/me/walk.ml
@@ -0,0 +1,687 @@
+
+open Common;;
+
+(*
+ * The purpose of this module is just to decouple the AST from the
+ * various passes that are interested in visiting "parts" of it.
+ * If the AST shifts, we have better odds of the shift only affecting
+ * this module rather than all of its clients. Similarly if the
+ * clients only need to visit part, they only have to define the
+ * part of the walk they're interested in, making it cheaper to define
+ * multiple passes.
+ *)
+
+type visitor =
+ {
+ visit_stmt_pre: Ast.stmt -> unit;
+ visit_stmt_post: Ast.stmt -> unit;
+ visit_slot_identified_pre: (Ast.slot identified) -> unit;
+ visit_slot_identified_post: (Ast.slot identified) -> unit;
+ visit_expr_pre: Ast.expr -> unit;
+ visit_expr_post: Ast.expr -> unit;
+ visit_ty_pre: Ast.ty -> unit;
+ visit_ty_post: Ast.ty -> unit;
+ visit_constr_pre: node_id option -> Ast.constr -> unit;
+ visit_constr_post: node_id option -> Ast.constr -> unit;
+ visit_pat_pre: Ast.pat -> unit;
+ visit_pat_post: Ast.pat -> unit;
+ visit_block_pre: Ast.block -> unit;
+ visit_block_post: Ast.block -> unit;
+
+ visit_lit_pre: Ast.lit -> unit;
+ visit_lit_post: Ast.lit -> unit;
+ visit_lval_pre: Ast.lval -> unit;
+ visit_lval_post: Ast.lval -> unit;
+ visit_mod_item_pre:
+ (Ast.ident
+ -> ((Ast.ty_param identified) array)
+ -> Ast.mod_item
+ -> unit);
+ visit_mod_item_post:
+ (Ast.ident
+ -> ((Ast.ty_param identified) array)
+ -> Ast.mod_item
+ -> unit);
+ visit_obj_fn_pre:
+ (Ast.obj identified) -> Ast.ident -> (Ast.fn identified) -> unit;
+ visit_obj_fn_post:
+ (Ast.obj identified) -> Ast.ident -> (Ast.fn identified) -> unit;
+ visit_obj_drop_pre:
+ (Ast.obj identified) -> Ast.block -> unit;
+ visit_obj_drop_post:
+ (Ast.obj identified) -> Ast.block -> unit;
+ visit_crate_pre: Ast.crate -> unit;
+ visit_crate_post: Ast.crate -> unit;
+ }
+;;
+
+
+let empty_visitor =
+ { visit_stmt_pre = (fun _ -> ());
+ visit_stmt_post = (fun _ -> ());
+ visit_slot_identified_pre = (fun _ -> ());
+ visit_slot_identified_post = (fun _ -> ());
+ visit_expr_pre = (fun _ -> ());
+ visit_expr_post = (fun _ -> ());
+ visit_ty_pre = (fun _ -> ());
+ visit_ty_post = (fun _ -> ());
+ visit_constr_pre = (fun _ _ -> ());
+ visit_constr_post = (fun _ _ -> ());
+ visit_pat_pre = (fun _ -> ());
+ visit_pat_post = (fun _ -> ());
+ visit_block_pre = (fun _ -> ());
+ visit_block_post = (fun _ -> ());
+ visit_lit_pre = (fun _ -> ());
+ visit_lit_post = (fun _ -> ());
+ visit_lval_pre = (fun _ -> ());
+ visit_lval_post = (fun _ -> ());
+ visit_mod_item_pre = (fun _ _ _ -> ());
+ visit_mod_item_post = (fun _ _ _ -> ());
+ visit_obj_fn_pre = (fun _ _ _ -> ());
+ visit_obj_fn_post = (fun _ _ _ -> ());
+ visit_obj_drop_pre = (fun _ _ -> ());
+ visit_obj_drop_post = (fun _ _ -> ());
+ visit_crate_pre = (fun _ -> ());
+ visit_crate_post = (fun _ -> ()); }
+;;
+
+let path_managing_visitor
+ (path:Ast.name_component Stack.t)
+ (inner:visitor)
+ : visitor =
+ let visit_mod_item_pre ident params item =
+ Stack.push (Ast.COMP_ident ident) path;
+ inner.visit_mod_item_pre ident params item
+ in
+ let visit_mod_item_post ident params item =
+ inner.visit_mod_item_post ident params item;
+ ignore (Stack.pop path)
+ in
+ let visit_obj_fn_pre obj ident fn =
+ Stack.push (Ast.COMP_ident ident) path;
+ inner.visit_obj_fn_pre obj ident fn
+ in
+ let visit_obj_fn_post obj ident fn =
+ inner.visit_obj_fn_post obj ident fn;
+ ignore (Stack.pop path)
+ in
+ let visit_obj_drop_pre obj b =
+ Stack.push (Ast.COMP_ident "drop") path;
+ inner.visit_obj_drop_pre obj b
+ in
+ let visit_obj_drop_post obj b =
+ inner.visit_obj_drop_post obj b;
+ ignore (Stack.pop path)
+ 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 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 _ = Ast.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)
+ (children:unit -> unit)
+ (post:'a -> unit)
+ (x:'a)
+ : unit =
+ begin
+ pre x;
+ children ();
+ post x
+ end
+;;
+
+
+let walk_option
+ (walker:'a -> unit)
+ (opt:'a option)
+ : unit =
+ match opt with
+ None -> ()
+ | Some v -> walker v
+;;
+
+
+let rec walk_crate
+ (v:visitor)
+ (crate:Ast.crate)
+ : unit =
+ walk_bracketed
+ v.visit_crate_pre
+ (fun _ -> walk_mod_items v (snd crate.node.Ast.crate_items))
+ v.visit_crate_post
+ crate
+
+and walk_mod_items
+ (v:visitor)
+ (items:Ast.mod_items)
+ : unit =
+ Hashtbl.iter (walk_mod_item v) items
+
+
+and walk_mod_item
+ (v:visitor)
+ (name:Ast.ident)
+ (item:Ast.mod_item)
+ : unit =
+ let children _ =
+ match item.node.Ast.decl_item with
+ Ast.MOD_ITEM_type ty -> walk_ty v ty
+ | Ast.MOD_ITEM_fn f -> walk_fn v f item.id
+ | Ast.MOD_ITEM_tag (htup, ttag, _) ->
+ walk_header_tup v htup;
+ walk_ty_tag v ttag
+ | Ast.MOD_ITEM_mod (_, items) ->
+ walk_mod_items v items
+ | Ast.MOD_ITEM_obj ob ->
+ walk_header_slots v ob.Ast.obj_state;
+ walk_constrs v (Some item.id) ob.Ast.obj_constrs;
+ let oid = { node = ob; id = item.id } in
+ Hashtbl.iter (walk_obj_fn v oid) ob.Ast.obj_fns;
+ match ob.Ast.obj_drop with
+ None -> ()
+ | Some d ->
+ v.visit_obj_drop_pre oid d;
+ walk_block v d;
+ v.visit_obj_drop_post oid d
+
+ in
+ walk_bracketed
+ (v.visit_mod_item_pre name item.node.Ast.decl_params)
+ children
+ (v.visit_mod_item_post name item.node.Ast.decl_params)
+ item
+
+
+and walk_ty_tup v ttup = Array.iter (walk_slot v) ttup
+
+and walk_ty_tag v ttag = Hashtbl.iter (fun _ t -> walk_ty_tup v t) ttag
+
+and walk_ty
+ (v:visitor)
+ (ty:Ast.ty)
+ : unit =
+ let children _ =
+ match ty with
+ Ast.TY_tup ttup -> walk_ty_tup v ttup
+ | Ast.TY_vec s -> walk_slot v s
+ | Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_slot v s) trec
+ | Ast.TY_tag ttag -> walk_ty_tag v ttag
+ | Ast.TY_iso tiso -> Array.iter (walk_ty_tag v) tiso.Ast.iso_group
+ | Ast.TY_fn tfn -> walk_ty_fn v tfn
+ | Ast.TY_obj (_, fns) ->
+ Hashtbl.iter (fun _ tfn -> walk_ty_fn v tfn) fns
+ | Ast.TY_chan t -> walk_ty v t
+ | Ast.TY_port t -> walk_ty v t
+ | Ast.TY_constrained (t,cs) ->
+ begin
+ walk_ty v t;
+ walk_constrs v None cs
+ end
+ | Ast.TY_named _ -> ()
+ | Ast.TY_param _ -> ()
+ | Ast.TY_native _ -> ()
+ | Ast.TY_idx _ -> ()
+ | Ast.TY_mach _ -> ()
+ | Ast.TY_type -> ()
+ | Ast.TY_str -> ()
+ | Ast.TY_char -> ()
+ | Ast.TY_int -> ()
+ | Ast.TY_uint -> ()
+ | Ast.TY_bool -> ()
+ | Ast.TY_nil -> ()
+ | Ast.TY_task -> ()
+ | Ast.TY_any -> ()
+ in
+ walk_bracketed
+ v.visit_ty_pre
+ children
+ v.visit_ty_post
+ ty
+
+
+and walk_ty_sig
+ (v:visitor)
+ (s:Ast.ty_sig)
+ : unit =
+ begin
+ Array.iter (walk_slot v) s.Ast.sig_input_slots;
+ walk_constrs v None s.Ast.sig_input_constrs;
+ walk_slot v s.Ast.sig_output_slot;
+ end
+
+
+and walk_ty_fn
+ (v:visitor)
+ (tfn:Ast.ty_fn)
+ : unit =
+ let (tsig, _) = tfn in
+ walk_ty_sig v tsig
+
+
+and walk_constrs
+ (v:visitor)
+ (formal_base:node_id option)
+ (cs:Ast.constrs)
+ : unit =
+ Array.iter (walk_constr v formal_base) cs
+
+and walk_check_calls
+ (v:visitor)
+ (calls:Ast.check_calls)
+ : unit =
+ Array.iter
+ begin
+ fun (f, args) ->
+ walk_lval v f;
+ Array.iter (walk_atom v) args
+ end
+ calls
+
+
+and walk_constr
+ (v:visitor)
+ (formal_base:node_id option)
+ (c:Ast.constr)
+ : unit =
+ walk_bracketed
+ (v.visit_constr_pre formal_base)
+ (fun _ -> ())
+ (v.visit_constr_post formal_base)
+ c
+
+and walk_header_slots
+ (v:visitor)
+ (hslots:Ast.header_slots)
+ : unit =
+ Array.iter (fun (s,_) -> walk_slot_identified v s) hslots
+
+and walk_header_tup
+ (v:visitor)
+ (htup:Ast.header_tup)
+ : unit =
+ Array.iter (walk_slot_identified v) htup
+
+and walk_obj_fn
+ (v:visitor)
+ (obj:Ast.obj identified)
+ (ident:Ast.ident)
+ (f:Ast.fn identified)
+ : unit =
+ v.visit_obj_fn_pre obj ident f;
+ walk_fn v f.node f.id;
+ v.visit_obj_fn_post obj ident f
+
+and walk_fn
+ (v:visitor)
+ (f:Ast.fn)
+ (id:node_id)
+ : unit =
+ walk_header_slots v f.Ast.fn_input_slots;
+ walk_constrs v (Some id) f.Ast.fn_input_constrs;
+ walk_slot_identified v f.Ast.fn_output_slot;
+ walk_block v f.Ast.fn_body
+
+and walk_slot_identified
+ (v:visitor)
+ (s:Ast.slot identified)
+ : unit =
+ walk_bracketed
+ v.visit_slot_identified_pre
+ (fun _ -> walk_slot v s.node)
+ v.visit_slot_identified_post
+ s
+
+
+and walk_slot
+ (v:visitor)
+ (s:Ast.slot)
+ : unit =
+ walk_option (walk_ty v) s.Ast.slot_ty
+
+
+and walk_stmt
+ (v:visitor)
+ (s:Ast.stmt)
+ : unit =
+ let walk_stmt_for
+ (s:Ast.stmt_for)
+ : unit =
+ let (si,_) = s.Ast.for_slot in
+ let (ss,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
+ let walk_stmt_for_each
+ (s:Ast.stmt_for_each)
+ : unit =
+ let (si,_) = s.Ast.for_each_slot in
+ let (f,az) = s.Ast.for_each_call in
+ walk_slot_identified v si;
+ walk_lval v f;
+ Array.iter (walk_atom v) az;
+ walk_block v s.Ast.for_each_head
+ in
+ let walk_stmt_while
+ (s:Ast.stmt_while)
+ : unit =
+ let (ss,e) = s.Ast.while_lval in
+ Array.iter (walk_stmt v) ss;
+ walk_expr v e;
+ walk_block v s.Ast.while_body
+ in
+ let children _ =
+ match s.node with
+ Ast.STMT_log a ->
+ walk_atom v a
+
+ | Ast.STMT_init_rec (lv, atab, base) ->
+ walk_lval v lv;
+ Array.iter (fun (_, _, _, a) -> walk_atom v a) atab;
+ walk_option (walk_lval v) base;
+
+ | 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 (fun (_, _, a) -> walk_atom v a) mut_atoms
+
+ | Ast.STMT_init_str (lv, _) ->
+ walk_lval v lv
+
+ | Ast.STMT_init_port lv ->
+ walk_lval v lv
+
+ | Ast.STMT_init_chan (chan,port) ->
+ walk_option (walk_lval v) port;
+ walk_lval v chan;
+
+ | Ast.STMT_for f ->
+ walk_stmt_for f
+
+ | Ast.STMT_for_each f ->
+ walk_stmt_for_each f
+
+ | Ast.STMT_while w ->
+ walk_stmt_while w
+
+ | Ast.STMT_do_while w ->
+ walk_stmt_while w
+
+ | Ast.STMT_if i ->
+ begin
+ walk_expr v i.Ast.if_test;
+ walk_block v i.Ast.if_then;
+ walk_option (walk_block v) i.Ast.if_else
+ end
+
+ | Ast.STMT_block b ->
+ walk_block v b
+
+ | Ast.STMT_copy (lv,e) ->
+ walk_lval v lv;
+ walk_expr v e
+
+ | Ast.STMT_copy_binop (lv,_,a) ->
+ walk_lval v lv;
+ walk_atom v a
+
+ | Ast.STMT_call (dst,f,az) ->
+ walk_lval v dst;
+ walk_lval v f;
+ Array.iter (walk_atom v) az
+
+ | Ast.STMT_bind (dst, f, az) ->
+ walk_lval v dst;
+ walk_lval v f;
+ Array.iter (walk_opt_atom v) az
+
+ | Ast.STMT_spawn (dst,_,p,az) ->
+ walk_lval v dst;
+ walk_lval v p;
+ Array.iter (walk_atom v) az
+
+ | Ast.STMT_ret ao ->
+ walk_option (walk_atom v) ao
+
+ | Ast.STMT_put at ->
+ walk_option (walk_atom v) at
+
+ | Ast.STMT_put_each (lv, ats) ->
+ walk_lval v lv;
+ Array.iter (walk_atom v) ats
+
+ (* FIXME: this should have a param array, and invoke the visitors. *)
+ | Ast.STMT_decl (Ast.DECL_mod_item (id, mi)) ->
+ walk_mod_item v id mi
+
+ | Ast.STMT_decl (Ast.DECL_slot (_, slot)) ->
+ walk_slot_identified v slot
+
+ | Ast.STMT_yield
+ | Ast.STMT_fail ->
+ ()
+
+ | Ast.STMT_join task ->
+ walk_lval v task
+
+ | Ast.STMT_send (dst,src) ->
+ walk_lval v dst;
+ walk_lval v src
+
+ | Ast.STMT_recv (dst,src) ->
+ walk_lval v dst;
+ walk_lval v src
+
+ | Ast.STMT_be (lv, ats) ->
+ walk_lval v lv;
+ Array.iter (walk_atom v) ats
+
+ | Ast.STMT_check_expr e ->
+ walk_expr v e
+
+ | Ast.STMT_check (cs, calls) ->
+ walk_constrs v None cs;
+ walk_check_calls v calls
+
+ | Ast.STMT_check_if (cs,calls,b) ->
+ walk_constrs v None cs;
+ walk_check_calls v calls;
+ walk_block v b
+
+ | Ast.STMT_prove cs ->
+ walk_constrs v None cs
+
+ | Ast.STMT_alt_tag
+ { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } ->
+ walk_lval v lval;
+ let walk_arm { node = (pat, block) } =
+ walk_pat v pat;
+ walk_block v block
+ in
+ Array.iter walk_arm arms
+
+ (* FIXME (issue #20): finish this as needed. *)
+ | Ast.STMT_slice _
+ | Ast.STMT_note _
+ | Ast.STMT_alt_type _
+ | Ast.STMT_alt_port _ ->
+ bug () "unimplemented statement type in Walk.walk_stmt"
+ in
+ walk_bracketed
+ v.visit_stmt_pre
+ children
+ v.visit_stmt_post
+ s
+
+
+and walk_expr
+ (v:visitor)
+ (e:Ast.expr)
+ : unit =
+ let children _ =
+ match e with
+ Ast.EXPR_binary (_,aa,ab) ->
+ walk_atom v aa;
+ walk_atom v ab
+ | Ast.EXPR_unary (_,a) ->
+ walk_atom v a
+ | Ast.EXPR_atom a ->
+ walk_atom v a
+ in
+ walk_bracketed
+ v.visit_expr_pre
+ children
+ v.visit_expr_post
+ e
+
+and walk_atom
+ (v:visitor)
+ (a:Ast.atom)
+ : unit =
+ match a with
+ Ast.ATOM_literal ls -> walk_lit v ls.node
+ | Ast.ATOM_lval lv -> walk_lval v lv
+
+
+and walk_opt_atom
+ (v:visitor)
+ (ao:Ast.atom option)
+ : unit =
+ match ao with
+ None -> ()
+ | Some a -> walk_atom v a
+
+
+and walk_lit
+ (v:visitor)
+ (li:Ast.lit)
+ : unit =
+ walk_bracketed
+ v.visit_lit_pre
+ (fun _ -> ())
+ v.visit_lit_post
+ li
+
+
+and walk_lval
+ (v:visitor)
+ (lv:Ast.lval)
+ : unit =
+ walk_bracketed
+ v.visit_lval_pre
+ (fun _ -> ())
+ v.visit_lval_post
+ lv
+
+
+and walk_pat
+ (v:visitor)
+ (p:Ast.pat)
+ : unit =
+ let rec walk p =
+ match p with
+ Ast.PAT_lit lit -> walk_lit v lit
+ | Ast.PAT_tag (_, pats) -> Array.iter walk pats
+ | Ast.PAT_slot (si, _) -> walk_slot_identified v si
+ | Ast.PAT_wild -> ()
+ in
+ walk_bracketed
+ v.visit_pat_pre
+ (fun _ -> walk p)
+ v.visit_pat_post
+ p
+
+
+and walk_block
+ (v:visitor)
+ (b:Ast.block)
+ : unit =
+ walk_bracketed
+ v.visit_block_pre
+ (fun _ -> (Array.iter (walk_stmt v) b.node))
+ v.visit_block_post
+ b
+;;
+
+(*
+ * Local Variables:
+ * fill-column: 78;
+ * indent-tabs-mode: nil
+ * buffer-file-coding-system: utf-8-unix
+ * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
+ * End:
+ *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-11 11:45:16 +0000