From beb4c07e26794dde482b4de85107f1e078375036 Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Tue, 12 Oct 2010 12:28:46 -0700 Subject: Git index wins again. --- src/boot/be/ra.ml | 9 +++++++-- src/boot/llvm/lltrans.ml | 25 +++++++++++++------------ src/boot/me/dead.ml | 36 ++++++++++++++++++++++++------------ src/boot/me/resolve.ml | 20 ++++++++++++-------- src/boot/me/semant.ml | 17 ++++++++++------- src/boot/me/trans.ml | 8 +++++--- src/boot/me/type.ml | 42 +++++++++++++++++++++++++++--------------- src/boot/me/typestate.ml | 11 ++++++----- src/boot/me/walk.ml | 2 +- 9 files changed, 105 insertions(+), 65 deletions(-) (limited to 'src/boot') diff --git a/src/boot/be/ra.ml b/src/boot/be/ra.ml index 3b3e8b92..66da8093 100644 --- a/src/boot/be/ra.ml +++ b/src/boot/be/ra.ml @@ -132,7 +132,12 @@ let kill_redundant_moves (cx:ctxt) : unit = let quad_jump_target_labels (q:quad) : Il.label list = match q.Il.quad_body with - Il.Jmp { Il.jmp_targ = Il.CodeLabel lab; _ } -> [ lab ] + Il.Jmp jmp -> + begin + match jmp.Il.jmp_targ with + Il.CodeLabel lab -> [ lab ] + | _ -> [] + end | _ -> [] ;; @@ -172,7 +177,7 @@ let quad_defined_vregs (q:quad) : Il.vreg list = let quad_is_unconditional_jump (q:quad) : bool = match q.Il.quad_body with - Il.Jmp { jmp_op = Il.JMP; _ } -> true + Il.Jmp { jmp_op = Il.JMP; jmp_targ = _ } -> true | Il.Ret -> true | _ -> false ;; diff --git a/src/boot/llvm/lltrans.ml b/src/boot/llvm/lltrans.ml index 983e8bc3..c3b097af 100644 --- a/src/boot/llvm/lltrans.ml +++ b/src/boot/llvm/lltrans.ml @@ -110,8 +110,9 @@ let trans_crate : Llvm.llvalue option = match Session.get_span sess id with None -> None - | Some {lo=(_, line, col); _} -> - Some (di_location line col scope) + | Some span -> + let (_, line, col) = span.lo in + Some (di_location line col scope) in (* Sets the 'llbuilder's current location (which it attaches to all @@ -585,7 +586,8 @@ let trans_crate (name:Ast.ident) mod_item : unit = - let { node = { Ast.decl_item = (item:Ast.mod_item'); _ }; id = id } = + let { node = { Ast.decl_item = (item:Ast.mod_item'); + Ast.decl_params = _ }; id = id } = mod_item in let full_name = Semant.item_str sem_cx id in let (filename, line_num) = @@ -618,13 +620,11 @@ let trans_crate Ast.sprintf_mod_item (name, mod_item) in - let trans_fn - ({ - Ast.fn_input_slots = (header_slots:Ast.header_slots); - Ast.fn_body = (body:Ast.block); _ - }:Ast.fn) + let trans_fn (fn:Ast.fn) (fn_id:node_id) : unit = + let header_slots = fn.Ast.fn_input_slots in + let body = fn.Ast.fn_body in let llfn = Hashtbl.find llitems fn_id in let lloutptr = Llvm.param llfn 0 in let lltask = Llvm.param llfn 1 in @@ -654,7 +654,7 @@ let trans_crate let build_arg idx llargval = if idx >= n_implicit_args then - let ({ id = id; _ }, ident) = header_slots.(idx - 2) in + let ({ id = id; node = _ }, ident) = header_slots.(idx - 2) in Llvm.set_value_name ident llargval; let llarg = let llty = Llvm.type_of llargval in @@ -754,7 +754,7 @@ let trans_crate let rec trans_lval (lval:Ast.lval) : (Llvm.llvalue * Ast.ty) = iflog (fun _ -> log sem_cx "trans_lval: %a" Ast.sprintf_lval lval); match lval with - Ast.LVAL_base { id = base_id; _ } -> + Ast.LVAL_base { id = base_id; node = _ } -> set_debug_loc base_id; let defn_id = lval_base_defn_id sem_cx lval in begin @@ -813,7 +813,7 @@ let trans_crate let trans_atom (atom:Ast.atom) : Llvm.llvalue = iflog (fun _ -> log sem_cx "trans_atom: %a" Ast.sprintf_atom atom); match atom with - Ast.ATOM_literal { node = lit; _ } -> trans_literal lit + Ast.ATOM_literal { node = lit; id = _ } -> trans_literal lit | Ast.ATOM_lval lval -> Llvm.build_load (fst (trans_lval lval)) (anon_llid "tmp") llbuilder @@ -1081,7 +1081,8 @@ let trans_crate (name:Ast.ident) mod_item : unit = - let { node = { Ast.decl_item = (item:Ast.mod_item'); _ }; id = id } = + let { node = { Ast.decl_item = (item:Ast.mod_item'); + Ast.decl_params = _ }; id = id } = mod_item in match item with Ast.MOD_ITEM_type _ -> diff --git a/src/boot/me/dead.ml b/src/boot/me/dead.ml index dbd510bb..376effed 100644 --- a/src/boot/me/dead.ml +++ b/src/boot/me/dead.ml @@ -37,21 +37,31 @@ let dead_code_visitor inner.Walk.visit_block_post block in + let exit_stmt_if_exit_body s body = + if (Hashtbl.mem must_exit body.id) then + Hashtbl.add must_exit s.id () + in + let visit_stmt_post s = begin - match s.node with + 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_while w + | Ast.STMT_do_while w -> + exit_stmt_if_exit_body s w.Ast.while_body + + | Ast.STMT_for_each f -> + exit_stmt_if_exit_body s f.Ast.for_each_body + + | Ast.STMT_for f -> + exit_stmt_if_exit_body s f.Ast.for_body - | Ast.STMT_if { Ast.if_then = b1; Ast.if_else = Some b2; _ } -> + | Ast.STMT_if { Ast.if_then = b1; + Ast.if_else = Some b2; + Ast.if_test = _ } -> if (Hashtbl.mem must_exit b1.id) && (Hashtbl.mem must_exit b2.id) then Hashtbl.add must_exit s.id () @@ -61,16 +71,18 @@ let dead_code_visitor | Ast.STMT_be _ -> Hashtbl.add must_exit s.id () - | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms; _ } -> + | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms; + Ast.alt_tag_lval = _ } -> let arm_ids = - Array.map (fun { node = (_, block); _ } -> block.id) arms + Array.map (fun { node = (_, block); id = _ } -> 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 { node = ((_, _), block); _ } -> + Ast.alt_type_else = alt_type_else; + Ast.alt_type_lval = _ } -> + let arm_ids = Array.map (fun { node = ((_, _), block); id = _ } -> block.id) arms in let else_ids = begin diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml index 879601fb..78d372d5 100644 --- a/src/boot/me/resolve.ml +++ b/src/boot/me/resolve.ml @@ -113,10 +113,11 @@ let stmt_collecting_visitor 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; _ } -> + | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms; + Ast.alt_tag_lval = _ } -> let rec resolve_pat block pat = match pat with - Ast.PAT_slot ({ id = slot_id; _ }, ident) -> + Ast.PAT_slot ({ id = slot_id; node = _ }, 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; @@ -125,7 +126,8 @@ let stmt_collecting_visitor | Ast.PAT_lit _ | Ast.PAT_wild -> () in - Array.iter (fun { node = (p, b); _ } -> resolve_pat b p) arms + Array.iter (fun { node = (p, b); id = _ } -> + resolve_pat b p) arms | _ -> () end; inner.Walk.visit_stmt_pre stmt @@ -236,8 +238,10 @@ let lookup_type_node_by_name 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_item { Ast.decl_item = Ast.MOD_ITEM_type _; + Ast.decl_params = _ }) + | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _; + Ast.decl_params = _ }) | Some (DEFN_ty_param _) -> id | _ -> err None "Found non-type binding for %a" @@ -645,8 +649,8 @@ let lval_base_resolving_visitor let reference_any_name lv = let rec lval_is_name lv = match lv with - Ast.LVAL_base {node = Ast.BASE_ident _; _} - | Ast.LVAL_base {node = Ast.BASE_app _; _} -> true + Ast.LVAL_base {node = Ast.BASE_ident _; id = _} + | Ast.LVAL_base {node = Ast.BASE_app _; id = _} -> true | Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_ident _)) | Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_app _)) -> lval_is_name lv' @@ -749,7 +753,7 @@ let pattern_resolving_visitor end in - let resolve_arm { node = arm; _ } = + let resolve_arm { node = arm; id = _ } = match fst arm with Ast.PAT_tag (lval, pats) -> let lval_nm = lval_to_name lval in diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index a4bad711..c8b3b45e 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -546,9 +546,9 @@ let slot_ty (s:Ast.slot) : Ast.ty = let fn_output_ty (fn_ty:Ast.ty) : Ast.ty = match fn_ty with - Ast.TY_fn ({ Ast.sig_output_slot = slot; _ }, _) -> + Ast.TY_fn (tsig, _) -> begin - match slot.Ast.slot_ty with + match tsig.Ast.sig_output_slot.Ast.slot_ty with Some ty -> ty | None -> bug () "function has untyped output slot" end @@ -579,8 +579,10 @@ let defn_is_static (d:defn) : bool = 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 + DEFN_slot { Ast.slot_ty = Some Ast.TY_fn _; + Ast.slot_mode = _ } + | DEFN_item { Ast.decl_item = (Ast.MOD_ITEM_fn _ ); + Ast.decl_params = _ } -> true | _ -> false ;; @@ -637,7 +639,7 @@ let atoms_to_names (atoms:Ast.atom array) let rec lval_to_name (lv:Ast.lval) : Ast.name = match lv with - Ast.LVAL_base { node = nb; _ } -> + Ast.LVAL_base { node = nb; id = _ } -> Ast.NAME_base nb | Ast.LVAL_ext (lv, lv_comp) -> let comp = @@ -655,7 +657,7 @@ let rec plval_to_name (pl:Ast.plval) : Ast.name = match pl with Ast.PLVAL_base nb -> Ast.NAME_base nb - | Ast.PLVAL_ext_name ({node = Ast.PEXP_lval pl; _}, nc) -> + | Ast.PLVAL_ext_name ({node = Ast.PEXP_lval pl; id = _}, nc) -> Ast.NAME_ext (plval_to_name pl, nc) | _ -> bug () "plval_to_name with plval that contains non-name components" ;; @@ -1878,7 +1880,8 @@ let get_mod_item (node:node_id) : (Ast.mod_view * Ast.mod_items) = match get_item cx node with - { Ast.decl_item = Ast.MOD_ITEM_mod md; _ } -> md + { Ast.decl_item = Ast.MOD_ITEM_mod md; + Ast.decl_params = _ } -> md | _ -> bugi cx node "defn is not a mod" ;; diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml index 2697c8b5..cb0b7c83 100644 --- a/src/boot/me/trans.ml +++ b/src/boot/me/trans.ml @@ -1368,7 +1368,8 @@ let trans_visitor 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 + DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj obj; + Ast.decl_params = _} -> obj | _ -> bug () "Trans.get_obj_vtbl on non-obj referent" in trans_crate_rel_data_operand (DATA_obj_vtbl id) @@ -4755,8 +4756,9 @@ let trans_visitor match lval with Ast.LVAL_ext (_, (Ast.COMP_named (Ast.COMP_ident id))) | Ast.LVAL_ext (_, (Ast.COMP_named (Ast.COMP_app (id, _)))) - | Ast.LVAL_base { node = Ast.BASE_ident id; _ } - | Ast.LVAL_base { node = Ast.BASE_app (id, _); _ } -> id + | Ast.LVAL_base { node = Ast.BASE_ident id; id = _ } + | Ast.LVAL_base { node = Ast.BASE_app (id, _); id = _ } -> + id | _ -> bug cx "expected lval ending in ident" in let ttag = diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml index 4b329502..2179c70e 100644 --- a/src/boot/me/type.ml +++ b/src/boot/me/type.ml @@ -1261,13 +1261,18 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit = if cx.Semant.ctxt_main_name = Some path_name then try match Hashtbl.find cx.Semant.ctxt_all_item_types item_id with - Ast.TY_fn ({ Ast.sig_input_slots = [| |]; _ }, _) - | Ast.TY_fn ({ Ast.sig_input_slots = [| { - Ast.slot_mode = Ast.MODE_local; - Ast.slot_ty = Some (Ast.TY_vec Ast.TY_str) - } |]; _}, _) -> - () - | _ -> Common.err (Some item_id) "main fn has bad type signature" + Ast.TY_fn (tsig, _) -> + begin + match tsig.Ast.sig_input_slots with + [| |] + | [| { + Ast.slot_mode = Ast.MODE_local; + Ast.slot_ty = Some (Ast.TY_vec Ast.TY_str) + } |] -> () + | _ -> Common.err (Some item_id) + "main fn has bad type signature" + end + | _ -> Common.err (Some item_id) "main item has bad non-fn type" with Not_found -> Common.err (Some item_id) "main item has no type (is it a function?)" in @@ -1325,14 +1330,21 @@ let process_crate (cx:Semant.ctxt) (crate:Ast.crate) : unit = let visit_obj_fn_pre obj ident _ = let obj_ty = Hashtbl.find cx.Semant.ctxt_all_item_types obj.Common.id in - match obj_ty with - Ast.TY_fn ({ Ast.sig_output_slot = - { Ast.slot_ty = Some (Ast.TY_obj (_, methods)); _ }; _ }, _) -> - push_fn_ctx_of_ty_fn (Hashtbl.find methods ident) - | _ -> - Common.bug () - "Type.visit_obj_fn_pre: item doesn't have an object type (%a)" - Ast.sprintf_ty obj_ty + let bad _ = + Common.bug () + "Type.visit_obj_fn_pre: item doesn't have an object type (%a)" + Ast.sprintf_ty obj_ty + in + match obj_ty with + Ast.TY_fn (tsig, _) -> + begin + match tsig.Ast.sig_output_slot with + { Ast.slot_ty = Some (Ast.TY_obj (_, methods)); + Ast.slot_mode = _ } -> + push_fn_ctx_of_ty_fn (Hashtbl.find methods ident) + | _ -> bad() + end + | _ -> bad() in let visit_obj_fn_post _ _ item = finish_function (item.Common.id) in diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml index 95aa1107..00629886 100644 --- a/src/boot/me/typestate.ml +++ b/src/boot/me/typestate.ml @@ -714,7 +714,7 @@ let condition_assigning_visitor | Ast.STMT_alt_tag at -> let precond = slot_inits (lval_slots cx at.Ast.alt_tag_lval) in - let visit_arm { node = (pat, block); _ } = + let visit_arm { node = (pat, block); id = _ } = (* FIXME (issue #34): propagate tag-carried constrs here. *) let rec get_slots pat = match pat with @@ -1048,7 +1048,7 @@ let graph_special_block_structure_building_visitor let graph = ts.ts_graph in let dsts = Hashtbl.find graph s.id in let arm_blocks = - let arm_block_id { node = (_, block); _ } = block.id in + let arm_block_id { node = (_, block); id = _ } = block.id in Array.to_list (Array.map arm_block_id at.Ast.alt_tag_arms) in let succ_stmts = @@ -1470,7 +1470,8 @@ let lifecycle_visitor iflog cx (fun _ -> log cx "entering a loop"); Stack.push (Some (Stack.create ())) loop_blocks; - | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms; _ } -> + | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms; + Ast.alt_tag_lval = _ } -> let note_slot block slot_id = log cx "noting implicit init for slot %d in pattern-alt block %d" @@ -1479,7 +1480,7 @@ let lifecycle_visitor in let rec all_pat_slot_ids block pat = match pat with - Ast.PAT_slot ({ id = slot_id; _ }, _) -> + Ast.PAT_slot ({ id = slot_id; node = _ }, _) -> [ slot_id ] | Ast.PAT_tag (_, pats) -> List.concat @@ -1490,7 +1491,7 @@ let lifecycle_visitor in Array.iter begin - fun { node = (pat, block); _ } -> + fun { node = (pat, block); id = _ } -> let slot_ids = all_pat_slot_ids block pat in List.iter (note_slot block) slot_ids; htab_put implicit_init_block_slots diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml index 03577c80..d3fdc9b4 100644 --- a/src/boot/me/walk.ml +++ b/src/boot/me/walk.ml @@ -517,7 +517,7 @@ and walk_stmt | Ast.STMT_alt_tag { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } -> walk_lval v lval; - let walk_arm { node = (pat, block); _ } = + let walk_arm { node = (pat, block); id=_ } = walk_pat v pat; walk_block v block in -- cgit v1.2.3