From 1f9fd2710ec9122ddddcedaab51650a92ad7c8cf Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Tue, 29 Jun 2010 12:00:15 -0700 Subject: [PATCH] Initial stab at lowering mutable and exterior into the type system. --- src/boot/driver/llvm/glue.ml | 2 +- src/boot/driver/main.ml | 2 +- src/boot/fe/ast.ml | 101 ++-- src/boot/fe/item.ml | 16 +- src/boot/fe/parser.ml | 2 - src/boot/fe/pexp.ml | 115 ++-- src/boot/me/alias.ml | 2 +- src/boot/me/dwarf.ml | 174 +++--- src/boot/me/effect.ml | 27 +- src/boot/me/semant.ml | 173 +++--- src/boot/me/trans.ml | 1058 +++++++++++++++++----------------- src/boot/me/transutil.ml | 64 +- src/boot/me/type.ml | 85 +-- src/boot/me/typestate.ml | 12 +- src/boot/me/walk.ml | 18 +- 15 files changed, 942 insertions(+), 909 deletions(-) diff --git a/src/boot/driver/llvm/glue.ml b/src/boot/driver/llvm/glue.ml index ef5c1c8653b..30fce0cd2d7 100644 --- a/src/boot/driver/llvm/glue.ml +++ b/src/boot/driver/llvm/glue.ml @@ -16,8 +16,8 @@ let alt_pipeline sess sem_cx crate = [| Resolve.process_crate; Type.process_crate; - Effect.process_crate; Typestate.process_crate; + Effect.process_crate; Loop.process_crate; Alias.process_crate; Dead.process_crate; diff --git a/src/boot/driver/main.ml b/src/boot/driver/main.ml index 8cfe4048b9c..5655604d3f2 100644 --- a/src/boot/driver/main.ml +++ b/src/boot/driver/main.ml @@ -316,8 +316,8 @@ let main_pipeline _ = exit_if_failed ()) [| Resolve.process_crate; Type.process_crate; - Effect.process_crate; Typestate.process_crate; + Effect.process_crate; Loop.process_crate; Alias.process_crate; Dead.process_crate; diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml index 770b57bf82b..8b1ce71fb34 100644 --- a/src/boot/fe/ast.ml +++ b/src/boot/fe/ast.ml @@ -9,11 +9,6 @@ open Common;; open Fmt;; -(* - * Slot names are given by a dot-separated path within the current - * module namespace. - *) - type ident = string ;; @@ -70,11 +65,11 @@ and ty = | TY_str | TY_tup of ty_tup - | TY_vec of slot + | TY_vec of ty | TY_rec of ty_rec (* - * Note that ty_idx is only valid inside a slot of a ty_iso group, not + * Note that ty_idx is only valid inside a ty of a ty_iso group, not * in a general type term. *) | TY_tag of ty_tag @@ -93,18 +88,25 @@ and ty = | TY_named of name | TY_type + | TY_exterior of ty + | TY_mutable of ty + | TY_constrained of (ty * constrs) +(* + * FIXME: this should be cleaned up to be a different + * type definition. Only args can be by-ref, only locals + * can be auto. The structure here is historical. + *) + and mode = - MODE_exterior | MODE_interior | MODE_alias and slot = { slot_mode: mode; - slot_mutable: bool; slot_ty: ty option; } -and ty_tup = slot array +and ty_tup = ty array (* In closed type terms a constraint may refer to components of the term by * anchoring off the "formal symbol" '*', which represents "the term this @@ -147,7 +149,7 @@ and constr = and constrs = constr array -and ty_rec = (ident * slot) array +and ty_rec = (ident * ty) array (* ty_tag is a sum type. * @@ -185,9 +187,9 @@ and ty_obj = (effect * ((ident,ty_fn) Hashtbl.t)) and check_calls = (lval * (atom array)) array -and rec_input = (ident * mode * bool * atom) +and rec_input = (ident * atom) -and tup_input = (mode * bool * atom) +and tup_input = atom and stmt' = @@ -195,10 +197,11 @@ and stmt' = STMT_spawn of (lval * domain * lval * (atom array)) | STMT_init_rec of (lval * (rec_input array) * lval option) | STMT_init_tup of (lval * (tup_input array)) - | STMT_init_vec of (lval * slot * (atom array)) + | STMT_init_vec of (lval * atom array) | STMT_init_str of (lval * string) | STMT_init_port of lval | STMT_init_chan of (lval * (lval option)) + | STMT_init_exterior of (lval * atom) | STMT_copy of (lval * expr) | STMT_copy_binop of (lval * binop * atom) | STMT_call of (lval * lval * (atom array)) @@ -516,13 +519,8 @@ and fmt_name (ff:Format.formatter) (n:name) : unit = fmt ff "."; fmt_name_component ff nc -and fmt_mutable (ff:Format.formatter) (m:bool) : unit = - if m - then fmt ff "mutable "; - and fmt_mode (ff:Format.formatter) (m:mode) : unit = match m with - MODE_exterior -> fmt ff "@@" | MODE_alias -> fmt ff "&" | MODE_interior -> () @@ -530,10 +528,27 @@ and fmt_slot (ff:Format.formatter) (s:slot) : unit = match s.slot_ty with None -> fmt ff "auto" | Some t -> - fmt_mutable ff s.slot_mutable; fmt_mode ff s.slot_mode; fmt_ty ff t +and fmt_tys + (ff:Format.formatter) + (tys:ty array) + : unit = + fmt_bracketed_arr_sep "(" ")" "," fmt_ty ff tys + +and fmt_ident_tys + (ff:Format.formatter) + (entries:(ident * ty) array) + : unit = + fmt_bracketed_arr_sep "(" ")" "," + (fun ff (ident, ty) -> + fmt_ty ff ty; + fmt ff " "; + fmt_ident ff ident) + ff + entries + and fmt_slots (ff:Format.formatter) (slots:slot array) @@ -594,7 +609,7 @@ and fmt_tag (ff:Format.formatter) (ttag:ty_tag) : unit = then first := false else fmt ff ",@ "); fmt_name ff name; - fmt_slots ff ttup None + fmt_tys ff ttup end ttag; fmt ff "@])@]" @@ -623,19 +638,15 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit = | TY_char -> fmt ff "char" | TY_str -> fmt ff "str" - | TY_tup slots -> (fmt ff "tup"; fmt_slots ff slots None) - | TY_vec s -> (fmt ff "vec["; fmt_slot ff s; fmt ff "]") + | TY_tup tys -> (fmt ff "tup"; fmt_tys ff tys) + | TY_vec t -> (fmt ff "vec["; fmt_ty ff t; fmt ff "]") | TY_chan t -> (fmt ff "chan["; fmt_ty ff t; fmt ff "]") | TY_port t -> (fmt ff "port["; fmt_ty ff t; fmt ff "]") - | TY_rec slots -> - let (idents, slots) = - let (idents, slots) = List.split (Array.to_list slots) in - (Array.of_list idents, Array.of_list slots) - in - fmt ff "@[rec"; - fmt_slots ff slots (Some idents); - fmt ff "@]" + | TY_rec entries -> + fmt ff "@[rec"; + fmt_ident_tys ff entries; + fmt ff "@]" | TY_param (i, e) -> (fmt_effect ff e; if e <> PURE then fmt ff " "; @@ -644,6 +655,14 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit = | TY_named n -> fmt_name ff n | TY_type -> fmt ff "type" + | TY_exterior t -> + fmt ff "@@"; + fmt_ty ff t + + | TY_mutable t -> + fmt ff "mutable "; + fmt_ty ff t + | TY_fn tfn -> fmt_ty_fn ff None tfn | TY_task -> fmt ff "task" | TY_tag ttag -> fmt_tag ff ttag @@ -964,7 +983,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = fmt_lval ff lv; fmt ff " "; fmt_binop ff binop; - fmt ff "="; + fmt ff "= "; fmt_atom ff at; fmt ff ";" @@ -999,11 +1018,9 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = do if i != 0 then fmt ff ", "; - let (ident, mode, mut, atom) = entries.(i) in + let (ident, atom) = entries.(i) in fmt_ident ff ident; fmt ff " = "; - fmt_mutable ff mut; - fmt_mode ff mode; fmt_atom ff atom; done; begin @@ -1015,7 +1032,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = end; fmt ff ");" - | STMT_init_vec (dst, _, atoms) -> + | STMT_init_vec (dst, atoms) -> fmt_lval ff dst; fmt ff " = vec("; for i = 0 to (Array.length atoms) - 1 @@ -1033,10 +1050,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = do if i != 0 then fmt ff ", "; - let (mode, mut, atom) = entries.(i) in - fmt_mutable ff mut; - fmt_mode ff mode; - fmt_atom ff atom; + fmt_atom ff entries.(i); done; fmt ff ");"; @@ -1153,6 +1167,12 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = fmt_lval ff t; fmt ff ";" + | STMT_init_exterior (lv, at) -> + fmt_lval ff lv; + fmt ff " = @"; + fmt_atom ff at; + fmt ff ";" + | STMT_alt_tag _ -> fmt ff "?stmt_alt_tag?" | STMT_alt_type _ -> fmt ff "?stmt_alt_type?" | STMT_alt_port _ -> fmt ff "?stmt_alt_port?" @@ -1321,7 +1341,6 @@ let sprintf_lval_component = sprintf_fmt fmt_lval_component;; let sprintf_atom = sprintf_fmt fmt_atom;; let sprintf_slot = sprintf_fmt fmt_slot;; let sprintf_slot_key = sprintf_fmt fmt_slot_key;; -let sprintf_mutable = sprintf_fmt fmt_mutable;; let sprintf_ty = sprintf_fmt fmt_ty;; let sprintf_effect = sprintf_fmt fmt_effect;; let sprintf_tag = sprintf_fmt fmt_tag;; diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml index 3efd4e2a061..5c0a7c65608 100644 --- a/src/boot/fe/item.ml +++ b/src/boot/fe/item.ml @@ -128,6 +128,13 @@ and parse_auto_slot_and_init and parse_stmts (ps:pstate) : Ast.stmt array = let apos = lexpos ps in + let ensure_mutable slot = + match slot.Ast.slot_ty with + None -> slot + | Some (Ast.TY_mutable _) -> slot + | Some t -> { slot with Ast.slot_ty = Some (Ast.TY_mutable t) } + in + let rec name_to_lval (apos:pos) (bpos:pos) (name:Ast.name) : Ast.lval = match name with @@ -236,7 +243,6 @@ and parse_stmts (ps:pstate) : Ast.stmt array = Ast.NAME_base (Ast.BASE_ident ident) -> let slot = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; Ast.slot_ty = None } in Ast.PAT_slot @@ -456,7 +462,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array = bump ps; let (stmts, slot, ident) = ctxt "stmt slot" parse_slot_and_ident_and_init ps in - let slot = Pexp.apply_mutability slot true in + let slot = ensure_mutable slot in let bpos = lexpos ps in let decl = Ast.DECL_slot (Ast.KEY_ident ident, (span ps apos bpos slot)) @@ -467,7 +473,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array = bump ps; let (stmts, slot, ident) = ctxt "stmt slot" parse_auto_slot_and_init ps in - let slot = Pexp.apply_mutability slot true in + let slot = ensure_mutable slot in let bpos = lexpos ps in let decl = Ast.DECL_slot (Ast.KEY_ident ident, (span ps apos bpos slot)) @@ -979,7 +985,9 @@ and expand_tags (ps, "unexpected name type while expanding tag")) in let header = - Array.map (fun slot -> (clone_span ps item slot)) tup + Array.map (fun ty -> (clone_span ps item + { Ast.slot_mode = Ast.MODE_alias; + Ast.slot_ty = Some ty})) tup in let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in let cloned_params = diff --git a/src/boot/fe/parser.ml b/src/boot/fe/parser.ml index 5df44303664..97cf898533b 100644 --- a/src/boot/fe/parser.ml +++ b/src/boot/fe/parser.ml @@ -181,13 +181,11 @@ let err (str:string) (ps:pstate) = let (slot_nil:Ast.slot) = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; Ast.slot_ty = Some Ast.TY_nil } ;; let (slot_auto:Ast.slot) = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = true; Ast.slot_ty = None } ;; diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml index e859d135e92..25352e5c752 100644 --- a/src/boot/fe/pexp.ml +++ b/src/boot/fe/pexp.ml @@ -22,7 +22,7 @@ type pexp' = | PEXP_bind of (pexp * pexp option array) | PEXP_rec of ((Ast.ident * pexp) array * pexp option) | PEXP_tup of (pexp array) - | PEXP_vec of (Ast.slot * (pexp array)) + | PEXP_vec of (pexp array) | PEXP_port | PEXP_chan of (pexp option) | PEXP_binop of (Ast.binop * pexp * pexp) @@ -261,11 +261,10 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | VEC -> bump ps; - Ast.TY_vec (bracketed LBRACKET RBRACKET (parse_slot false) ps) + Ast.TY_vec (bracketed LBRACKET RBRACKET parse_ty ps) | IDENT _ -> Ast.TY_named (parse_name ps) - | TAG -> bump ps; let htab = Hashtbl.create 4 in @@ -273,7 +272,7 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = let ident = parse_ident ps in let tup = match peek ps with - LPAREN -> paren_comma_list (parse_slot false) ps + LPAREN -> paren_comma_list parse_ty ps | _ -> raise (err "tag variant missing argument list" ps) in htab_put htab (Ast.NAME_base (Ast.BASE_ident ident)) tup @@ -287,9 +286,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | REC -> bump ps; let parse_rec_entry ps = - let mut = parse_mutability ps in - let (slot, ident) = parse_slot_and_ident false ps in - (ident, apply_mutability slot mut) + let (ty, ident) = parse_ty_and_ident ps in + (ident, ty) in let entries = paren_comma_list parse_rec_entry ps in let labels = Array.map (fun (l, _) -> l) entries in @@ -300,8 +298,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | TUP -> bump ps; - let slots = paren_comma_list (parse_slot false) ps in - Ast.TY_tup slots + let tys = paren_comma_list parse_ty ps in + Ast.TY_tup tys | MACH m -> bump ps; @@ -333,6 +331,14 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | _ -> raise (unexpected ps) end + | AT -> + bump ps; + Ast.TY_exterior (parse_ty ps) + + | MUTABLE -> + bump ps; + Ast.TY_mutable (parse_ty ps) + | LPAREN -> begin bump ps; @@ -356,21 +362,15 @@ and flag (ps:pstate) (tok:token) : bool = and parse_mutability (ps:pstate) : bool = flag ps MUTABLE -and apply_mutability (slot:Ast.slot) (mut:bool) : Ast.slot = - { slot with Ast.slot_mutable = mut } - and parse_slot (aliases_ok:bool) (ps:pstate) : Ast.slot = - let mut = parse_mutability ps in let mode = match (peek ps, aliases_ok) with - (AT, _) -> bump ps; Ast.MODE_exterior - | (AND, true) -> bump ps; Ast.MODE_alias + (AND, true) -> bump ps; Ast.MODE_alias | (AND, false) -> raise (err "alias slot in prohibited context" ps) | _ -> Ast.MODE_interior in let ty = parse_ty ps in { Ast.slot_mode = mode; - Ast.slot_mutable = mut; Ast.slot_ty = Some ty } and parse_slot_and_ident @@ -381,6 +381,13 @@ and parse_slot_and_ident let ident = ctxt "slot and ident: ident" parse_ident ps in (slot, ident) +and parse_ty_and_ident + (ps:pstate) + : (Ast.ty * Ast.ident) = + let ty = ctxt "ty and ident: ty" parse_ty ps in + let ident = ctxt "ty and ident: ident" parse_ident ps in + (ty, ident) + and parse_slot_and_optional_ignored_ident (aliases_ok:bool) (ps:pstate) @@ -494,16 +501,9 @@ and parse_bottom_pexp (ps:pstate) : pexp = | VEC -> bump ps; begin - let slot = - match peek ps with - LBRACKET -> bracketed LBRACKET RBRACKET (parse_slot false) ps - | _ -> { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; - Ast.slot_ty = None } - in let pexps = ctxt "vec pexp: exprs" parse_pexp_list ps in let bpos = lexpos ps in - span ps apos bpos (PEXP_vec (slot, pexps)) + span ps apos bpos (PEXP_vec pexps) end @@ -1088,7 +1088,9 @@ and desugar_expr_atom | PEXP_call _ | PEXP_bind _ | PEXP_spawn _ - | PEXP_custom _ -> + | PEXP_custom _ + | PEXP_exterior _ + | PEXP_mutable _ -> let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in let stmts = desugar_expr_init ps tmp pexp in (Array.append [| decl_stmt |] stmts, @@ -1101,31 +1103,6 @@ and desugar_expr_atom let (stmts, lval) = desugar_lval ps pexp in (stmts, Ast.ATOM_lval lval) - | PEXP_exterior _ -> - raise (err "exterior symbol in atom context" ps) - - | PEXP_mutable _ -> - raise (err "mutable keyword in atom context" ps) - - -and desugar_expr_mode_mut_atom - (ps:pstate) - (pexp:pexp) - : (Ast.stmt array * (Ast.mode * bool * Ast.atom)) = - let desugar_inner mode mut e = - let (stmts, atom) = desugar_expr_atom ps e in - (stmts, (mode, mut, atom)) - in - match pexp.node with - PEXP_mutable {node=(PEXP_exterior e); id=_} -> - desugar_inner Ast.MODE_exterior true e - | PEXP_exterior e -> - desugar_inner Ast.MODE_exterior false e - | PEXP_mutable e -> - desugar_inner Ast.MODE_interior true e - | _ -> - desugar_inner Ast.MODE_interior false pexp - and desugar_expr_atoms (ps:pstate) (pexps:pexp array) @@ -1138,12 +1115,6 @@ and desugar_opt_expr_atoms : (Ast.stmt array * Ast.atom option array) = arj1st (Array.map (desugar_opt_expr_atom ps) pexps) -and desugar_expr_mode_mut_atoms - (ps:pstate) - (pexps:pexp array) - : (Ast.stmt array * (Ast.mode * bool * Ast.atom) array) = - arj1st (Array.map (desugar_expr_mode_mut_atom ps) pexps) - and desugar_expr_init (ps:pstate) (dst_lval:Ast.lval) @@ -1253,10 +1224,10 @@ and desugar_expr_init Array.map begin fun (ident, pexp) -> - let (stmts, (mode, mut, atom)) = - desugar_expr_mode_mut_atom ps pexp + let (stmts, atom) = + desugar_expr_atom ps pexp in - (stmts, (ident, mode, mut, atom)) + (stmts, (ident, atom)) end args end @@ -1278,19 +1249,19 @@ and desugar_expr_init end | PEXP_tup args -> - let (arg_stmts, arg_mode_atoms) = - desugar_expr_mode_mut_atoms ps args + let (arg_stmts, arg_atoms) = + desugar_expr_atoms ps args in - let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_mode_atoms)) in + let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_atoms)) in aa arg_stmts [| stmt |] | PEXP_str s -> let stmt = ss (Ast.STMT_init_str (dst_lval, s)) in [| stmt |] - | PEXP_vec (slot, args) -> + | PEXP_vec args -> let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in - let stmt = ss (Ast.STMT_init_vec (dst_lval, slot, arg_atoms)) in + let stmt = ss (Ast.STMT_init_vec (dst_lval, arg_atoms)) in aa arg_stmts [| stmt |] | PEXP_port -> @@ -1315,11 +1286,19 @@ and desugar_expr_init in aa port_stmts [| chan_stmt |] - | PEXP_exterior _ -> - raise (err "exterior symbol in initialiser context" ps) + | PEXP_exterior arg -> + let (arg_stmts, arg_mode_atom) = + desugar_expr_atom ps arg + in + let stmt = ss (Ast.STMT_init_exterior (dst_lval, arg_mode_atom)) in + aa arg_stmts [| stmt |] - | PEXP_mutable _ -> - raise (err "mutable keyword in initialiser context" ps) + | PEXP_mutable arg -> + (* Initializing a local from a "mutable" atom is the same as + * initializing it from an immutable one; all locals are mutable + * anyways. So this is just a fall-through. + *) + desugar_expr_init ps dst_lval arg | PEXP_custom (n, a, b) -> let (arg_stmts, args) = desugar_expr_atoms ps a in diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml index 25d4ed04497..b603e77919e 100644 --- a/src/boot/me/alias.ml +++ b/src/boot/me/alias.ml @@ -67,7 +67,7 @@ let alias_analysis_visitor | Ast.STMT_recv (dst, _) -> alias dst | Ast.STMT_init_port (dst) -> alias dst | Ast.STMT_init_chan (dst, _) -> alias dst - | Ast.STMT_init_vec (dst, _, _) -> alias dst + | Ast.STMT_init_vec (dst, _) -> alias dst | Ast.STMT_init_str (dst, _) -> alias dst | Ast.STMT_for_each sfe -> let (slot, _) = sfe.Ast.for_each_slot in diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml index b7fdf309e5e..410ff402ca3 100644 --- a/src/boot/me/dwarf.ml +++ b/src/boot/me/dwarf.ml @@ -1305,58 +1305,67 @@ let (abbrev_base_type:abbrev) = let (abbrev_alias_slot:abbrev) = (DW_TAG_reference_type, DW_CHILDREN_no, + [| + (DW_AT_type, DW_FORM_ref_addr); + |]) +;; + +(* FIXME: Perverse, but given dwarf's vocabulary it seems at least plausible + * that a "mutable const type" is a correct way of saying "mutable". Or else we + * make up our own. Revisit perhaps. + *) +let (abbrev_mutable_type:abbrev) = + (DW_TAG_const_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, +let (abbrev_exterior_type:abbrev) = + (DW_TAG_pointer_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) - |]) + (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) - |]) + (DW_TAG_member, DW_CHILDREN_no, + [| + (DW_AT_name, DW_FORM_string); + (DW_AT_type, DW_FORM_ref_addr); + (DW_AT_data_member_location, DW_FORM_block4); + (DW_AT_byte_size, DW_FORM_block4) + |]) ;; let (abbrev_variant_part:abbrev) = - (DW_TAG_variant_part, DW_CHILDREN_yes, - [| - (DW_AT_discr, DW_FORM_ref_addr) - |]) + (DW_TAG_variant_part, DW_CHILDREN_yes, + [| + (DW_AT_discr, DW_FORM_ref_addr) + |]) ;; let (abbrev_variant:abbrev) = - (DW_TAG_variant, DW_CHILDREN_yes, - [| - (DW_AT_discr_value, DW_FORM_udata) - |]) + (DW_TAG_variant, DW_CHILDREN_yes, + [| + (DW_AT_discr_value, DW_FORM_udata) + |]) ;; let (abbrev_subroutine_type:abbrev) = - (DW_TAG_subroutine_type, DW_CHILDREN_yes, - [| - (DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *) + (DW_TAG_subroutine_type, DW_CHILDREN_yes, + [| + (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); @@ -1541,33 +1550,8 @@ let dwarf_visitor 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 (issue #72): encode mutable-ness of interiors. *) - | Ast.MODE_interior -> ref_type_die (slot_ty slot) + | Ast.MODE_interior -> + ref_type_die (slot_ty slot) | Ast.MODE_alias -> let fix = new_fixup "alias DIE" in @@ -1575,8 +1559,6 @@ let dwarf_visitor 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 @@ -1708,15 +1690,13 @@ let dwarf_visitor emit_die die; Array.iteri begin - fun i (ident, slot) -> + fun i (ident, ty) -> 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); + (ref_type_die ty); (* DW_AT_data_member_location: DW_FORM_block4 *) size_block4 (Il.get_element_offset word_bits rtys i) @@ -1904,10 +1884,6 @@ let dwarf_visitor 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 @@ -1974,9 +1950,7 @@ let dwarf_visitor (* DW_AT_name: DW_FORM_string *) ZSTRING "tag"; (* DW_AT_type: DW_FORM_ref_addr *) - (ref_slot_die (interior_slot Ast.TY_uint)); - (* DW_AT_mutable: DW_FORM_flag *) - BYTE 0; + (ref_type_die Ast.TY_uint); (* DW_AT_data_member_location: DW_FORM_block4 *) size_block4 (Il.get_element_offset word_bits rtys 0) @@ -2038,6 +2012,41 @@ let dwarf_visitor ref_addr_for_fix (Stack.top iso_stack).(i) in + let exterior_type t = + 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_type); + (* DW_AT_type: DW_FORM_ref_addr *) + (ref_type_die t); + (* 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 + in + + let mutable_type t = + let fix = new_fixup "mutable DIE" in + emit_die (DEF (fix, SEQ [| + uleb (get_abbrev_code abbrev_mutable_type); + (* DW_AT_type: DW_FORM_ref_addr *) + (ref_type_die t); + (* DW_AT_mutable: DW_FORM_flag *) + BYTE 1; + |])); + 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) @@ -2058,7 +2067,7 @@ let dwarf_visitor | Ast.TY_tag ttag -> tag_type None ttag | Ast.TY_iso tiso -> iso_type tiso | Ast.TY_idx i -> idx_type i - | Ast.TY_vec s -> unspecified_ptr_with_ref_slot DW_RUST_vec s + | Ast.TY_vec t -> unspecified_ptr_with_ref_ty DW_RUST_vec t | 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 @@ -2067,6 +2076,8 @@ let dwarf_visitor | Ast.TY_native i -> native_ptr_type i | Ast.TY_param p -> rust_type_param p | Ast.TY_obj ob -> obj_type ob + | Ast.TY_mutable t -> mutable_type t + | Ast.TY_exterior t -> exterior_type t | _ -> bug () "unimplemented dwarf encoding for type %a" Ast.sprintf_ty ty @@ -2893,7 +2904,7 @@ let rec extract_mod_items | DW_TAG_pointer_type when is_rust_type die DW_RUST_vec -> - Ast.TY_vec (get_referenced_slot die) + Ast.TY_vec (get_referenced_ty die) | DW_TAG_pointer_type when is_rust_type die DW_RUST_type_param -> @@ -2903,6 +2914,13 @@ let rec extract_mod_items when is_rust_type die DW_RUST_native -> Ast.TY_native (get_opaque_of (get_native_id die)) + | DW_TAG_pointer_type -> + Ast.TY_exterior (get_referenced_ty die) + + | DW_TAG_const_type + when ((get_num die DW_AT_mutable) = 1) -> + Ast.TY_mutable (get_referenced_ty die) + | DW_TAG_string_type -> Ast.TY_str | DW_TAG_base_type -> @@ -2953,13 +2971,13 @@ let rec extract_mod_items 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 + let tys = Array.map get_referenced_ty members in + Ast.TY_tup tys else let entries = Array.map (fun member_die -> ((get_name member_die), - (get_referenced_slot member_die))) + (get_referenced_ty member_die))) members in Ast.TY_rec entries @@ -2989,23 +3007,11 @@ let rec extract_mod_items 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_mode = Ast.MODE_alias; Ast.slot_ty = Some ty } | _ -> let ty = get_ty die in - (* FIXME (issue #28): 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 = diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml index ad9a4cb362d..22edce7c7eb 100644 --- a/src/boot/me/effect.ml +++ b/src/boot/me/effect.ml @@ -33,12 +33,18 @@ let mutability_checking_visitor | _ -> () 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)) + let check_write s dst = + let dst_ty = lval_ty cx dst in + let is_mutable = + match dst_ty with + Ast.TY_mutable _ -> true + | _ -> false + in + if (is_mutable or (Hashtbl.mem cx.ctxt_copy_stmt_is_init s.id)) then () - else err (Some id) "writing to non-mutable slot" + else err (Some s.id) + "writing to non-mutable slot of type %a in statement %a" + Ast.sprintf_ty dst_ty Ast.sprintf_stmt s in (* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot * rule. @@ -46,10 +52,10 @@ let mutability_checking_visitor 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 + Ast.STMT_copy (dst, _) -> check_write s dst + | Ast.STMT_copy_binop (dst, _, _) -> check_write s dst + | Ast.STMT_call (dst, _, _) -> check_write s dst + | Ast.STMT_recv (dst, _) -> check_write s dst | _ -> () end; inner.Walk.visit_stmt_pre s @@ -151,8 +157,7 @@ let function_effect_propagation_visitor in if lval_is_slot cx fn then - let t = lval_slot cx fn in - lower_to_callee_ty (slot_ty t) + lower_to_callee_ty (lval_ty cx fn) else begin let item = lval_item cx fn in diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index 5160429ef50..746f83bf6b6 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -582,15 +582,13 @@ let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array = ;; let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array = - Array.concat (List.map - (fun (_,_,a) -> atom_slots cx a) - (Array.to_list az)) + Array.concat (List.map (atom_slots cx) (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) + (fun (_, atom) -> atom_slots cx atom) (Array.to_list inputs)) ;; @@ -606,14 +604,27 @@ let expr_slots (cx:ctxt) (e:Ast.expr) : node_id array = (* 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 ty = + if mut + then Ast.TY_mutable ty + else ty + in + { Ast.slot_mode = Ast.MODE_interior; + Ast.slot_ty = Some ty } ;; let exterior_slot_full mut ty : Ast.slot = - { Ast.slot_mode = Ast.MODE_exterior; - Ast.slot_mutable = mut; + let ty = + match ty with + Ast.TY_exterior _ -> ty + | _ -> Ast.TY_exterior ty + in + let ty = + if mut + then Ast.TY_mutable ty + else ty + in + { Ast.slot_mode = Ast.MODE_interior; Ast.slot_ty = Some ty } ;; @@ -626,12 +637,13 @@ let exterior_slot ty : Ast.slot = exterior_slot_full false ty (* General folds of Ast.ty. *) -type ('ty, 'slot, 'slots, 'tag) ty_fold = +type ('ty, 'tys, 'slot, 'slots, 'tag) ty_fold = { (* Functions that correspond to interior nodes in Ast.ty. *) - ty_fold_slot : (Ast.mode * bool * 'ty) -> 'slot; + ty_fold_slot : (Ast.mode * 'ty) -> 'slot; ty_fold_slots : ('slot array) -> 'slots; - ty_fold_tags : (Ast.name, 'slots) Hashtbl.t -> 'tag; + ty_fold_tys : ('ty array) -> 'tys; + ty_fold_tags : (Ast.name, 'tys) Hashtbl.t -> 'tag; (* Functions that correspond to the Ast.ty constructors. *) ty_fold_any: unit -> 'ty; @@ -642,9 +654,9 @@ type ('ty, 'slot, 'slots, 'tag) ty_fold = 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_tup : 'tys -> 'ty; + ty_fold_vec : 'ty -> 'ty; + ty_fold_rec : (Ast.ident * 'ty) array -> 'ty; ty_fold_tag : 'tag -> 'ty; ty_fold_iso : (int * 'tag array) -> 'ty; ty_fold_idx : int -> 'ty; @@ -659,21 +671,29 @@ type ('ty, 'slot, 'slots, 'tag) ty_fold = ty_fold_param : (int * Ast.effect) -> 'ty; ty_fold_named : Ast.name -> 'ty; ty_fold_type : unit -> 'ty; + ty_fold_exterior : 'ty -> 'ty; + ty_fold_mutable : 'ty -> 'ty; ty_fold_constrained : ('ty * Ast.constrs) -> 'ty } ;; -let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty = +let rec fold_ty (f:('ty, 'tys, '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))) + + let fold_tys (tys:Ast.ty array) : 'tys = + f.ty_fold_tys (Array.map (fold_ty f) tys) in + + let fold_tags (ttag:Ast.ty_tag) : 'tag = + f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_tys v))) + in + let fold_sig tsig = (fold_slots tsig.Ast.sig_input_slots, tsig.Ast.sig_input_constrs, @@ -692,13 +712,15 @@ let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty = | 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_tup t -> f.ty_fold_tup (fold_tys t) + | Ast.TY_vec t -> f.ty_fold_vec (fold_ty f t) + | Ast.TY_rec r -> + f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_ty f 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_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) @@ -713,16 +735,20 @@ let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty = | Ast.TY_named n -> f.ty_fold_named n | Ast.TY_type -> f.ty_fold_type () + | Ast.TY_exterior t -> f.ty_fold_exterior (fold_ty f t) + | Ast.TY_mutable t -> f.ty_fold_mutable (fold_ty f t) + | 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 +type 'a simple_ty_fold = ('a, 'a, 'a, 'a, 'a) ty_fold ;; let ty_fold_default (default:'a) : 'a simple_ty_fold = - { ty_fold_slot = (fun _ -> default); + { ty_fold_tys = (fun _ -> default); + ty_fold_slot = (fun _ -> default); ty_fold_slots = (fun _ -> default); ty_fold_tags = (fun _ -> default); ty_fold_any = (fun _ -> default); @@ -748,19 +774,22 @@ let ty_fold_default (default:'a) : 'a simple_ty_fold = ty_fold_param = (fun _ -> default); ty_fold_named = (fun _ -> default); ty_fold_type = (fun _ -> default); + ty_fold_exterior = (fun _ -> default); + ty_fold_mutable = (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 = + : (Ast.ty, Ast.ty array, 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) -> + { + ty_fold_tys = (fun ts -> ts); + ty_fold_slot = (fun (mode, 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); @@ -773,7 +802,7 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty) 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_vec = (fun t -> id (Ast.TY_vec t)); 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; @@ -791,6 +820,8 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty) 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_exterior = (fun t -> id (Ast.TY_exterior t)); + ty_fold_mutable = (fun t -> id (Ast.TY_mutable t)); ty_fold_constrained = (fun (t, constrs) -> id (Ast.TY_constrained (t, constrs))) } ;; @@ -892,7 +923,7 @@ let associative_binary_op_ty_fold in { base with ty_fold_slots = (fun slots -> reduce (Array.to_list slots)); - ty_fold_slot = (fun (_, _, a) -> a); + 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); @@ -957,13 +988,9 @@ let lower_effect_of x 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_mutable _ = Ast.STATE in let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in - let fold = { fold with ty_fold_slot = fold_slot } in + let fold = { fold with ty_fold_mutable = fold_mutable } in fold_ty fold t ;; @@ -1037,15 +1064,15 @@ let check_concrete params thing = ;; -let project_type_to_slot +let project_type (base_ty:Ast.ty) (comp:Ast.lval_component) - : Ast.slot = + : Ast.ty = 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 + Some ty -> ty | None -> err None "unknown record-member '%s'" id end @@ -1054,14 +1081,10 @@ let project_type_to_slot 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_vec ty, Ast.COMP_atom _) -> ty + | (Ast.TY_str, Ast.COMP_atom _) -> (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)) + (Ast.TY_fn (Hashtbl.find fns id)) | (_,_) -> bug () @@ -1070,16 +1093,6 @@ let project_type_to_slot 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)) @@ -1150,6 +1163,10 @@ let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool = | _ -> false ;; +let lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty = + Hashtbl.find cx.ctxt_all_lval_types (lval_base_id lval) +;; + let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool = defn_is_static (resolve_lval cx lval) ;; @@ -1164,7 +1181,7 @@ let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool = match lval with Ast.LVAL_ext (base, _) -> begin - match slot_ty (lval_slot cx base) with + match lval_ty cx base with Ast.TY_obj _ -> true | _ -> false end @@ -1172,11 +1189,6 @@ let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool = 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 @@ -1741,7 +1753,7 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty = 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 tup ttup = Il.StructTy (Array.map (referent_type abi) ttup) in let tag ttag = let union = Il.UnionTy @@ -1802,6 +1814,11 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty = | Ast.TY_native _ -> ptr + | Ast.TY_exterior t -> + sp (Il.StructTy [| word; referent_type abi t |]) + + | Ast.TY_mutable t -> referent_type abi t + | Ast.TY_param (i, _) -> Il.ParamTy i | Ast.TY_named _ -> bug () "named type in referent_type" @@ -1809,16 +1826,11 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty = 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 ;; @@ -1940,14 +1952,17 @@ let word_slot (abi:Abi.abi) : Ast.slot = let alias_slot (ty:Ast.ty) : Ast.slot = { Ast.slot_mode = Ast.MODE_alias; - Ast.slot_mutable = false; Ast.slot_ty = Some ty } ;; let mutable_alias_slot (ty:Ast.ty) : Ast.slot = - { Ast.slot_mode = Ast.MODE_alias; - Ast.slot_mutable = true; - Ast.slot_ty = Some ty } + let ty = + match ty with + Ast.TY_mutable _ -> ty + | _ -> Ast.TY_mutable ty + in + { Ast.slot_mode = Ast.MODE_alias; + Ast.slot_ty = Some ty } ;; let mk_ty_fn_or_iter @@ -2002,12 +2017,10 @@ let item_str (cx:ctxt) (id:node_id) : string = 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 -> "") + let fold_slot (mode,ty) = + (match mode with + Ast.MODE_alias -> "a" + | Ast.MODE_interior -> "") ^ ty in let num n = (string_of_int n) ^ "$" in @@ -2080,6 +2093,8 @@ let ty_str (ty:Ast.ty) : string = ty_fold_native = (fun _ -> "N"); ty_fold_param = (fun _ -> "P"); ty_fold_type = (fun _ -> "Y"); + ty_fold_mutable = (fun t -> "m" ^ t); + ty_fold_exterior = (fun t -> "e" ^ t); (* FIXME (issue #78): encode obj types. *) (* FIXME (issue #78): encode opaque and param numbers. *) diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml index 8ecc743e56c..5a15eadadca 100644 --- a/src/boot/me/trans.ml +++ b/src/boot/me/trans.ml @@ -55,13 +55,14 @@ let trans_visitor 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 (word_ty:Ast.ty) = Ast.TY_mach abi.Abi.abi_word_ty 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_sty:Il.scalar_ty) = Il.ValTy word_bits in + let (word_rty:Il.referent_ty) = Il.ScalarTy word_sty in let (word_ty_mach:ty_mach) = match word_bits with Il.Bits8 -> TY_u8 @@ -88,7 +89,7 @@ let trans_visitor 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 wordptr_ty = Il.AddrTy (Il.ScalarTy word_ty) in + let wordptr_ty = Il.AddrTy (Il.ScalarTy word_sty) in let crate_rel fix = Asm.SUB (Asm.M_POS fix, Asm.M_POS cx.ctxt_crate_fixup) @@ -431,8 +432,8 @@ let trans_visitor in - let make_tydesc_slots n = - Array.init n (fun _ -> interior_slot Ast.TY_type) + let make_tydesc_tys n = + Array.init n (fun _ -> Ast.TY_type) in let cell_vreg_num (vr:(int option) ref) : int = @@ -521,7 +522,7 @@ let trans_visitor 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_ty = Ast.TY_tup (make_tydesc_tys 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 @@ -595,28 +596,28 @@ let trans_visitor | SIZE_rt_neg a -> let op_a = sub_sz a in - let tmp = next_vreg_cell word_ty in + let tmp = next_vreg_cell word_sty 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 + let tmp = next_vreg_cell word_sty 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 + let tmp = next_vreg_cell word_sty 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 + let tmp = next_vreg_cell word_sty in mov tmp op_a; emit (Il.cmp op_a op_b); let jmp = mark () in @@ -643,8 +644,8 @@ let trans_visitor 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 + let mask = next_vreg_cell word_sty in + let off = next_vreg_cell word_sty in mov mask op_align; sub_from mask one; mov off op_off; @@ -678,8 +679,8 @@ let trans_visitor | 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))); + let c = (Il.Reg (v, word_sty)) in + mov c (Il.Cell (Il.Reg (reg, word_sty))); add_to c runtime_size; based v @@ -690,17 +691,17 @@ let trans_visitor 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 ty_sz_in_current_frame (ty:Ast.ty) : Il.operand = + let rty = referent_type abi ty in let sz = Il.referent_ty_size word_bits rty in calculate_sz_in_current_frame sz in - let slot_sz_with_ty_params + let ty_sz_with_ty_params (ty_params:Il.cell) - (slot:Ast.slot) + (ty:Ast.ty) : Il.operand = - let rty = slot_referent_type abi slot in + let rty = referent_type abi ty in let sz = Il.referent_ty_size word_bits rty in calculate_sz ty_params sz in @@ -722,8 +723,8 @@ let trans_visitor 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 + let v = next_vreg word_sty in + let vc = Il.Reg (v, word_sty) in lea vc mem; add_to vc sz; Il.Mem (based v, elt_rty) @@ -739,12 +740,6 @@ let trans_visitor 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) @@ -890,15 +885,15 @@ let trans_visitor (base_ty:Ast.ty) (cell:Il.cell) (comp:Ast.lval_component) - : (Il.cell * Ast.slot) = + : (Il.cell * Ast.ty) = - let bounds_checked_access at slot = + let bounds_checked_access at ty = let atop = trans_atom at in - let unit_sz = slot_sz_in_current_frame slot in - let idx = next_vreg_cell word_ty in + let unit_sz = ty_sz_in_current_frame ty in + let idx = next_vreg_cell word_sty 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) + (Il.Mem (elt_mem, referent_type abi ty), ty) in match (base_ty, comp) with @@ -911,18 +906,18 @@ let trans_visitor Ast.COMP_named (Ast.COMP_idx i)) -> (get_element_ptr_dyn_in_current_frame cell i, entries.(i)) - | (Ast.TY_vec slot, + | (Ast.TY_vec ty, Ast.COMP_atom at) -> - bounds_checked_access at slot + bounds_checked_access at ty | (Ast.TY_str, Ast.COMP_atom at) -> - bounds_checked_access at (interior_slot (Ast.TY_mach TY_u8)) + bounds_checked_access at (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))) + (cell, (Ast.TY_fn fn_ty)) | _ -> bug () "unhandled form of lval_ext in trans_slot_lval_ext" @@ -938,7 +933,7 @@ let trans_visitor 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 + let (diff:Il.cell) = next_vreg_cell word_sty in annotate "bounds check"; lea base (fst (need_mem_cell data)); add elt (Il.Cell base) mul_idx; @@ -950,23 +945,27 @@ let trans_visitor and trans_lval_full (initializing:bool) (lv:Ast.lval) - : (Il.cell * Ast.slot) = + : (Il.cell * Ast.ty) = let rec trans_slot_lval_full (initializing:bool) lv = - let (cell, slot) = + let (cell, ty) = match lv with Ast.LVAL_ext (base, comp) -> - let (base_cell, base_slot) = + let (base_cell, base_ty) = 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 + let (base_cell, base_ty) = + deref_ty initializing base_cell base_ty + in + trans_slot_lval_ext base_ty 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) + let ty = slot_ty slot in + let cell = deref_slot initializing cell slot in + deref_ty initializing cell ty in iflog begin @@ -976,7 +975,7 @@ let trans_visitor Ast.sprintf_lval lv (cell_str cell)) end; - (cell, slot) + (cell, ty) in if lval_is_slot cx lv @@ -994,13 +993,13 @@ let trans_visitor and trans_lval_maybe_init (initializing:bool) (lv:Ast.lval) - : (Il.cell * Ast.slot) = + : (Il.cell * Ast.ty) = trans_lval_full initializing lv - and trans_lval_init (lv:Ast.lval) : (Il.cell * Ast.slot) = + and trans_lval_init (lv:Ast.lval) : (Il.cell * Ast.ty) = trans_lval_maybe_init true lv - and trans_lval (lv:Ast.lval) : (Il.cell * Ast.slot) = + and trans_lval (lv:Ast.lval) : (Il.cell * Ast.ty) = trans_lval_maybe_init false lv and trans_callee @@ -1231,8 +1230,8 @@ let trans_visitor match atom with Ast.ATOM_lval lv -> - let (cell, slot) = trans_lval lv in - Il.Cell (deref_slot false cell slot) + let (cell, ty) = trans_lval lv in + Il.Cell (fst (deref_ty false cell ty)) | Ast.ATOM_literal lit -> trans_lit lit.node @@ -1302,7 +1301,7 @@ let trans_visitor and check_interrupt_flag _ = let dom = next_vreg_cell wordptr_ty in - let flag = next_vreg_cell word_ty in + let flag = next_vreg_cell word_sty 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))); @@ -1393,7 +1392,7 @@ let trans_visitor (bs:Ast.slot array) (* FIXME (issue #5): mutability flag *) : Il.referent_ty = - let rc = Il.ScalarTy word_ty in + let rc = Il.ScalarTy word_sty 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 |] @@ -1557,7 +1556,7 @@ let trans_visitor 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 + let params = make_tydesc_tys n_ty_params in alias_slot (Ast.TY_tup params) and get_drop_glue @@ -1570,7 +1569,7 @@ let trans_visitor 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; + drop_ty ty_params (deref cell) ty curr_iso; note_drop_step ty "drop-glue complete"; in let ty_params_ptr = ty_params_covering ty in @@ -1621,7 +1620,7 @@ let trans_visitor let inner _ (args:Il.cell) = let ty_params = deref (get_element_ptr args 0) in let cell = get_element_ptr args 1 in - sever_ty ty_params ty (deref cell) curr_iso + sever_ty ty_params (deref cell) ty curr_iso in let ty_params_ptr = ty_params_covering ty in let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in @@ -1636,7 +1635,7 @@ let trans_visitor 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 + mark_ty ty_params (deref cell) ty curr_iso in let ty_params_ptr = ty_params_covering ty in let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in @@ -1653,7 +1652,7 @@ let trans_visitor 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 + clone_ty ty_params clone_task dst src ty curr_iso in let ty_params_ptr = ty_params_covering ty in let fty = @@ -1677,7 +1676,7 @@ let trans_visitor 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 + copy_ty ty_params dst src ty curr_iso in let ty_params_ptr = ty_params_covering ty in let fty = @@ -2096,8 +2095,8 @@ let trans_visitor 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 + let (dstcell, dst_ty) = trans_lval_init dst in + let unit_ty = match dst_ty with Ast.TY_port t -> t | _ -> bug () "init dst of port-init has non-port type" in @@ -2134,19 +2133,18 @@ let trans_visitor *) and trans_init_vec (dst:Ast.lval) (atoms:Ast.atom array) : unit = - let (dst_cell, dst_slot) = trans_lval_init dst in - let dst_ty = slot_ty dst_slot in + let (dst_cell, dst_ty) = trans_lval_init dst in let gc_ctrl = - if (slot_mem_ctrl dst_slot) = MEM_gc - then Il.Cell (get_tydesc None (slot_ty dst_slot)) + if (ty_mem_ctrl dst_ty) = MEM_gc + then Il.Cell (get_tydesc None dst_ty) else zero in - let unit_slot = match dst_ty with - Ast.TY_vec s -> s + let unit_ty = match dst_ty with + Ast.TY_vec t -> t | _ -> 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 + let fill = next_vreg_cell word_sty in + let unit_sz = ty_sz_in_current_frame unit_ty in umul fill unit_sz (imm (Int64.of_int (Array.length atoms))); trans_upcall "upcall_new_vec" dst_cell [| Il.Cell fill; gc_ctrl |]; let vec = deref dst_cell in @@ -2155,14 +2153,14 @@ let trans_visitor (get_element_ptr_dyn_in_current_frame vec Abi.vec_elt_data)) in - let unit_rty = slot_referent_type abi unit_slot in + let unit_rty = referent_type abi unit_ty 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 + trans_init_ty_from_atom cell unit_ty atom end atoms; mov (get_element_ptr vec Abi.vec_elt_fill) (Il.Cell fill); @@ -2221,36 +2219,35 @@ let trans_visitor exterior_ctrl_cell cell Abi.exterior_rc_slot_field_refcnt and exterior_allocation_size - (slot:Ast.slot) + (ty:Ast.ty) : Il.operand = let header_sz = - match slot_mem_ctrl slot with + match ty_mem_ctrl ty with MEM_gc | 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) + Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi ty) in match refty_sz with - SIZE_fixed _ -> imm (Int64.add (ty_sz abi t) header_sz) + SIZE_fixed _ -> imm (Int64.add (ty_sz abi ty) 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 + let v = next_vreg word_sty in + let vc = Il.Reg (v, word_sty) in mov vc refty_sz; add_to vc (imm header_sz); Il.Cell vc; - and iter_tag_slots + and iter_tag_parts (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) + (f:Il.cell -> Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit) (curr_iso:Ast.ty_iso option) : unit = let tag_keys = sorted_htab_keys ttag in @@ -2258,8 +2255,8 @@ let trans_visitor 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; + let tmp = next_vreg_cell word_sty in + f dst_tag src_tag word_ty curr_iso; mov tmp (Il.Cell src_tag); Array.iteri begin @@ -2271,7 +2268,7 @@ let trans_visitor trans_compare Il.JNE (Il.Cell tmp) (imm (Int64.of_int i)) in let ttup = Hashtbl.find ttag key in - iter_tup_slots + iter_tup_parts (get_element_ptr_dyn ty_params) (get_variant_ptr dst_union i) (get_variant_ptr src_union i) @@ -2284,24 +2281,24 @@ let trans_visitor tiso.Ast.iso_group.(tiso.Ast.iso_index) - and seq_unit_slot (seq:Ast.ty) : Ast.slot = + and seq_unit_ty (seq:Ast.ty) : Ast.ty = 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" + Ast.TY_vec t -> t + | Ast.TY_str -> Ast.TY_mach TY_u8 + | _ -> bug () "seq_unit_ty of non-vec, non-str type" - and iter_seq_slots + and iter_seq_parts (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) + (unit_ty:Ast.ty) + (f:Il.cell -> Il.cell -> Ast.ty -> (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 + let unit_sz = ty_sz_with_ty_params ty_params unit_ty in (* - * Unlike most of the iter_ty_slots helpers; this one allocates a + * Unlike most of the iter_ty_parts 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. *) @@ -2323,9 +2320,9 @@ let trans_visitor 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)) + deref (ptr_cast ptr (referent_type abi unit_ty)) in - f unit_cell unit_cell unit_slot curr_iso; + f unit_cell unit_cell unit_ty curr_iso; add_to ptr unit_sz; check_interrupt_flag (); emit (Il.jmp Il.JMP (Il.CodeLabel back_jmp_target)); @@ -2337,12 +2334,12 @@ let trans_visitor end - and iter_ty_slots_full + and iter_ty_parts_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) + (ty:Ast.ty) + (f:Il.cell -> Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit) (curr_iso:Ast.ty_iso option) : unit = (* @@ -2352,84 +2349,74 @@ let trans_visitor *) match ty with Ast.TY_rec entries -> - iter_rec_slots + iter_rec_parts (get_element_ptr_dyn ty_params) dst_cell src_cell entries f curr_iso - | Ast.TY_tup slots -> - iter_tup_slots + | Ast.TY_tup tys -> + iter_tup_parts (get_element_ptr_dyn ty_params) dst_cell src_cell - slots f curr_iso + tys f curr_iso | Ast.TY_tag tag -> - iter_tag_slots ty_params dst_cell src_cell tag f curr_iso + iter_tag_parts 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) + iter_tag_parts 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 + let unit_ty = seq_unit_ty ty in + iter_seq_parts ty_params dst_cell src_cell unit_ty 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 + * This just calls iter_ty_parts_full with your cell as both src and + * dst, with an adaptor function that discards the dst parts of the * parallel traversal and and calls your provided function on the - * passed-in src slots. + * passed-in src parts. *) - and iter_ty_slots + and iter_ty_parts (ty_params:Il.cell) - (ty:Ast.ty) (cell:Il.cell) - (f:Il.cell -> Ast.slot -> (Ast.ty_iso option) -> unit) + (ty:Ast.ty) + (f:Il.cell -> Ast.ty -> (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) + iter_ty_parts_full ty_params cell cell ty + (fun _ src_cell ty curr_iso -> f src_cell ty curr_iso) curr_iso and drop_ty (ty_params:Il.cell) - (ty:Ast.ty) (cell:Il.cell) + (ty:Ast.ty) (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 ty = maybe_iso curr_iso ty in + let curr_iso = maybe_enter_iso ty curr_iso in + let mctrl = ty_mem_ctrl ty in + + match ty with + + Ast.TY_fn _ -> 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. + (* FIXME (issue #58): this is completely wrong, Closures need to + * carry tydescs like objs. For now this only works by accident, + * and will leak closures with exterior substructure. *) - drop_slot ty_params binding - (exterior_slot Ast.TY_int) curr_iso; + drop_ty ty_params binding (Ast.TY_exterior Ast.TY_int) curr_iso; patch null_jmp - end - | Ast.TY_obj _ -> - begin + | Ast.TY_obj _ -> let binding = get_element_ptr cell Abi.binding_field_binding in let null_jmp = null_check binding in let obj = deref binding in @@ -2445,55 +2432,109 @@ let trans_visitor 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 |]; - (* FIXME: this will fail if the user has lied about the - * state-ness of their obj. We need to store state-ness in the - * captured tydesc, and use that. *) - trans_free binding (type_has_state ty); - mov binding zero; - patch rc_jmp; - patch null_jmp - end + 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 |]; + (* FIXME: this will fail if the user has lied about the + * state-ness of their obj. We need to store state-ness in the + * captured tydesc, and use that. *) + trans_free binding (type_has_state ty); + mov binding zero; + patch rc_jmp; + patch null_jmp + | 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 + | _ -> - iter_ty_slots ty_params ty cell (drop_slot ty_params) curr_iso + match mctrl with + MEM_gc + | MEM_rc_opaque + | MEM_rc_struct -> + + let _ = check_exterior_rty cell in + let null_jmp = null_check cell in + let rc = exterior_rc_cell cell in + let j = drop_refcount_and_cmp rc in + + (* 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. *) + + if mctrl = MEM_rc_opaque + then + free_ty false ty_params ty cell curr_iso + else + trans_call_simple_static_glue + (get_free_glue ty (mctrl = MEM_gc) 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 " ^ + (Fmt.fmt_to_str Ast.fmt_ty ty)))); + 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 not caught above: + * nothing to do. + *) + () and sever_ty (ty_params:Il.cell) - (ty:Ast.ty) (cell:Il.cell) + (ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = - match ty with - | Ast.TY_fn _ - | Ast.TY_obj _ -> () - | _ -> - iter_ty_slots ty_params ty cell (sever_slot ty_params) curr_iso + let _ = note_gc_step ty "severing" in + match ty_mem_ctrl ty with + MEM_gc -> - 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 + let _ = check_exterior_rty cell in + let null_jmp = null_check cell in + let rc = exterior_rc_cell cell in + let _ = note_gc_step ty "severing GC slot" in + emit (Il.binary Il.SUB rc (Il.Cell rc) one); + mov cell zero; + patch null_jmp + + | MEM_interior when type_is_structured ty -> + iter_ty_parts ty_params cell ty + (sever_ty ty_params) curr_iso + + | _ -> () + (* No need to follow links / call glue; severing is shallow. *) and clone_ty (ty_params:Il.cell) (clone_task:Il.cell) - (ty:Ast.ty) (dst:Il.cell) (src:Il.cell) + (ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = match ty with @@ -2508,15 +2549,21 @@ let trans_visitor -> mov dst (Il.Cell src) | Ast.TY_fn _ | Ast.TY_obj _ -> () + | Ast.TY_exterior ty -> + let glue_fix = get_clone_glue ty curr_iso in + trans_call_static_glue + (code_fixup_to_ptr_operand glue_fix) + (Some dst) + [| alias ty_params; src; clone_task |] | _ -> - iter_ty_slots_full ty_params ty dst src - (clone_slot ty_params clone_task) curr_iso + iter_ty_parts_full ty_params dst src ty + (clone_ty ty_params clone_task) curr_iso and copy_ty (ty_params:Il.cell) - (ty:Ast.ty) (dst:Il.cell) (src:Il.cell) + (ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = iflog (fun _ -> @@ -2565,18 +2612,18 @@ let trans_visitor * 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) + trans_copy_ty ty_params true + dst_binding (Ast.TY_exterior Ast.TY_int) + src_binding (Ast.TY_exterior 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) + iter_ty_parts_full ty_params dst src ty + (fun dst src ty curr_iso -> + trans_copy_ty ty_params true + dst ty src ty curr_iso) curr_iso and free_ty @@ -2591,8 +2638,8 @@ let trans_visitor | 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; + iter_seq_parts ty_params cell cell s + (fun _ src ty iso -> drop_ty ty_params src ty iso) curr_iso; trans_free cell is_gc | _ -> trans_free cell is_gc @@ -2603,7 +2650,7 @@ let trans_visitor : Ast.ty = match (curr_iso, t) with (Some iso, Ast.TY_idx n) -> - Ast.TY_iso { iso with Ast.iso_index = n } + Ast.TY_exterior (Ast.TY_iso { iso with Ast.iso_index = n }) | (None, Ast.TY_idx _) -> bug () "TY_idx outside TY_iso" | _ -> t @@ -2616,74 +2663,46 @@ let trans_visitor Ast.TY_iso tiso -> Some tiso | _ -> curr_iso - and sever_slot - (ty_params:Il.cell) - (cell:Il.cell) - (slot:Ast.slot) - (curr_iso:Ast.ty_iso option) - : unit = - let _ = note_gc_step slot "severing" in - let ty = slot_ty slot in - match slot_mem_ctrl slot with - MEM_gc -> - - 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 "severing GC slot" in - emit (Il.binary Il.SUB rc (Il.Cell rc) one); - mov cell zero; - patch null_jmp - - | MEM_interior when type_is_structured ty -> - 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_sever_glue ty curr_iso) - ty_params tmp - - | MEM_interior -> - (* Interior allocation of all-interior value: sever directly. *) - let ty = maybe_iso curr_iso ty in - sever_ty ty_params ty cell 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 -> - let tmp = next_vreg_cell Il.voidptr_t in + (* Marking goes straight through aliases. Reachable means reachable. *) + mark_ty ty_params (deref_slot false cell slot) (slot_ty slot) curr_iso + + and mark_ty + (ty_params:Il.cell) + (cell:Il.cell) + (ty:Ast.ty) + (curr_iso:Ast.ty_iso option) + : unit = + match ty_mem_ctrl ty with + MEM_gc -> + let tmp = next_vreg_cell Il.voidptr_t in trans_upcall "upcall_mark" tmp [| Il.Cell cell |]; - let marked_jump = - trans_compare Il.JE (Il.Cell tmp) zero; - in - (* Iterate over exterior slots marking outgoing links. *) - 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; - List.iter patch marked_jump; + let marked_jump = + trans_compare Il.JE (Il.Cell tmp) zero; + in + (* Iterate over exterior parts marking outgoing links. *) + 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; + List.iter patch marked_jump; | MEM_interior when type_is_structured ty -> (iflog (fun _ -> annotate ("mark interior slot " ^ - (Fmt.fmt_to_str Ast.fmt_slot slot)))); + (Fmt.fmt_to_str Ast.fmt_ty ty)))); let (mem, _) = need_mem_cell cell in let tmp = next_vreg_cell Il.voidptr_t in let ty = maybe_iso curr_iso ty in @@ -2704,30 +2723,6 @@ let trans_visitor "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) @@ -2755,54 +2750,11 @@ let trans_visitor (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 - | MEM_gc - | MEM_rc_struct -> - let _ = check_exterior_rty cell in - let null_jmp = null_check cell in - let rc = exterior_rc_cell cell in - let j = drop_refcount_and_cmp rc in - - (* 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. *) - - if mctrl = MEM_rc_opaque - then - free_ty false ty_params ty cell curr_iso - else - trans_call_simple_static_glue - (get_free_glue ty (mctrl = MEM_gc) 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 " ^ - (Fmt.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 + match slot.Ast.slot_mode with + Ast.MODE_alias + (* Aliases are always free to drop. *) + | Ast.MODE_interior -> + drop_ty ty_params cell (slot_ty slot) curr_iso and note_drop_step ty step = if cx.ctxt_sess.Session.sess_trace_drop || @@ -2815,44 +2767,70 @@ let trans_visitor trace_str cx.ctxt_sess.Session.sess_trace_drop str end - and note_gc_step slot step = + and note_gc_step ty 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 + match ty_mem_ctrl ty with MEM_gc -> "MEM_gc" | MEM_rc_struct -> "MEM_rc_struct" | MEM_rc_opaque -> "MEM_rc_opaque" | MEM_interior -> "MEM_interior" in - let slotstr = Fmt.fmt_to_str Ast.fmt_slot slot in - let str = step ^ " " ^ mctrl_str ^ " " ^ slotstr in + let tystr = Fmt.fmt_to_str Ast.fmt_ty ty in + let str = step ^ " " ^ mctrl_str ^ " " ^ tystr 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 = - let mctrl = slot_mem_ctrl slot in + and init_exterior (cell:Il.cell) (ty:Ast.ty) : unit = + let mctrl = ty_mem_ctrl ty in match mctrl with MEM_gc | MEM_rc_opaque | MEM_rc_struct -> let ctrl = if mctrl = MEM_gc - then Il.Cell (get_tydesc None (slot_ty slot)) + then Il.Cell (get_tydesc None ty) else zero in iflog (fun _ -> annotate "init exterior: malloc"); - let sz = exterior_allocation_size slot in + let sz = exterior_allocation_size ty in trans_malloc cell sz ctrl; iflog (fun _ -> annotate "init exterior: load refcount"); let rc = exterior_rc_cell cell in mov rc one - | MEM_interior -> bug () "init_exterior_slot of MEM_interior" + | MEM_interior -> bug () "init_exterior of MEM_interior" + + and deref_ty + (initializing:bool) + (cell:Il.cell) + (ty:Ast.ty) + : (Il.cell * Ast.ty) = + match ty with + + | Ast.TY_mutable ty + | Ast.TY_constrained (ty, _) -> + deref_ty initializing cell ty + + | Ast.TY_exterior ty -> + check_exterior_rty cell; + if initializing + then init_exterior cell ty; + let cell = + get_element_ptr_dyn_in_current_frame + (deref cell) + (Abi.exterior_rc_slot_field_body) + in + (* Init recursively so @@@@T chain works. *) + deref_ty initializing cell ty + + | _ -> (cell, ty) + and deref_slot (initializing:bool) @@ -2860,17 +2838,9 @@ let trans_visitor (slot:Ast.slot) : Il.cell = match slot.Ast.slot_mode with - Ast.MODE_interior _ -> + 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 @@ -2881,24 +2851,32 @@ let trans_visitor (initializing:bool) (dst:Il.cell) (src:Il.cell) - (slots:Ast.ty_tup) + (tys:Ast.ty_tup) : unit = Array.iteri begin - fun i slot -> + fun i ty -> 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 + trans_copy_ty ty_params initializing - sub_dst_cell slot sub_src_cell slot None + sub_dst_cell ty sub_src_cell ty None end - slots + tys - and trans_copy_slot + and without_exterior t = + match t with + | Ast.TY_mutable t + | Ast.TY_exterior t + | Ast.TY_constrained (t, _) -> + without_exterior t + | _ -> t + + and trans_copy_ty (ty_params:Il.cell) (initializing:bool) - (dst:Il.cell) (dst_slot:Ast.slot) - (src:Il.cell) (src_slot:Ast.slot) + (dst:Il.cell) (dst_ty:Ast.ty) + (src:Il.cell) (src_ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = let anno (weight:string) : unit = @@ -2908,13 +2886,12 @@ let trans_visitor annotate (Printf.sprintf "%sweight copy: %a <- %a" weight - Ast.sprintf_slot dst_slot - Ast.sprintf_slot src_slot) + Ast.sprintf_ty dst_ty + Ast.sprintf_ty src_ty) end; in - assert (slot_ty src_slot = slot_ty dst_slot); - match (slot_mem_ctrl src_slot, - slot_mem_ctrl dst_slot) with + assert (without_exterior src_ty = without_exterior dst_ty); + match (ty_mem_ctrl src_ty, ty_mem_ctrl dst_ty) with | (MEM_rc_opaque, MEM_rc_opaque) | (MEM_gc, MEM_gc) @@ -2924,14 +2901,14 @@ let trans_visitor add_to (exterior_rc_cell src) one; if not initializing then - drop_slot ty_params dst dst_slot None; + drop_ty ty_params dst dst_ty 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 + trans_copy_ty_heavy ty_params initializing + dst dst_ty src src_ty 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 @@ -2960,39 +2937,44 @@ let trans_visitor * *) - and trans_copy_slot_heavy + and trans_copy_ty_heavy (ty_params:Il.cell) (initializing:bool) - (dst:Il.cell) (dst_slot:Ast.slot) - (src:Il.cell) (src_slot:Ast.slot) + (dst:Il.cell) (dst_ty:Ast.ty) + (src:Il.cell) (src_ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = - assert (slot_ty src_slot = slot_ty dst_slot); + assert (without_exterior src_ty = without_exterior dst_ty); iflog (fun _ -> annotate ("heavy copy: slot preparation")); - let ty = slot_ty src_slot in + let ty = without_exterior src_ty 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 + let (dst, dst_ty) = deref_ty initializing dst dst_ty in + let (src, src_ty) = deref_ty false src src_ty in + assert (dst_ty = ty); + assert (src_ty = ty); + copy_ty ty_params dst src ty 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 _, + let (dst_cell, dst_ty) = trans_lval_maybe_init initializing dst in + let rec can_append t = + match t with + Ast.TY_vec _ + | Ast.TY_str -> true + | Ast.TY_exterior t when can_append t -> true + | _ -> false + in + match (dst_ty, src) with + (t, 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)) -> + when can_append t -> (* * Translate str or vec * @@ -3003,14 +2985,14 @@ let trans_visitor * 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 + let (a_cell, a_ty) = trans_lval a in + let (b_cell, b_ty) = trans_lval b in + trans_copy_ty (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) + initializing dst_cell dst_ty + a_cell a_ty None; + trans_vec_append dst_cell dst_ty + (Il.Cell b_cell) b_ty | (Ast.TY_obj caller_obj_ty, @@ -3026,7 +3008,6 @@ let trans_visitor | _ -> 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 (issue #84): this is wrong. It treats the underlying * obj-state as the same as the callee and simply substitutes @@ -3036,16 +3017,16 @@ let trans_visitor * 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()) + trans_copy_ty (get_ty_params_of_current_frame()) initializing - dst_cell dst_slot - src_cell src_slot + dst_cell dst_ty + src_cell src_ty 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 + let (caller_obj, _) = + deref_ty initializing dst_cell dst_ty in let caller_vtbl = get_element_ptr caller_obj Abi.binding_field_item @@ -3061,19 +3042,19 @@ let trans_visitor * 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 + mov (fst (deref_ty false dst_cell dst_ty)) 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 + let (src_cell, src_ty) = trans_lval src_lval in + trans_copy_ty (get_ty_params_of_current_frame()) initializing - dst_cell dst_slot - src_cell src_slot + dst_cell dst_ty + src_cell src_ty None and trans_copy_direct_fn @@ -3089,120 +3070,117 @@ let trans_visitor 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) + (dst_tys:Ast.ty array) (atoms:Ast.atom array) : unit = Array.iteri begin fun i atom -> - trans_init_slot_from_atom - CLONE_none + trans_init_ty_from_atom (get_element_ptr_dyn_in_current_frame dst i) - dst_slots.(i) - atom + dst_tys.(i) atom end atoms and trans_init_rec_update (dst:Il.cell) - (dst_slots:Ast.slot array) + (dst_tys:Ast.ty array) (trec:Ast.ty_rec) - (atab:(Ast.ident * Ast.mode * bool * Ast.atom) array) + (atab:(Ast.ident * Ast.atom) array) (base:Ast.lval) : unit = Array.iteri begin fun i (fml_ident, _) -> - let fml_entry _ (act_ident, _, _, atom) = + let fml_entry _ (act_ident, atom) = if act_ident = fml_ident then Some atom else None in - let slot = dst_slots.(i) in + let dst_ty = dst_tys.(i) in match arr_search atab fml_entry with Some atom -> - trans_init_slot_from_atom - CLONE_none + trans_init_ty_from_atom (get_element_ptr_dyn_in_current_frame dst i) - slot - atom + dst_ty atom | None -> - let (src, _) = trans_lval base in - trans_copy_slot + let (src, src_ty) = trans_lval base in + trans_copy_ty (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 + (get_element_ptr_dyn_in_current_frame dst i) dst_ty + (get_element_ptr_dyn_in_current_frame src i) src_ty None end trec - and trans_init_slot_from_atom - (clone:clone_ctrl) - (dst:Il.cell) (dst_slot:Ast.slot) - (atom:Ast.atom) + and trans_init_ty_from_atom + (dst:Il.cell) (ty:Ast.ty) (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 -> - (* Aliasing a literal is a bit weird since nobody - * else will ever see it, but it seems harmless. - *) - 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 + let src = Il.Mem (force_to_mem (trans_atom atom)) in + trans_copy_ty (get_ty_params_of_current_frame()) + true dst ty src ty None and trans_init_slot_from_cell + (ty_params:Il.cell) (clone:clone_ctrl) (dst:Il.cell) (dst_slot:Ast.slot) - (src:Il.cell) (src_slot:Ast.slot) + (src:Il.cell) (src_ty:Ast.ty) : 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 dst_ty = slot_ty dst_slot in + assert (src_ty = dst_ty); + match (dst_slot.Ast.slot_mode, clone) with + (Ast.MODE_alias, CLONE_none) -> + mov dst (Il.Cell (alias (Il.Mem (need_mem_cell src)))) + + | (Ast.MODE_interior, CLONE_none) -> + trans_copy_ty + ty_params true + dst dst_ty src src_ty None + + | (Ast.MODE_alias, _) -> + bug () "attempting to clone into alias slot" + + | (_, CLONE_chan clone_task) -> let clone = - if (type_contains_chan (slot_ty src_slot)) + if (type_contains_chan src_ty) 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 + (* Feed back with massaged args. *) + trans_init_slot_from_cell ty_params + clone dst dst_slot src src_ty + + | (_, CLONE_all clone_task) -> + clone_ty ty_params clone_task dst src src_ty None + + + and trans_init_slot_from_atom + (clone:clone_ctrl) + (dst:Il.cell) (dst_slot:Ast.slot) + (src_atom:Ast.atom) + : unit = + match (dst_slot.Ast.slot_mode, clone, src_atom) with + (Ast.MODE_alias, CLONE_none, + Ast.ATOM_literal _) -> + (* Aliasing a literal is a bit weird since nobody + * else will ever see it, but it seems harmless. + *) + let src = trans_atom src_atom in + mov dst (Il.Cell (alias (Il.Mem (force_to_mem src)))) + + | (Ast.MODE_alias, CLONE_chan _, _) + | (Ast.MODE_alias, CLONE_all _, _) -> + bug () "attempting to clone into alias slot" + | _ -> + let src = Il.Mem (force_to_mem (trans_atom src_atom)) in + trans_init_slot_from_cell + (get_ty_params_of_current_frame()) + clone dst dst_slot src (atom_type cx src_atom) + and trans_be_fn (cx:ctxt) @@ -3376,9 +3354,10 @@ let trans_visitor (* Emit arg1 of any call: the task pointer. *) iflog (fun _ -> annotate "fn-call arg 1: task pointer"); trans_init_slot_from_cell + (get_ty_params_of_current_frame()) CLONE_none arg_cell word_slot - abi.Abi.abi_tp_cell word_slot + abi.Abi.abi_tp_cell word_ty and trans_argN (clone:clone_ctrl) @@ -3509,9 +3488,11 @@ let trans_visitor annotate (Printf.sprintf "fn-call ty param %d of %d" i n_ty_params)); - trans_init_slot_from_cell CLONE_none + trans_init_slot_from_cell + (get_ty_params_of_current_frame()) + CLONE_none (get_element_ptr callee_ty_params i) word_slot - (get_tydesc None ty_param) word_slot + (get_tydesc None ty_param) word_ty end call.call_callee_ty_params; @@ -3609,7 +3590,7 @@ let trans_visitor (Printf.sprintf "extract bound arg %d as actual arg %d" !bound_i arg_i)); - get_element_ptr closure_args_cell (!bound_i); + get_element_ptr closure_args_cell (!bound_i) end else begin @@ -3623,9 +3604,10 @@ let trans_visitor 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; + trans_init_slot_from_cell + self_ty_params_cell CLONE_none + dst_cell slot + (deref_slot false src_cell slot) (slot_ty slot); incr (if is_bound then bound_i else unbound_i); done; assert ((!bound_i + !unbound_i) == n_args) @@ -3765,7 +3747,7 @@ let trans_visitor let (pat, block) = arm.node in (* Translates the pattern and returns the addresses of the branch * instructions, which are taken if the match fails. *) - let rec trans_pat pat src_cell src_slot = + let rec trans_pat pat src_cell src_ty = match pat with Ast.PAT_lit lit -> trans_compare Il.JNE (trans_lit lit) (Il.Cell src_cell) @@ -3773,7 +3755,7 @@ let trans_visitor | Ast.PAT_tag (lval, pats) -> let tag_name = tag_ctor_name_to_tag_name (lval_to_name lval) in let ty_tag = - match slot_ty src_slot with + match src_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" @@ -3782,9 +3764,6 @@ let trans_visitor let tag_number = arr_idx tag_keys tag_name in let ty_tup = Hashtbl.find ty_tag tag_name in - (* NB: follow any exterior pointer as we go. *) - let src_cell = deref_slot false src_cell src_slot in - let tag_cell:Il.cell = get_element_ptr src_cell 0 in let union_cell = get_element_ptr_dyn_in_current_frame src_cell 1 @@ -3801,8 +3780,8 @@ let trans_visitor let elem_cell = get_element_ptr_dyn_in_current_frame tup_cell i in - let elem_slot = ty_tup.(i) in - trans_pat elem_pat elem_cell elem_slot + let elem_ty = ty_tup.(i) in + trans_pat elem_pat elem_cell elem_ty in let elem_jumps = Array.mapi trans_elem_pat pats in @@ -3811,11 +3790,10 @@ let trans_visitor | Ast.PAT_slot (dst, _) -> let dst_slot = get_slot cx dst.id in let dst_cell = cell_of_block_slot dst.id in - trans_copy_slot - (get_ty_params_of_current_frame()) true - dst_cell dst_slot - src_cell src_slot - None; + trans_init_slot_from_cell + (get_ty_params_of_current_frame()) + CLONE_none dst_cell dst_slot + src_cell src_ty; [] (* irrefutable *) | Ast.PAT_wild -> [] (* irrefutable *) @@ -3909,16 +3887,16 @@ let trans_visitor 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 + let (seq_cell, seq_ty) = trans_lval_full false seq in + let unit_ty = seq_unit_ty seq_ty in Array.iter trans_stmt head_stmts; - iter_seq_slots ty_params seq_cell seq_cell unit_slot + iter_seq_parts ty_params seq_cell seq_cell unit_ty begin - fun _ src_cell unit_slot curr_iso -> - trans_copy_slot - ty_params true + fun _ src_cell unit_ty _ -> + trans_init_slot_from_cell + ty_params CLONE_none dst_cell dst_slot.node - src_cell unit_slot curr_iso; + src_cell unit_ty; trans_block fo.Ast.for_body; end None @@ -3978,13 +3956,10 @@ let trans_visitor 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 + and trans_vec_append dst_cell dst_ty src_oper src_ty = + let elt_ty = seq_unit_ty dst_ty in + let trim_trailing_null = dst_ty = Ast.TY_str in + assert (src_ty = dst_ty); match src_ty with Ast.TY_str | Ast.TY_vec _ -> @@ -3992,12 +3967,6 @@ let trans_visitor 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 @@ -4018,12 +3987,11 @@ let trans_visitor 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 eltp_rty = Il.AddrTy (referent_type abi elt_ty) in + let dptr = next_vreg_cell eltp_rty in + let sptr = next_vreg_cell eltp_rty in + let dlim = next_vreg_cell eltp_rty in + let elt_sz = ty_sz_in_current_frame elt_ty in let dst_data = get_element_ptr_dyn_in_current_frame dst_vec Abi.vec_elt_data @@ -4041,20 +4009,20 @@ let trans_visitor emit (Il.jmp Il.JMP Il.CodeNone); let back_jmp_targ = mark () in (* copy slot *) - trans_copy_slot + trans_copy_ty (get_ty_params_of_current_frame()) true - (deref dptr) dst_elt_slot - (deref sptr) src_elt_slot + (deref dptr) elt_ty + (deref sptr) elt_ty None; - add_to dptr dst_elt_sz; - add_to sptr src_elt_sz; + add_to dptr elt_sz; + add_to sptr 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 + let v = next_vreg_cell word_sty in mov v (Il.Cell src_fill); add_to dst_fill (Il.Cell v); | t -> @@ -4064,14 +4032,14 @@ let trans_visitor and trans_copy_binop dst binop a_src = - let (dst_cell, dst_slot) = trans_lval_maybe_init false dst in + let (dst_cell, dst_ty) = trans_lval_maybe_init false dst in let src_oper = trans_atom a_src in - match slot_ty dst_slot with + match dst_ty 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) + trans_vec_append dst_cell dst_ty src_oper (atom_type cx a_src) | _ -> - let dst_cell = deref_slot false dst_cell dst_slot in + let (dst_cell, _) = deref_ty false dst_cell dst_ty in let op = trans_binop binop in emit (Il.binary op dst_cell (Il.Cell dst_cell) src_oper); @@ -4159,46 +4127,43 @@ let trans_visitor 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 + let (slot_cell, ty) = trans_lval_init dst in + let (trec, dst_tys) = + match ty 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 + let (dst_cell, _) = deref_ty true slot_cell ty in begin match base with None -> - let atoms = - Array.map (fun (_, _, _, atom) -> atom) atab - in + let atoms = Array.map snd atab in trans_init_structural_from_atoms - dst_cell dst_slots atoms + dst_cell dst_tys atoms | Some base_lval -> trans_init_rec_update - dst_cell dst_slots trec atab base_lval + dst_cell dst_tys 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.STMT_init_tup (dst, atoms) -> + let (slot_cell, ty) = trans_lval_init dst in + let dst_tys = + match ty 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 + let (dst_cell, _) = deref_ty true slot_cell ty in + trans_init_structural_from_atoms dst_cell dst_tys atoms | Ast.STMT_init_str (dst, s) -> trans_init_str dst s - | Ast.STMT_init_vec (dst, _, atoms) -> + | Ast.STMT_init_vec (dst, atoms) -> trans_init_vec dst atoms | Ast.STMT_init_port dst -> @@ -4424,7 +4389,7 @@ let trans_visitor let trans_obj_ctor (obj_id:node_id) - (state:Ast.header_slots) + (header:Ast.header_slots) : unit = trans_frame_entry obj_id; @@ -4439,21 +4404,14 @@ let trans_visitor 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))) + let obj_args_tup = + Array.map (fun (sloti,_) -> (slot_ty sloti.node)) header in + let obj_args_ty = Ast.TY_tup obj_args_tup in + let state_ty = Ast.TY_tup [| Ast.TY_type; obj_args_ty |] in + let state_ptr_ty = Ast.TY_exterior state_ty in + let state_ptr_rty = referent_type abi state_ptr_ty in + let state_malloc_sz = exterior_allocation_size state_ty in let ctor_ty = Hashtbl.find cx.ctxt_all_item_types obj_id in let obj_ty = @@ -4508,10 +4466,17 @@ let trans_visitor * 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. + * frame. So we manually drop the argument slots here, + * without mentioning the slot ids. *) - drop_slot frame_ty_params frame_args obj_args_slot None; + Array.iteri + (fun i (sloti, _) -> + let cell = + get_element_ptr_dyn_in_current_frame + frame_args i + in + drop_slot frame_ty_params cell sloti.node None) + header; trans_frame_exit obj_id false; in @@ -4682,27 +4647,32 @@ let trans_visitor | Ast.TY_iso tiso -> get_iso_tag tiso | _ -> bugi cx tagid "unexpected fn 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 (dst_cell, dst_slot) = get_current_output_cell_and_slot() in let dst_cell = deref_slot true dst_cell dst_slot in - let src = get_explicit_args_for_current_frame () in let tag_cell = get_element_ptr dst_cell 0 in let union_cell = get_element_ptr_dyn_in_current_frame dst_cell 1 in let tag_body_cell = get_variant_ptr union_cell i in let tag_body_rty = snd (need_mem_cell tag_body_cell) in + let ty_params = get_ty_params_of_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: tag_body_rty=" ^ (Il.string_of_referent_ty tag_body_rty))); - trans_copy_tup - (get_ty_params_of_current_frame()) - true tag_body_cell src slots; + Array.iteri + begin + fun i sloti -> + let slot = sloti.node in + let ty = slot_ty slot in + trans_copy_ty ty_params true + (get_element_ptr_dyn_in_current_frame tag_body_cell i) ty + (deref_slot false (cell_of_block_slot sloti.id) slot) ty + None; + end + header_tup; trace_str cx.ctxt_sess.Session.sess_trace_tag ("finished tag constructor " ^ n); trans_frame_exit tagid true; diff --git a/src/boot/me/transutil.ml b/src/boot/me/transutil.ml index cb867fefc54..8c6b8bc3175 100644 --- a/src/boot/me/transutil.ml +++ b/src/boot/me/transutil.ml @@ -112,29 +112,35 @@ let word_ty_signed_mach (abi:Abi.abi) : ty_mach = ;; -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_str -> MEM_rc_opaque - | Ast.TY_vec _ -> - if type_has_state ty - then MEM_gc +let rec ty_mem_ctrl (ty:Ast.ty) : mem_ctrl = + match ty with + Ast.TY_port _ + | Ast.TY_chan _ + | Ast.TY_task + | Ast.TY_str -> MEM_rc_opaque + | Ast.TY_vec _ -> + if type_has_state ty + then MEM_gc + else MEM_rc_opaque + | Ast.TY_exterior t -> + if type_has_state t + then MEM_gc + else + if type_is_structured t + then MEM_rc_struct else 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 _ -> - if type_has_state ty - then MEM_gc - else MEM_rc_opaque - | _ -> - MEM_interior + | Ast.TY_mutable t + | Ast.TY_constrained (t, _) -> + ty_mem_ctrl t + | _ -> + MEM_interior +;; + +let slot_mem_ctrl (slot:Ast.slot) : mem_ctrl = + match slot.Ast.slot_mode with + Ast.MODE_alias -> MEM_interior + | Ast.MODE_interior -> + ty_mem_ctrl (slot_ty slot) ;; @@ -200,33 +206,33 @@ let next_power_of_two (x:int64) : int64 = Int64.add 1L (!xr) ;; -let iter_tup_slots +let iter_tup_parts (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) + (f:'a -> 'a -> Ast.ty -> (Ast.ty_iso option) -> unit) (curr_iso:Ast.ty_iso option) : unit = Array.iteri begin - fun i slot -> + fun i ty -> f (get_element_ptr dst_ptr i) (get_element_ptr src_ptr i) - slot curr_iso + ty curr_iso end slots ;; -let iter_rec_slots +let iter_rec_parts (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) + (f:'a -> 'a -> Ast.ty -> (Ast.ty_iso option) -> unit) (curr_iso:Ast.ty_iso option) : unit = - iter_tup_slots get_element_ptr dst_ptr src_ptr + iter_tup_parts get_element_ptr dst_ptr src_ptr (Array.map snd entries) f curr_iso ;; diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml index 346c6e39492..5311a4a4fb4 100644 --- a/src/boot/me/type.ml +++ b/src/boot/me/type.ml @@ -33,6 +33,23 @@ type binopsig = | BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *) ;; + +(* In some instances we will strip off a layer of mutability or exterior-ness, + * as trans is willing to transplant and/or overlook mutability / exterior + * differences wrt. many operators. + * + * Note: there is a secondary mutability-checking pass in effect.ml to ensure + * you're not actually mutating the insides of an immutable. That's not the + * typechecker's job. + *) +let simplified t = + match t with + Ast.TY_mutable (Ast.TY_exterior t) -> t + | Ast.TY_mutable t -> t + | Ast.TY_exterior t -> t + | _ -> t +;; + let rec tyspec_to_str (ts:tyspec) : string = let fmt = Format.fprintf in @@ -253,17 +270,14 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = (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) + let find_ty (query:Ast.ident) : Ast.ty = + match atab_search fields query with + None -> fail() + | Some t -> t in let check_entry ident tv = - unify_slot (find_slot ident 0) None tv + unify_ty (find_ty ident) tv in Hashtbl.iter check_entry dct in @@ -290,18 +304,20 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | 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_exterior ty + | Ast.TY_mutable ty | Ast.TY_constrained (ty, _) -> is_comparable_or_ordered comparable ty in let floating (ty:Ast.ty) : bool = - match ty with + match simplified ty with Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true | _ -> false in let integral (ty:Ast.ty) : bool = - match ty with + match simplified ty with Ast.TY_int | Ast.TY_uint | 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 @@ -313,7 +329,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in let plusable (ty:Ast.ty) : bool = - match ty with + match simplified ty with Ast.TY_str -> true | Ast.TY_vec _ -> true | _ -> numeric ty @@ -369,7 +385,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) -> begin match ty with - Ast.TY_vec slot -> unify_slot slot None tv + Ast.TY_vec ty -> unify_ty ty tv | Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv | _ -> fail () end; @@ -439,12 +455,12 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (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) + Ast.TY_tup (elem_tys:Ast.ty array) -> + if (Array.length elem_tys) <> (Array.length tvs) then fail () else let check_elem i tv = - unify_slot (elem_slots.(i)) None tv + unify_ty (elem_tys.(i)) tv in Array.iteri check_elem tvs | _ -> fail () @@ -455,9 +471,9 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) -> begin match ty with - Ast.TY_vec slot -> - unify_slot slot None tv; - TYSPEC_resolved (params, ty) + Ast.TY_vec ty -> + unify_ty ty tv; + TYSPEC_resolved (params, Ast.TY_vec ty) | _ -> fail () end @@ -942,7 +958,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = 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 + unify_ty (project_type ty comp) tv | _ -> () @@ -981,7 +997,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | 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 add_field (ident, atom) = let tv = ref TYSPEC_all in unify_atom atom tv; Hashtbl.add dct ident tv @@ -994,7 +1010,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | Ast.STMT_init_rec (lval, fields, None) -> let dct = Hashtbl.create 10 in - let add_field (ident, _, _, atom) = + let add_field (ident, atom) = let tv = ref TYSPEC_all in unify_atom atom tv; Hashtbl.add dct ident tv @@ -1003,7 +1019,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = unify_lval lval (ref (TYSPEC_record dct)) | Ast.STMT_init_tup (lval, members) -> - let member_to_tv (_, _, atom) = + let member_to_tv atom = let tv = ref TYSPEC_all in unify_atom atom tv; tv @@ -1011,7 +1027,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let member_tvs = Array.map member_to_tv members in unify_lval lval (ref (TYSPEC_tuple member_tvs)) - | Ast.STMT_init_vec (lval, _, atoms) -> + | 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; @@ -1181,8 +1197,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = Ast.TY_fn (tsig, _) -> begin let vec_str = - interior_slot (Ast.TY_vec - (interior_slot Ast.TY_str)) + interior_slot (Ast.TY_vec Ast.TY_str) in match tsig.Ast.sig_input_slots with [| |] -> () @@ -1236,13 +1251,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let tag_tv = ref TYSPEC_all in unify_ty tag_ty tag_tv; unify_tyvars expected tag_tv; - List.iter - begin - fun slot -> - match slot.Ast.slot_ty with - Some ty -> expect ty - | None -> bug () "no slot type in tag slot tuple" - end + List.iter expect (List.rev (Array.to_list tag_ty_tup)); | Ast.PAT_slot (sloti, _) -> @@ -1336,8 +1345,14 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = 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 }) + begin + match slot_defn.Ast.slot_ty with + Some _ -> () + | None -> + Hashtbl.replace cx.ctxt_all_defns id + (DEFN_slot { slot_defn with + Ast.slot_ty = Some ty }) + end | _ -> bug () "check_auto_tyvar: no slot defn" in @@ -1349,7 +1364,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = begin match !(resolve_tyvar tv) with TYSPEC_resolved ([||], ty) -> - (Ast.TY_vec (interior_slot ty)) + (Ast.TY_vec ty) | _ -> err (Some id) "unresolved vector-element type in %s (%d)" diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml index d42aaf6d5ed..79e4784566e 100644 --- a/src/boot/me/typestate.ml +++ b/src/boot/me/typestate.ml @@ -419,7 +419,7 @@ let condition_assigning_visitor raise_precondition s.id precond; raise_postcondition s.id postcond - | Ast.STMT_init_vec (dst, _, atoms) -> + | Ast.STMT_init_vec (dst, atoms) -> let precond = slot_inits (atoms_slots cx atoms) in let postcond = slot_inits (lval_slots cx dst) in raise_precondition s.id precond; @@ -980,13 +980,19 @@ let lifecycle_visitor if initializing then begin - Hashtbl.add cx.ctxt_copy_stmt_is_init s.id (); + iflog cx + begin + fun _ -> + log cx "noting lval %a init at stmt %a" + Ast.sprintf_lval lv_dst Ast.sprintf_stmt s + end; + Hashtbl.replace 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_vec (lv_dst, _) | Ast.STMT_init_str (lv_dst, _) | Ast.STMT_init_port lv_dst | Ast.STMT_init_chan (lv_dst, _) -> diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml index 203acfce7d6..64c08724a72 100644 --- a/src/boot/me/walk.ml +++ b/src/boot/me/walk.ml @@ -262,7 +262,7 @@ and walk_mod_item item -and walk_ty_tup v ttup = Array.iter (walk_slot v) ttup +and walk_ty_tup v ttup = Array.iter (walk_ty v) ttup and walk_ty_tag v ttag = Hashtbl.iter (fun _ t -> walk_ty_tup v t) ttag @@ -273,8 +273,8 @@ and walk_ty 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_vec s -> walk_ty v s + | Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_ty 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 @@ -301,6 +301,8 @@ and walk_ty | Ast.TY_nil -> () | Ast.TY_task -> () | Ast.TY_any -> () + | Ast.TY_exterior m -> walk_ty v m + | Ast.TY_mutable m -> walk_ty v m in walk_bracketed v.visit_ty_pre @@ -448,16 +450,16 @@ and walk_stmt | Ast.STMT_init_rec (lv, atab, base) -> walk_lval v lv; - Array.iter (fun (_, _, _, a) -> walk_atom v a) atab; + Array.iter (fun (_, a) -> walk_atom v a) atab; walk_option (walk_lval v) base; - | Ast.STMT_init_vec (lv, _, atoms) -> + | Ast.STMT_init_vec (lv, atoms) -> walk_lval v lv; Array.iter (walk_atom v) atoms | Ast.STMT_init_tup (lv, mut_atoms) -> walk_lval v lv; - Array.iter (fun (_, _, a) -> walk_atom v a) mut_atoms + Array.iter (walk_atom v) mut_atoms | Ast.STMT_init_str (lv, _) -> walk_lval v lv @@ -469,6 +471,10 @@ and walk_stmt walk_option (walk_lval v) port; walk_lval v chan; + | Ast.STMT_init_exterior (dst, src) -> + walk_lval v dst; + walk_atom v src + | Ast.STMT_for f -> walk_stmt_for f