diff options
Diffstat (limited to 'src')
39 files changed, 1986 insertions, 1527 deletions
diff --git a/src/Makefile b/src/Makefile index 2c06b5f5..fa02a2a2 100644 --- a/src/Makefile +++ b/src/Makefile @@ -356,6 +356,7 @@ TEST_XFAILS_LLVM := $(addprefix test/run-pass/, \ complex.rs \ dead-code-one-arm-if.rs \ deep.rs \ + deref.rs \ div-mod.rs \ drop-on-ret.rs \ else-if.rs \ @@ -544,6 +545,9 @@ check: tidy \ $(TEST_RPASS_OUTS_X86) $(TEST_RFAIL_OUTS_X86) \ $(TEST_CFAIL_OUTS_X86) +compile-check: tidy \ + $(TEST_RPASS_EXES_X86) $(TEST_RFAIL_EXES_X86) + ifeq ($(VARIANT),llvm) ALL_TEST_CRATES += $(TEST_CFAIL_CRATES_LLVM) \ @@ -565,27 +569,33 @@ endif REQ := $(CFG_BOOT) $(CFG_RUNTIME) $(CFG_STDLIB) BOOT := $(CFG_QUIET)OCAMLRUNPARAM="b1" $(CFG_BOOT) $(CFG_BOOT_FLAGS) -test/run-pass/%.out: test/run-pass/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME) +# Cancel the implicit .out rule in GNU make. +%.out: % + +%.out: %.out.tmp + $(CFG_QUIET)mv $< $@ + +test/run-pass/%.out.tmp: test/run-pass/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME) @$(call CFG_ECHO, run: $<) $(CFG_QUIET)$(call CFG_RUN_TARG, $<) > $@ -test/run-fail/%.out: test/run-fail/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME) +test/run-fail/%.out.tmp: test/run-fail/%$(CFG_EXE_SUFFIX) $(CFG_RUNTIME) @$(call CFG_ECHO, run: $<) $(CFG_QUIET)rm -f $@ $(CFG_QUIET)$(call CFG_RUN_TARG, $<) >$@ 2>&1 ; X=$$? ; \ if [ $$X -eq 0 ] ; then exit 1 ; else exit 0 ; fi $(CFG_QUIET)grep --text --quiet \ "`awk -F: '/error-pattern/ { print $$2 }' \ - $(basename $(basename $@)).rs | tr -d '\n\r'`" $@ + $(basename $(basename $(basename $@))).rs | tr -d '\n\r'`" $@ -test/compile-fail/%.x86.out: test/compile-fail/%.rs $(REQ) +test/compile-fail/%.x86.out.tmp: test/compile-fail/%.rs $(REQ) @$(call CFG_ECHO, compile [x86]: $<) $(CFG_QUIET)rm -f $@ $(BOOT) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true $(CFG_QUIET)grep --text --quiet \ "`awk -F: '/error-pattern/ { print $$2 }' $< | tr -d '\n\r'`" $@ -test/compile-fail/%.llvm.out: test/compile-fail/%.rs $(REQ) +test/compile-fail/%.llvm.out.tmp: test/compile-fail/%.rs $(REQ) @$(call CFG_ECHO, compile [llvm]: $<) $(CFG_QUIET)rm -f $@ $(BOOT) -o $(@:.out=$(CFG_EXE_SUFFIX)) $< >$@ 2>&1 || true diff --git a/src/boot/be/abi.ml b/src/boot/be/abi.ml index 9108a182..44f9761b 100644 --- a/src/boot/be/abi.ml +++ b/src/boot/be/abi.ml @@ -26,20 +26,20 @@ let frame_glue_fns_field_mark = 0;; let frame_glue_fns_field_drop = 1;; let frame_glue_fns_field_reloc = 2;; -let exterior_rc_slot_field_refcnt = 0;; -let exterior_rc_slot_field_body = 1;; +let box_rc_slot_field_refcnt = 0;; +let box_rc_slot_field_body = 1;; -let exterior_gc_slot_alloc_base = (-3);; -let exterior_gc_slot_field_prev = (-3);; -let exterior_gc_slot_field_next = (-2);; -let exterior_gc_slot_field_ctrl = (-1);; -let exterior_gc_slot_field_refcnt = 0;; -let exterior_gc_slot_field_body = 1;; +let box_gc_slot_alloc_base = (-3);; +let box_gc_slot_field_prev = (-3);; +let box_gc_slot_field_next = (-2);; +let box_gc_slot_field_ctrl = (-1);; +let box_gc_slot_field_refcnt = 0;; +let box_gc_slot_field_body = 1;; -let exterior_rc_header_size = 1;; -let exterior_gc_header_size = 4;; +let box_rc_header_size = 1;; +let box_gc_header_size = 4;; -let exterior_gc_malloc_return_adjustment = 3;; +let box_gc_malloc_return_adjustment = 3;; let stk_field_valgrind_id = 0 + 1;; let stk_field_limit = stk_field_valgrind_id + 1;; diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml index 182096ed..d18cf11f 100644 --- a/src/boot/be/x86.ml +++ b/src/boot/be/x86.ml @@ -829,7 +829,7 @@ let sweep_gc_chain emit (Il.jmp Il.JE (codefix exit_jmp_fix)); (* if nonzero *) mov (rc ecx) (* Load GC ctrl word *) - (c (edi_n Abi.exterior_gc_slot_field_ctrl)); + (c (edi_n Abi.box_gc_slot_field_ctrl)); mov (rc eax) (ro ecx); band (rc eax) (immi 1L); (* Extract mark to eax. *) band (* Clear mark in ecx. *) @@ -839,7 +839,7 @@ let sweep_gc_chain if clear_mark then mov (* Write-back cleared. *) - ((edi_n Abi.exterior_gc_slot_field_ctrl)) + ((edi_n Abi.box_gc_slot_field_ctrl)) (ro ecx); emit (Il.cmp (ro eax) (immi 0L)); @@ -870,7 +870,7 @@ let sweep_gc_chain mark skip_jmp_fix; mov (rc edi) (* Advance down chain *) - (c (edi_n Abi.exterior_gc_slot_field_next)); + (c (edi_n Abi.box_gc_slot_field_next)); emit (Il.jmp Il.JMP (codefix repeat_jmp_fix)); (* loop *) mark exit_jmp_fix; @@ -901,7 +901,7 @@ let gc_glue (* The sweep pass has two sub-passes over the GC chain: * * - In pass #1, 'severing', we goes through and disposes of all - * mutable exterior slots in each record. That is, rc-- the referent, + * mutable box slots in each record. That is, rc-- the referent, * and then null-out. If the rc-- gets to zero, that just means the * mutable is part of the garbage set currently being collected. But * a mutable may be live-and-outside; this detaches the garbage set diff --git a/src/boot/driver/llvm/glue.ml b/src/boot/driver/llvm/glue.ml index ef5c1c86..30fce0cd 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 8cfe4048..5655604d 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 770b57bf..92aad667 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_box 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_local | 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_box of (lval * atom) | STMT_copy of (lval * expr) | STMT_copy_binop of (lval * binop * atom) | STMT_call of (lval * lval * (atom array)) @@ -334,6 +337,7 @@ and lit = and lval_component = COMP_named of name_component | COMP_atom of atom + | COMP_deref (* identifying the name_base here is sufficient to identify the full lval *) @@ -406,7 +410,7 @@ and obj = and ty_param = ident * (ty_param_idx * effect) and mod_item' = - MOD_ITEM_type of ty + MOD_ITEM_type of (effect * ty) | MOD_ITEM_tag of (header_tup * ty_tag * node_id) | MOD_ITEM_mod of (mod_view * mod_items) | MOD_ITEM_fn of fn @@ -516,24 +520,36 @@ 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 -> () + | MODE_local -> () 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 +610,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 +639,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 +656,14 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit = | TY_named n -> fmt_name ff n | TY_type -> fmt ff "type" + | TY_box 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 @@ -843,24 +863,23 @@ and fmt_atom_opts (ff:Format.formatter) (az:(atom option) array) : unit = az; fmt ff ")" -and fmt_lval_component (ff:Format.formatter) (lvc:lval_component) : unit = - match lvc with - COMP_named nc -> fmt_name_component ff nc - | COMP_atom a -> - begin - fmt ff "("; - fmt_atom ff a; - fmt ff ")" - end - and fmt_lval (ff:Format.formatter) (l:lval) : unit = match l with LVAL_base nbi -> fmt_name_base ff nbi.node | LVAL_ext (lv, lvc) -> begin - fmt_lval ff lv; - fmt ff "."; - fmt_lval_component ff lvc + match lvc with + COMP_named nc -> + fmt_lval ff lv; + fmt ff "."; + fmt_name_component ff nc + | COMP_atom a -> + fmt_lval ff lv; + fmt ff "."; + fmt_bracketed "(" ")" fmt_atom ff a; + | COMP_deref -> + fmt ff "*"; + fmt_lval ff lv end and fmt_stmt (ff:Format.formatter) (s:stmt) : unit = @@ -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 @@ -1028,15 +1045,12 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = | STMT_init_tup (dst, entries) -> fmt_lval ff dst; - fmt ff " = ("; + fmt ff " = tup("; for i = 0 to (Array.length entries) - 1 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_box (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?" @@ -1160,6 +1180,13 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = | STMT_slice _ -> fmt ff "?stmt_slice?" end +and fmt_decl_param (ff:Format.formatter) (param:ty_param) : unit = + let (ident, (i, e)) = param in + fmt_effect ff e; + if e <> PURE then fmt ff " "; + fmt_ident ff ident; + fmt ff "=<p#%d>" i + and fmt_decl_params (ff:Format.formatter) (params:ty_param array) : unit = if Array.length params = 0 then () @@ -1170,11 +1197,7 @@ and fmt_decl_params (ff:Format.formatter) (params:ty_param array) : unit = do if i <> 0 then fmt ff ", "; - let (ident, (i, e)) = params.(i) in - fmt_effect ff e; - if e <> PURE then fmt ff " "; - fmt_ident ff ident; - fmt ff "=<p#%d>" i + fmt_decl_param ff params.(i) done; fmt ff "]" end; @@ -1192,6 +1215,10 @@ and fmt_ident_and_params fmt_ident ff id; fmt_decl_params ff params +and fmt_effect_qual (ff:Format.formatter) (e:effect) : unit = + fmt_effect ff e; + if e <> PURE then fmt ff " "; + and fmt_fn (ff:Format.formatter) (id:ident) @@ -1199,8 +1226,7 @@ and fmt_fn (f:fn) : unit = fmt_obox ff; - fmt_effect ff f.fn_aux.fn_effect; - if f.fn_aux.fn_effect <> PURE then fmt ff " "; + fmt_effect_qual ff f.fn_aux.fn_effect; fmt ff "%s "(if f.fn_aux.fn_is_iter then "iter" else "fn"); fmt_ident_and_params ff id params; fmt_header_slots ff f.fn_input_slots; @@ -1220,8 +1246,7 @@ and fmt_obj (obj:obj) : unit = fmt_obox ff; - fmt_effect ff obj.obj_effect; - if obj.obj_effect <> PURE then fmt ff " "; + fmt_effect_qual ff obj.obj_effect; fmt ff "obj "; fmt_ident_and_params ff id params; fmt_header_slots ff obj.obj_state; @@ -1257,7 +1282,8 @@ and fmt_mod_item (ff:Format.formatter) (id:ident) (item:mod_item) : unit = let params = Array.map (fun i -> i.node) params in begin match item.node.decl_item with - MOD_ITEM_type ty -> + MOD_ITEM_type (e, ty) -> + fmt_effect_qual ff e; fmt ff "type "; fmt_ident_and_params ff id params; fmt ff " = "; @@ -1316,22 +1342,24 @@ and fmt_crate (ff:Format.formatter) (c:crate) : unit = let sprintf_expr = sprintf_fmt fmt_expr;; let sprintf_name = sprintf_fmt fmt_name;; +let sprintf_name_component = sprintf_fmt fmt_name_component;; let sprintf_lval = sprintf_fmt fmt_lval;; -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;; let sprintf_carg = sprintf_fmt fmt_carg;; let sprintf_constr = sprintf_fmt fmt_constr;; -let sprintf_stmt = sprintf_fmt fmt_stmt;; let sprintf_mod_items = sprintf_fmt fmt_mod_items;; +let sprintf_decl_param = sprintf_fmt fmt_decl_param;; let sprintf_decl_params = sprintf_fmt fmt_decl_params;; let sprintf_app_args = sprintf_fmt fmt_app_args;; +(* You probably want this one; stmt has a leading \n *) +let sprintf_stmt = sprintf_fmt fmt_stmt_body;; + (* * Local Variables: * fill-column: 78; diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml index 3efd4e2a..130909e2 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 @@ -235,8 +242,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array = match name with Ast.NAME_base (Ast.BASE_ident ident) -> let slot = - { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; + { Ast.slot_mode = Ast.MODE_local; 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)) @@ -754,6 +760,20 @@ and parse_obj_item span ps apos bpos (decl params (Ast.MOD_ITEM_obj obj))) +and parse_type_item + (ps:pstate) + (apos:pos) + (effect:Ast.effect) + : (Ast.ident * Ast.mod_item) = + expect ps TYPE; + let (ident, params) = parse_ident_and_params ps "type" in + let _ = expect ps EQ in + let ty = ctxt "mod type item: ty" Pexp.parse_ty ps in + let _ = expect ps SEMI in + let bpos = lexpos ps in + let item = Ast.MOD_ITEM_type (effect, ty) in + (ident, span ps apos bpos (decl params item)) + and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) = let apos = lexpos ps in @@ -769,13 +789,15 @@ and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) = | _ -> ps.pstate_infer_lib_name ident in + match peek ps with - IO | STATE | UNSAFE | OBJ | FN | ITER -> + IO | STATE | UNSAFE | TYPE | OBJ | FN | ITER -> let effect = Pexp.parse_effect ps in begin match peek ps with OBJ -> parse_obj_item ps apos effect + | TYPE -> parse_type_item ps apos effect | _ -> let is_iter = (peek ps) = ITER in bump ps; @@ -789,16 +811,6 @@ and parse_mod_item (ps:pstate) : (Ast.ident * Ast.mod_item) = (decl params (Ast.MOD_ITEM_fn fn))) end - | TYPE -> - bump ps; - let (ident, params) = parse_ident_and_params ps "type" in - let _ = expect ps EQ in - let ty = ctxt "mod type item: ty" Pexp.parse_ty ps in - let _ = expect ps SEMI in - let bpos = lexpos ps in - let item = Ast.MOD_ITEM_type ty in - (ident, span ps apos bpos (decl params item)) - | MOD -> bump ps; let (ident, params) = parse_ident_and_params ps "mod" in @@ -958,7 +970,8 @@ and parse_mod_item_from_signature (ps:pstate) in expect ps SEMI; let bpos = lexpos ps in - (ident, span ps apos bpos (decl params (Ast.MOD_ITEM_type t))) + (ident, span ps apos bpos + (decl params (Ast.MOD_ITEM_type (Ast.UNSAFE, t)))) | _ -> raise (unexpected ps) @@ -979,7 +992,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 = @@ -1000,7 +1015,7 @@ and expand_tags | _ -> [| |] in match item.node.Ast.decl_item with - Ast.MOD_ITEM_type tyd -> handle_ty_decl item.id tyd + Ast.MOD_ITEM_type (_, tyd) -> handle_ty_decl item.id tyd | _ -> [| |] diff --git a/src/boot/fe/lexer.mll b/src/boot/fe/lexer.mll index fb4d58c5..6430821d 100644 --- a/src/boot/fe/lexer.mll +++ b/src/boot/fe/lexer.mll @@ -79,6 +79,7 @@ ("int", INT); ("uint", UINT); + ("float", FLOAT); ("char", CHAR); ("str", STR); @@ -121,9 +122,10 @@ } let hexdig = ['0'-'9' 'a'-'f' 'A'-'F'] -let bin = "0b" ['0' '1']['0' '1' '_']* -let hex = "0x" hexdig ['0'-'9' 'a'-'f' 'A'-'F' '_']* -let dec = ['0'-'9']+ +let decdig = ['0'-'9'] +let bin = '0' 'b' ['0' '1' '_']* +let hex = '0' 'x' ['0'-'9' 'a'-'f' 'A'-'F' '_']* +let dec = decdig ['0'-'9' '_']* let exp = ['e''E']['-''+']? dec let flo = (dec '.' dec (exp?)) | (dec exp) @@ -160,7 +162,7 @@ rule token = parse | ">>>" { ASR } | '~' { TILDE } | '{' { LBRACE } -| '_' (dec as n) { IDX (int_of_string n) } +| '_' (decdig+ as n) { IDX (int_of_string n) } | '_' { UNDERSCORE } | '}' { RBRACE } diff --git a/src/boot/fe/parser.ml b/src/boot/fe/parser.ml index 5df44303..ab7ff56c 100644 --- a/src/boot/fe/parser.ml +++ b/src/boot/fe/parser.ml @@ -180,14 +180,12 @@ let err (str:string) (ps:pstate) = let (slot_nil:Ast.slot) = - { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; + { Ast.slot_mode = Ast.MODE_local; Ast.slot_ty = Some Ast.TY_nil } ;; let (slot_auto:Ast.slot) = - { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = true; + { Ast.slot_mode = Ast.MODE_local; Ast.slot_ty = None } ;; diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml index e859d135..14065466 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) @@ -33,7 +33,7 @@ type pexp' = | PEXP_lit of Ast.lit | PEXP_str of string | PEXP_mutable of pexp - | PEXP_exterior of pexp + | PEXP_box of pexp | PEXP_custom of Ast.name * (pexp array) * (string option) and plval = @@ -41,6 +41,7 @@ and plval = | PLVAL_app of (Ast.ident * (Ast.ty array)) | PLVAL_ext_name of (pexp * Ast.name_component) | PLVAL_ext_pexp of (pexp * pexp) + | PLVAL_ext_deref of pexp and pexp = pexp' Common.identified ;; @@ -261,11 +262,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 +273,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 +287,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 +299,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 +332,14 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | _ -> raise (unexpected ps) end + | AT -> + bump ps; + Ast.TY_box (parse_ty ps) + + | MUTABLE -> + bump ps; + Ast.TY_mutable (parse_ty ps) + | LPAREN -> begin bump ps; @@ -353,24 +360,15 @@ and flag (ps:pstate) (tok:token) : bool = then (bump ps; true) else false -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 + | _ -> Ast.MODE_local 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 +379,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) @@ -477,7 +482,7 @@ and parse_bottom_pexp (ps:pstate) : pexp = bump ps; let inner = parse_pexp ps in let bpos = lexpos ps in - span ps apos bpos (PEXP_exterior inner) + span ps apos bpos (PEXP_box inner) | TUP -> bump ps; @@ -494,16 +499,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 @@ -588,6 +586,13 @@ and parse_bottom_pexp (ps:pstate) : pexp = end end + + | STAR -> + bump ps; + let inner = parse_pexp ps in + let bpos = lexpos ps in + span ps apos bpos (PEXP_lval (PLVAL_ext_deref inner)) + | (INT | UINT | CHAR | BOOL) as tok -> begin bump ps; @@ -1030,6 +1035,11 @@ let rec desugar_lval (ps:pstate) (pexp:pexp) : (Ast.stmt array * Ast.lval) = (Array.append base_stmts ext_stmts, Ast.LVAL_ext (base_lval, Ast.COMP_atom (clone_atom ps ext_atom))) + | PEXP_lval (PLVAL_ext_deref base_pexp) -> + let (base_stmts, base_atom) = desugar_expr_atom ps base_pexp in + let base_lval = atom_lval ps base_atom in + (base_stmts, Ast.LVAL_ext (base_lval, Ast.COMP_deref)) + | _ -> let (stmts, atom) = desugar_expr_atom ps pexp in (stmts, atom_lval ps atom) @@ -1088,7 +1098,9 @@ and desugar_expr_atom | PEXP_call _ | PEXP_bind _ | PEXP_spawn _ - | PEXP_custom _ -> + | PEXP_custom _ + | PEXP_box _ + | 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 +1113,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 +1125,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 +1234,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 +1259,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 +1296,19 @@ and desugar_expr_init in aa port_stmts [| chan_stmt |] - | PEXP_exterior _ -> - raise (err "exterior symbol in initialiser context" ps) + | PEXP_box arg -> + let (arg_stmts, arg_mode_atom) = + desugar_expr_atom ps arg + in + let stmt = ss (Ast.STMT_init_box (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/fe/token.ml b/src/boot/fe/token.ml index 636e1ac2..446e5262 100644 --- a/src/boot/fe/token.ml +++ b/src/boot/fe/token.ml @@ -118,6 +118,7 @@ type token = | BOOL | INT | UINT + | FLOAT | CHAR | STR | MACH of Common.ty_mach @@ -267,6 +268,7 @@ let rec string_of_tok t = | BOOL -> "bool" | INT -> "int" | UINT -> "uint" + | FLOAT -> "float" | CHAR -> "char" | STR -> "str" | MACH m -> Common.string_of_ty_mach m diff --git a/src/boot/llvm/lltrans.ml b/src/boot/llvm/lltrans.ml index 7a62bb73..a7daa371 100644 --- a/src/boot/llvm/lltrans.ml +++ b/src/boot/llvm/lltrans.ml @@ -253,16 +253,24 @@ let trans_crate fn_ty void_ty (Array.append [| lloutptr; lltaskty |] llins) | Ast.TY_tup slots -> - s (Array.map (trans_slot None) slots) + s (Array.map trans_ty slots) | Ast.TY_rec entries -> - s (Array.map (fun e -> trans_slot None (snd e)) entries) + s (Array.map (fun (_, e) -> trans_ty e) entries) | Ast.TY_constrained (ty', _) -> trans_ty ty' | Ast.TY_chan _ | Ast.TY_port _ | Ast.TY_task -> p rc_opaque_ty + | Ast.TY_box t -> + (* FIXME: wrong, this needs to point to a refcounted cell. *) + p (trans_ty t) + + | Ast.TY_mutable t -> + (* FIXME: No idea if 'mutable' translates to LLVM-type. *) + (trans_ty t) + | Ast.TY_native _ -> word_ty @@ -286,10 +294,9 @@ let trans_crate in let base_llty = trans_ty ty in match slot.Ast.slot_mode with - Ast.MODE_exterior _ | Ast.MODE_alias _ -> Llvm.pointer_type base_llty - | Ast.MODE_interior _ -> base_llty + | Ast.MODE_local _ -> base_llty in let get_element_ptr @@ -320,14 +327,14 @@ let trans_crate | _ -> trans_free llbuilder lltask ptr in - let rec iter_ty_slots_full + let rec iter_ty_parts_full (llbuilder:Llvm.llbuilder ref) (ty:Ast.ty) (dst_ptr:Llvm.llvalue) (src_ptr:Llvm.llvalue) (f:(Llvm.llvalue -> Llvm.llvalue - -> Ast.slot + -> Ast.ty -> (Ast.ty_iso option) -> unit)) (curr_iso:Ast.ty_iso option) @@ -338,38 +345,38 @@ let trans_crate match ty with Ast.TY_rec entries -> - iter_rec_slots gep dst_ptr src_ptr entries f curr_iso + iter_rec_parts gep dst_ptr src_ptr entries f curr_iso - | Ast.TY_tup slots -> - iter_tup_slots gep dst_ptr src_ptr slots f curr_iso + | Ast.TY_tup tys -> + iter_tup_parts gep dst_ptr src_ptr tys f curr_iso | Ast.TY_tag _ | Ast.TY_iso _ | Ast.TY_fn _ | Ast.TY_obj _ -> - bug () "unimplemented ty in Lltrans.iter_ty_slots_full" + bug () "unimplemented ty in Lltrans.iter_ty_parts_full" | _ -> () - and iter_ty_slots + and iter_ty_parts (llbuilder:Llvm.llbuilder ref) (ty:Ast.ty) (ptr:Llvm.llvalue) - (f:Llvm.llvalue -> Ast.slot -> (Ast.ty_iso option) -> unit) + (f:Llvm.llvalue -> Ast.ty -> (Ast.ty_iso option) -> unit) (curr_iso:Ast.ty_iso option) : unit = - iter_ty_slots_full llbuilder ty ptr ptr + iter_ty_parts_full llbuilder ty ptr ptr (fun _ src_ptr slot curr_iso -> f src_ptr slot curr_iso) curr_iso and drop_ty (llbuilder:Llvm.llbuilder ref) (lltask:Llvm.llvalue) - (ty:Ast.ty) (ptr:Llvm.llvalue) + (ty:Ast.ty) (curr_iso:Ast.ty_iso option) : unit = - iter_ty_slots llbuilder ty ptr (drop_slot llbuilder lltask) curr_iso + iter_ty_parts llbuilder ty ptr (drop_ty llbuilder lltask) curr_iso and drop_slot (llbuilder:Llvm.llbuilder ref) @@ -446,7 +453,7 @@ let trans_crate llbuilder := if_ptr_in_slot_not_null (decr_refcnt_and_if_zero - Abi.exterior_rc_slot_field_refcnt + Abi.box_rc_slot_field_refcnt free_and_null_out_slot) (!llbuilder) @@ -454,14 +461,14 @@ let trans_crate llbuilder := if_ptr_in_slot_not_null (decr_refcnt_and_if_zero - Abi.exterior_rc_slot_field_refcnt + Abi.box_rc_slot_field_refcnt free_and_null_out_slot) (!llbuilder) | MEM_interior when Semant.type_is_structured ty -> (* FIXME: to handle recursive types, need to call drop glue here, not inline. *) - drop_ty llbuilder lltask ty slot_ptr curr_iso + drop_ty llbuilder lltask slot_ptr ty curr_iso | _ -> () end @@ -555,7 +562,7 @@ let trans_crate Array.iteri build_arg (Llvm.params llfn); (* Allocate space for all the blocks' slots. - * and zero the exteriors. *) + * and zero the box pointers. *) let init_block (block_id:node_id) : unit = let init_slot (key:Ast.slot_key) @@ -757,7 +764,7 @@ let trans_crate Ast.STMT_init_tup (dest, atoms) -> let zero = const_i32 0 in let lldest = trans_lval dest in - let trans_tup_atom idx (_, _, atom) = + let trans_tup_atom idx atom = let indices = [| zero; const_i32 idx |] in let gep_id = anon_llid "init_tup_gep" in let ptr = @@ -814,17 +821,18 @@ let trans_crate | Ast.STMT_log a -> begin - match Semant.atom_type sem_cx a with - (* NB: If you extend this, be sure to update the - * typechecking code in type.ml as well. *) - Ast.TY_str -> trans_log_str a - | Ast.TY_int | Ast.TY_uint | Ast.TY_bool | Ast.TY_char - | Ast.TY_mach (TY_u8) | Ast.TY_mach (TY_u16) - | Ast.TY_mach (TY_u32) | Ast.TY_mach (TY_i8) - | Ast.TY_mach (TY_i16) | Ast.TY_mach (TY_i32) -> - trans_log_int a - | _ -> Semant.bugi sem_cx head.id - "unimplemented logging type" + let aty = Semant.atom_type sem_cx a in + match Semant.simplified_ty aty with + (* NB: If you extend this, be sure to update the + * typechecking code in type.ml as well. *) + Ast.TY_str -> trans_log_str a + | Ast.TY_int | Ast.TY_uint | Ast.TY_bool | Ast.TY_char + | Ast.TY_mach (TY_u8) | Ast.TY_mach (TY_u16) + | Ast.TY_mach (TY_u32) | Ast.TY_mach (TY_i8) + | Ast.TY_mach (TY_i16) | Ast.TY_mach (TY_i32) -> + trans_log_int a + | _ -> Semant.bugi sem_cx head.id + "unimplemented logging type" end; trans_tail () diff --git a/src/boot/me/alias.ml b/src/boot/me/alias.ml index 25d4ed04..2c507335 100644 --- a/src/boot/me/alias.ml +++ b/src/boot/me/alias.ml @@ -29,7 +29,7 @@ let alias_analysis_visitor let alias_atom at = match at with Ast.ATOM_lval lv -> alias lv - | _ -> err None "aliasing literal" + | _ -> () (* Aliasing a literal is harmless, if weird. *) in let alias_call_args dst callee args = @@ -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 b7fdf309..5fd8638f 100644 --- a/src/boot/me/dwarf.ml +++ b/src/boot/me/dwarf.ml @@ -1210,6 +1210,8 @@ let (abbrev_typedef:abbrev) = (DW_TAG_typedef, DW_CHILDREN_yes, [| (DW_AT_name, DW_FORM_string); + (DW_AT_mutable, DW_FORM_flag); + (DW_AT_pure, DW_FORM_flag); (DW_AT_type, DW_FORM_ref_addr) |]) ;; @@ -1307,56 +1309,66 @@ let (abbrev_alias_slot:abbrev) = (DW_TAG_reference_type, DW_CHILDREN_no, [| (DW_AT_type, DW_FORM_ref_addr); - (DW_AT_mutable, DW_FORM_flag); |]) ;; -let (abbrev_exterior_slot:abbrev) = - (DW_TAG_reference_type, DW_CHILDREN_no, +(* 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_box_type:abbrev) = + (DW_TAG_pointer_type, DW_CHILDREN_no, + [| + (DW_AT_type, DW_FORM_ref_addr); (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 +1553,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_local -> + ref_type_die (slot_ty slot) | Ast.MODE_alias -> let fix = new_fixup "alias DIE" in @@ -1575,8 +1562,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 +1693,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 +1887,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 +1953,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 +2015,40 @@ let dwarf_visitor ref_addr_for_fix (Stack.top iso_stack).(i) in + let box_type t = + let fix = new_fixup "box DIE" in + let body_off = + word_sz_int * Abi.box_rc_slot_field_body + in + emit_die (DEF (fix, SEQ [| + uleb (get_abbrev_code abbrev_box_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 a box 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 +2069,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 +2078,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_box t -> box_type t | _ -> bug () "unimplemented dwarf encoding for type %a" Ast.sprintf_ty ty @@ -2308,6 +2321,7 @@ let dwarf_visitor let emit_typedef_die (id:Ast.ident) + (e:Ast.effect) (ty:Ast.ty) : unit = let abbrev_code = get_abbrev_code abbrev_typedef in @@ -2316,6 +2330,7 @@ let dwarf_visitor uleb abbrev_code; (* DW_AT_name: DW_FORM_string *) ZSTRING id; + encode_effect e; (* DW_AT_type: DW_FORM_ref_addr *) (ref_type_die ty); |]) @@ -2377,13 +2392,13 @@ let dwarf_visitor (Hashtbl.find cx.ctxt_fn_fixups item.id); emit_type_param_decl_dies item.node.Ast.decl_params; end - | Ast.MOD_ITEM_type _ -> + | Ast.MOD_ITEM_type (e, _) -> begin log cx "walking typedef '%s' with %d type params" (path_name()) (Array.length item.node.Ast.decl_params); emit_typedef_die - id (Hashtbl.find cx.ctxt_all_type_items item.id); + id e (Hashtbl.find cx.ctxt_all_type_items item.id); emit_type_param_decl_dies item.node.Ast.decl_params; end | _ -> () @@ -2452,7 +2467,7 @@ let dwarf_visitor then get_abbrev_code abbrev_formal else get_abbrev_code abbrev_variable in - let resolved_slot = referent_to_slot cx s.id in + let resolved_slot = get_slot cx s.id in let emit_var_die slot_loc = let var_die = SEQ [| @@ -2893,7 +2908,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 +2918,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_box (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 +2975,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 +3011,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_mode = Ast.MODE_local; Ast.slot_ty = Some ty } and get_referenced_ty die = @@ -3094,9 +3104,10 @@ let rec extract_mod_items let die = Hashtbl.find dies i in match die.die_tag with DW_TAG_typedef -> + let effect = get_effect die in let ident = get_name die in let ty = get_referenced_ty die in - let tyi = Ast.MOD_ITEM_type ty in + let tyi = Ast.MOD_ITEM_type (effect, ty) in let (params, islots) = get_formals die in assert ((Array.length islots) = 0); htab_put mis ident (decl params tyi) diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml index ad9a4cb3..795f1990 100644 --- a/src/boot/me/effect.ml +++ b/src/boot/me/effect.ml @@ -33,12 +33,23 @@ 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 _ = + iflog cx + (fun _ -> log cx "checking write to lval #%d = %a" + (int_of_node (lval_base_id dst)) Ast.sprintf_lval dst) + in + 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 +57,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 @@ -144,15 +155,14 @@ let function_effect_propagation_visitor | Ast.STMT_call (_, fn, _) -> let lower_to_callee_ty t = - match t with + match simplified_ty t with Ast.TY_fn (_, taux) -> lower_to s taux.Ast.fn_effect; | _ -> bug () "non-fn callee" in if lval_is_slot cx fn then - let t = lval_slot cx fn in - lower_to_callee_ty (slot_ty t) + lower_to_callee_ty (lval_ty cx fn) else begin let item = lval_item cx fn in diff --git a/src/boot/me/layout.ml b/src/boot/me/layout.ml index 6c4567fd..365acbf9 100644 --- a/src/boot/me/layout.ml +++ b/src/boot/me/layout.ml @@ -140,7 +140,7 @@ let layout_visitor (slots:node_id array) : unit = let accum (off,align) id : (size * size) = - let slot = referent_to_slot cx id in + let slot = get_slot cx id in let rt = slot_referent_type cx.ctxt_abi slot in let (elt_size, elt_align) = rty_layout rt in if vregs_ok @@ -221,7 +221,7 @@ let layout_visitor let offset = let word_sz = cx.ctxt_abi.Abi.abi_word_sz in let word_n (n:int) = Int64.mul word_sz (Int64.of_int n) in - SIZE_fixed (word_n (Abi.exterior_rc_slot_field_body + SIZE_fixed (word_n (Abi.box_rc_slot_field_body + 1 (* the state tydesc. *))) in log cx "laying out object-state for node #%d at offset %s" @@ -262,7 +262,7 @@ let layout_visitor *) let glue_callsz = - let word = interior_slot Ast.TY_int in + let word = local_slot Ast.TY_int in let glue_fn = mk_simple_ty_fn (Array.init Abi.worst_case_glue_call_args (fun _ -> word)) diff --git a/src/boot/me/resolve.ml b/src/boot/me/resolve.ml index cafb69b1..641df884 100644 --- a/src/boot/me/resolve.ml +++ b/src/boot/me/resolve.ml @@ -270,7 +270,7 @@ let type_reference_and_tag_extracting_visitor let visit_mod_item_pre id params item = begin match item.node.Ast.decl_item with - Ast.MOD_ITEM_type ty -> + Ast.MOD_ITEM_type (_, ty) -> begin log cx "extracting references for type node %d" (int_of_node item.id); @@ -395,7 +395,7 @@ and lookup_type_by_name | Some (scopes', id) -> let ty, params = match htab_search cx.ctxt_all_defns id with - Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type t; + Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type (_, t); Ast.decl_params = params }) -> (t, Array.map (fun p -> p.node) params) | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj ob; @@ -543,7 +543,7 @@ let type_resolving_visitor begin try match item.node.Ast.decl_item with - Ast.MOD_ITEM_type ty -> + Ast.MOD_ITEM_type (_, ty) -> let ty = resolve_type cx (!scopes) recursive_tag_groups all_tags empty_recur_info ty @@ -570,7 +570,7 @@ let type_resolving_visitor header_slots in let output_slot = - interior_slot (ty_iso_of cx recursive_tag_groups + local_slot (ty_iso_of cx recursive_tag_groups all_tags nid) in let ty = @@ -636,7 +636,8 @@ let type_resolving_visitor Ast.LVAL_ext (base, ext) -> let ext = match ext with - Ast.COMP_named (Ast.COMP_ident _) + Ast.COMP_deref + | Ast.COMP_named (Ast.COMP_ident _) | Ast.COMP_named (Ast.COMP_idx _) | Ast.COMP_atom (Ast.ATOM_literal _) -> ext | Ast.COMP_atom (Ast.ATOM_lval lv) -> @@ -837,7 +838,7 @@ let resolve_recursion then begin match Hashtbl.find cx.ctxt_all_defns id with DEFN_item - { Ast.decl_item = Ast.MOD_ITEM_type (Ast.TY_tag _) } -> + { Ast.decl_item = Ast.MOD_ITEM_type (_, (Ast.TY_tag _)) } -> log cx "type %d is a recursive tag" (int_of_node id); Hashtbl.replace recursive_tag_types id () | _ -> diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index 95a5c792..8d2ed8ac 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -21,10 +21,10 @@ type glue = | GLUE_exit_main_task | GLUE_exit_task | GLUE_copy of Ast.ty (* One-level copy. *) - | GLUE_drop of Ast.ty (* De-initialize interior memory. *) - | GLUE_free of Ast.ty (* Drop body + free() exterior ptr. *) - | GLUE_sever of Ast.ty (* Null all exterior state slots. *) - | GLUE_mark of Ast.ty (* Mark all exterior state slots. *) + | GLUE_drop of Ast.ty (* De-initialize local memory. *) + | GLUE_free of Ast.ty (* Drop body + free() box ptr. *) + | GLUE_sever of Ast.ty (* Null all box state slots. *) + | GLUE_mark of Ast.ty (* Mark all box state slots. *) | GLUE_clone of Ast.ty (* Deep copy. *) | GLUE_compare of Ast.ty | GLUE_hash of Ast.ty @@ -91,6 +91,7 @@ type ctxt = ctxt_slot_is_arg: (node_id,unit) Hashtbl.t; ctxt_slot_keys: (node_id,Ast.slot_key) Hashtbl.t; ctxt_node_referenced: (node_id, unit) Hashtbl.t; + ctxt_auto_deref_lval: (node_id, bool) Hashtbl.t; ctxt_all_item_names: (node_id,Ast.name) Hashtbl.t; ctxt_all_item_types: (node_id,Ast.ty) Hashtbl.t; ctxt_all_lval_types: (node_id,Ast.ty) Hashtbl.t; @@ -181,6 +182,7 @@ let new_ctxt sess abi crate = ctxt_slot_is_arg = Hashtbl.create 0; ctxt_slot_keys = Hashtbl.create 0; ctxt_node_referenced = Hashtbl.create 0; + ctxt_auto_deref_lval = Hashtbl.create 0; ctxt_all_item_names = Hashtbl.create 0; ctxt_all_item_types = Hashtbl.create 0; ctxt_all_lval_types = Hashtbl.create 0; @@ -306,18 +308,32 @@ let referent_is_item (cx:ctxt) (id:node_id) : bool = | _ -> false ;; -(* coerce an lval definition id to a slot *) -let referent_to_slot (cx:ctxt) (id:node_id) : Ast.slot = - match Hashtbl.find cx.ctxt_all_defns id with - DEFN_slot slot -> slot - | _ -> bugi cx id "unknown slot" +let rec lval_base_id (lv:Ast.lval) : node_id = + match lv with + Ast.LVAL_base nbi -> nbi.id + | Ast.LVAL_ext (lv, _) -> lval_base_id lv +;; + +let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl = + match htab_search cx.ctxt_all_defns node with + Some (DEFN_item item) -> item + | Some _ -> bugi cx node "defn is not an item" + | None -> bugi cx node "missing defn" +;; + +let get_slot (cx:ctxt) (node:node_id) : Ast.slot = + match htab_search cx.ctxt_all_defns node with + Some (DEFN_slot slot) -> slot + | Some _ -> bugi cx node "defn is not a slot" + | None -> bugi cx node "missing defn" ;; (* coerce an lval reference id to its definition slot *) -let lval_to_slot (cx:ctxt) (id:node_id) : Ast.slot = - match resolve_lval_id cx id with - DEFN_slot slot -> slot - | _ -> bugi cx id "unknown slot" +let lval_base_to_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot identified = + let lid = lval_base_id lval in + let rid = lval_to_referent cx lid in + let slot = get_slot cx rid in + { node = slot; id = rid } ;; let get_stmt_depth (cx:ctxt) (id:node_id) : int = @@ -534,22 +550,6 @@ let rec lval_to_name (lv:Ast.lval) : Ast.name = Ast.NAME_ext (lval_to_name lv, comp) ;; -let rec lval_base_id (lv:Ast.lval) : node_id = - match lv with - Ast.LVAL_base nbi -> nbi.id - | Ast.LVAL_ext (lv, _) -> lval_base_id lv -;; - -let rec lval_base_slot (cx:ctxt) (lv:Ast.lval) : node_id option = - match lv with - Ast.LVAL_base nbi -> - let referent = lval_to_referent cx nbi.id in - if referent_is_slot cx referent - then Some referent - else None - | Ast.LVAL_ext (lv, _) -> lval_base_slot cx lv -;; - let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array = match lv with Ast.LVAL_base nbi -> @@ -557,7 +557,8 @@ let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array = if referent_is_slot cx referent then [| referent |] else [| |] - | Ast.LVAL_ext (lv, Ast.COMP_named _) -> lval_slots cx lv + | Ast.LVAL_ext (lv, Ast.COMP_named _) + | Ast.LVAL_ext (lv, Ast.COMP_deref) -> lval_slots cx lv | Ast.LVAL_ext (lv, Ast.COMP_atom a) -> Array.append (lval_slots cx lv) (atom_slots cx a) @@ -582,15 +583,13 @@ let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array = ;; let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array = - Array.concat (List.map - (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)) ;; @@ -605,33 +604,47 @@ 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 local_slot_full mut ty : Ast.slot = + let ty = + if mut + then Ast.TY_mutable ty + else ty + in + { Ast.slot_mode = Ast.MODE_local; + Ast.slot_ty = Some ty } ;; -let exterior_slot_full mut ty : Ast.slot = - { Ast.slot_mode = Ast.MODE_exterior; - Ast.slot_mutable = mut; +let box_slot_full mut ty : Ast.slot = + let ty = + match ty with + Ast.TY_box _ -> ty + | _ -> Ast.TY_box ty + in + let ty = + if mut + then Ast.TY_mutable ty + else ty + in + { Ast.slot_mode = Ast.MODE_local; Ast.slot_ty = Some ty } ;; -let interior_slot ty : Ast.slot = interior_slot_full false ty +let local_slot ty : Ast.slot = local_slot_full false ty ;; -let exterior_slot ty : Ast.slot = exterior_slot_full false ty +let box_slot ty : Ast.slot = box_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; + (* Functions that correspond to local nodes in Ast.ty. *) + 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 +655,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 +672,32 @@ 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_box : '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_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_slots v))) + 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 +716,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 +739,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_box t -> f.ty_fold_box (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 +778,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_box = (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 +806,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 +824,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_box = (fun t -> id (Ast.TY_box t)); + ty_fold_mutable = (fun t -> id (Ast.TY_mutable t)); ty_fold_constrained = (fun (t, constrs) -> id (Ast.TY_constrained (t, constrs))) } ;; @@ -891,8 +926,9 @@ let associative_binary_op_ty_fold fn islots oslot in { base with + ty_fold_tys = (fun ts -> reduce (Array.to_list ts)); 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); @@ -906,6 +942,8 @@ let associative_binary_op_ty_fold reduce (List.map reduce_fn (htab_vals fns))); ty_fold_chan = (fun a -> a); ty_fold_port = (fun a -> a); + ty_fold_box = (fun a -> a); + ty_fold_mutable = (fun a -> a); ty_fold_constrained = (fun (a, _) -> a) } let ty_fold_bool_and (default:bool) : bool simple_ty_fold = @@ -957,13 +995,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 ;; @@ -1036,16 +1070,28 @@ let check_concrete params thing = else bug () "unhandled parametric binding" ;; +let rec strip_mutable_or_constrained_ty (t:Ast.ty) : Ast.ty = + match t with + Ast.TY_mutable t + | Ast.TY_constrained (t, _) -> strip_mutable_or_constrained_ty t + | _ -> t +;; + +let rec simplified_ty (t:Ast.ty) : Ast.ty = + match strip_mutable_or_constrained_ty t with + Ast.TY_box t -> simplified_ty t + | t -> t +;; -let project_type_to_slot +let rec 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,30 +1100,35 @@ 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_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)) -> + (Ast.TY_fn (Hashtbl.find fns id)) - | (Ast.TY_str, Ast.COMP_atom _) -> - interior_slot (Ast.TY_mach TY_u8) + | (Ast.TY_box t, Ast.COMP_deref) -> t - | (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) -> - interior_slot (Ast.TY_fn (Hashtbl.find fns id)) + (* Box, mutable and constrained are transparent to the + * other lval-ext forms: x.y and x.(y). + *) + | (Ast.TY_box t, _) + | (Ast.TY_mutable t, _) + | (Ast.TY_constrained (t, _), _) -> project_type t comp | (_,_) -> bug () - "unhandled form of lval-ext in Semant." - "project_slot: %a indexed by %a" - Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp -;; - - -(* NB: this will fail if lval is not a slot. *) -let rec lval_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot = - match lval with - Ast.LVAL_base nb -> lval_to_slot cx nb.id - | Ast.LVAL_ext (base, comp) -> - let base_ty = slot_ty (lval_slot cx base) in - project_type_to_slot base_ty comp + "project_ty: bad lval-ext: %s" + (match comp with + Ast.COMP_atom at -> + Printf.sprintf "%a.(%a)" + Ast.sprintf_ty base_ty + Ast.sprintf_atom at + | Ast.COMP_named nc -> + Printf.sprintf "%a.%a" + Ast.sprintf_ty base_ty + Ast.sprintf_name_component nc + | Ast.COMP_deref -> + Printf.sprintf "*(%a)" + Ast.sprintf_ty base_ty) ;; let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool = @@ -1107,8 +1158,8 @@ let rec lval_item (cx:ctxt) (lval:Ast.lval) : Ast.mod_item = | Ast.COMP_named (Ast.COMP_app (i, args)) -> (i, args) | _ -> bug () - "unhandled lval-component '%a' in Semant.lval_item" - Ast.sprintf_lval_component comp + "unhandled lval-component in '%a' in lval_item" + Ast.sprintf_lval lval in match htab_search items i with | Some sub when exports_permit view i -> @@ -1150,6 +1201,38 @@ let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool = | _ -> false ;; +(* + * FIXME: this function is a bad idea and exists only as a workaround + * for other logic that is even worse. Untangle. + *) +let rec project_lval_ty_from_slot (cx:ctxt) (lval:Ast.lval) : Ast.ty = + match lval with + Ast.LVAL_base nbi -> + let referent = lval_to_referent cx nbi.id in + if lval_is_slot cx lval + then slot_ty (get_slot cx referent) + else Hashtbl.find cx.ctxt_all_item_types nbi.id + | Ast.LVAL_ext (base, comp) -> + let base_ty = project_lval_ty_from_slot cx base in + project_type base_ty comp +;; + + +let lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty = + (* + FIXME: The correct definition of this function is just: + + Hashtbl.find cx.ctxt_all_lval_types (lval_base_id lval) + + However, since the typechecker is not presently handling + every stmt, we have a fallback mode to "pick out the slot + type and hope for the best". + *) + match htab_search cx.ctxt_all_lval_types (lval_base_id lval) with + Some t -> t + | None -> project_lval_ty_from_slot cx lval +;; + let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool = defn_is_static (resolve_lval cx lval) ;; @@ -1164,7 +1247,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 (simplified_ty (project_lval_ty_from_slot cx base)) with Ast.TY_obj _ -> true | _ -> false end @@ -1172,11 +1255,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 @@ -1236,7 +1314,7 @@ let ty_of_mod_item ((*inside*)_:bool) (item:Ast.mod_item) : Ast.ty = let tobj = Ast.TY_obj (ty_obj_of_obj ob) in let tsig = { Ast.sig_input_slots = arg_slots ob.Ast.obj_state; Ast.sig_input_constrs = ob.Ast.obj_constrs; - Ast.sig_output_slot = interior_slot tobj } + Ast.sig_output_slot = local_slot tobj } in (Ast.TY_fn (tsig, taux)) @@ -1246,7 +1324,7 @@ let ty_of_mod_item ((*inside*)_:bool) (item:Ast.mod_item) : Ast.ty = in let tsig = { Ast.sig_input_slots = tup_slots htup; Ast.sig_input_constrs = [| |]; - Ast.sig_output_slot = interior_slot (Ast.TY_tag ttag) } + Ast.sig_output_slot = local_slot (Ast.TY_tag ttag) } in (Ast.TY_fn (tsig, taux)) ;; @@ -1433,20 +1511,6 @@ let unreferenced_required_item_ignoring_visitor type resolved = ((scope list * node_id) option) ;; -let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl = - match htab_search cx.ctxt_all_defns node with - Some (DEFN_item item) -> item - | Some _ -> bugi cx node "defn is not an item" - | None -> bugi cx node "missing defn" -;; - -let get_slot (cx:ctxt) (node:node_id) : Ast.slot = - match htab_search cx.ctxt_all_defns node with - Some (DEFN_slot slot) -> slot - | Some _ -> bugi cx node "defn is not a slot" - | None -> bugi cx node "missing defn" -;; - let get_mod_item (cx:ctxt) (node:node_id) @@ -1741,7 +1805,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 +1866,11 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty = | Ast.TY_native _ -> ptr + | Ast.TY_box 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,17 +1878,12 @@ 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_local _ -> rty | Ast.MODE_alias _ -> sp rty ;; @@ -1886,7 +1950,7 @@ let call_args_referent_type Il.ScalarTy (Il.AddrTy Il.OpaqueTy) |] in - match callee_ty with + match simplified_ty callee_ty with Ast.TY_fn (tsig, taux) -> call_args_referent_type_full cx.ctxt_abi @@ -1896,7 +1960,9 @@ let call_args_referent_type (if taux.Ast.fn_is_iter then (iterator_arg_rtys()) else [||]) indirect_arg_rtys - | _ -> bug cx "Semant.call_args_referent_type on non-callable type" + | _ -> bug cx + "Semant.call_args_referent_type on non-callable type %a" + Ast.sprintf_ty callee_ty ;; let indirect_call_args_referent_type @@ -1935,19 +2001,22 @@ let slot_sz (abi:Abi.abi) (s:Ast.slot) : int64 = ;; let word_slot (abi:Abi.abi) : Ast.slot = - interior_slot (Ast.TY_mach abi.Abi.abi_word_ty) + local_slot (Ast.TY_mach abi.Abi.abi_word_ty) ;; 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 @@ -1977,7 +2046,7 @@ let mk_simple_ty_fn (arg_slots:Ast.slot array) : Ast.ty = (* In some cases we don't care what the output slot is. *) - let out_slot = interior_slot Ast.TY_nil in + let out_slot = local_slot Ast.TY_nil in mk_ty_fn out_slot arg_slots ;; @@ -1985,7 +2054,7 @@ let mk_simple_ty_iter (arg_slots:Ast.slot array) : Ast.ty = (* In some cases we don't care what the output slot is. *) - let out_slot = interior_slot Ast.TY_nil in + let out_slot = local_slot Ast.TY_nil in mk_ty_fn_or_iter out_slot arg_slots true ;; @@ -2002,12 +2071,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_local -> "") ^ ty in let num n = (string_of_int n) ^ "$" in @@ -2080,6 +2147,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_box = (fun t -> "B" ^ 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 8ecc743e..abeff66e 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 = @@ -445,7 +446,7 @@ let trans_visitor in let slot_id_referent_type (slot_id:node_id) : Il.referent_ty = - slot_referent_type abi (referent_to_slot cx slot_id) + slot_referent_type abi (get_slot cx slot_id) in let caller_args_cell (args_rty:Il.referent_ty) : Il.cell = @@ -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) @@ -887,18 +882,29 @@ let trans_visitor in let rec trans_slot_lval_ext + (initializing:bool) (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 + (* + * All lval components aside from explicit-deref just auto-deref + * through all boxes to find their indexable referent. + *) + let base_ty = strip_mutable_or_constrained_ty base_ty in + let (cell, base_ty) = + if comp = Ast.COMP_deref + then (cell, base_ty) + else deref_ty DEREF_all_boxes initializing cell base_ty in match (base_ty, comp) with @@ -911,19 +917,21 @@ 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)) + | (Ast.TY_box _, Ast.COMP_deref) -> + deref_ty DEREF_one_box initializing cell base_ty | _ -> bug () "unhandled form of lval_ext in trans_slot_lval_ext" @@ -938,7 +946,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 +958,35 @@ 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 - - | 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) + trans_slot_lval_ext initializing base_ty base_cell comp + + | Ast.LVAL_base nbi -> + let sloti = lval_base_to_slot cx lv in + let cell = cell_of_block_slot sloti.id in + let ty = slot_ty sloti.node in + let cell = deref_slot initializing cell sloti.node in + let dctrl = + (* If this fails, type didn't visit the lval, and we + * don't know whether to auto-deref its base. Crashing + * here is best. Compiler bug. + *) + match htab_search cx.ctxt_auto_deref_lval nbi.id with + None -> + bugi cx nbi.id + "Lval without auto-deref info; bad typecheck?" + | Some true -> DEREF_all_boxes + | Some false -> DEREF_none + in + deref_ty dctrl initializing cell ty in iflog begin @@ -976,7 +996,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 +1014,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 @@ -1228,11 +1248,10 @@ let trans_visitor fun _ -> annotate (Fmt.fmt_to_str Ast.fmt_atom atom) end; - match atom with Ast.ATOM_lval lv -> - let (cell, slot) = trans_lval lv in - Il.Cell (deref_slot false cell slot) + let (cell, ty) = trans_lval lv in + Il.Cell (fst (deref_ty DEREF_none false cell ty)) | Ast.ATOM_literal lit -> trans_lit lit.node @@ -1302,7 +1321,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 +1412,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 +1576,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 +1589,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 @@ -1585,31 +1604,31 @@ let trans_visitor : fixup = let g = GLUE_free ty in let inner _ (args:Il.cell) = - (* - * Free-glue assumes it's called with a pointer to an - * exterior allocation with normal exterior layout. It's - * just a way to move drop+free out of leaf code. + (* Free-glue assumes it's called with a pointer to a box allocation with + * normal box layout. It's just a way to move drop+free out of leaf + * code. *) let ty_params = deref (get_element_ptr args 0) in let cell = get_element_ptr args 1 in let (body_mem, _) = need_mem_cell (get_element_ptr_dyn ty_params (deref cell) - Abi.exterior_rc_slot_field_body) + Abi.box_rc_slot_field_body) in + let body_ty = simplified_ty ty in let vr = next_vreg_cell Il.voidptr_t in lea vr body_mem; - note_drop_step ty "in free-glue, calling drop-glue on body"; + note_drop_step body_ty "in free-glue, calling drop-glue on body"; trace_word cx.ctxt_sess.Session.sess_trace_drop vr; trans_call_simple_static_glue - (get_drop_glue ty curr_iso) ty_params vr; + (get_drop_glue body_ty curr_iso) ty_params vr; note_drop_step ty "back in free-glue, calling free"; trans_free cell is_gc; trace_str cx.ctxt_sess.Session.sess_trace_drop "free-glue complete"; in let ty_params_ptr = ty_params_covering ty in - let fty = mk_simple_ty_fn [| ty_params_ptr; exterior_slot ty |] in + let fty = mk_simple_ty_fn [| ty_params_ptr; box_slot ty |] in get_typed_mem_glue g fty inner @@ -1621,7 +1640,9 @@ 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 + note_gc_step ty "in sever-glue, severing"; + sever_ty ty_params (deref cell) ty curr_iso; + note_gc_step ty "in sever-glue complete"; 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 +1657,9 @@ 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 + note_gc_step ty "in mark-glue, marking"; + mark_ty ty_params (deref cell) ty curr_iso; + note_gc_step ty "mark-glue complete"; in let ty_params_ptr = ty_params_covering ty in let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in @@ -1653,12 +1676,12 @@ 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 = mk_ty_fn - (interior_slot ty) (* dst *) + (local_slot ty) (* dst *) [| ty_params_ptr; alias_slot ty; (* src *) @@ -1677,12 +1700,12 @@ 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 + trans_copy_ty ty_params false dst ty src ty curr_iso in let ty_params_ptr = ty_params_covering ty in let fty = mk_ty_fn - (interior_slot ty) + (local_slot ty) [| ty_params_ptr; alias_slot ty |] in get_typed_mem_glue g fty inner @@ -1888,12 +1911,12 @@ let trans_visitor in match expr with Ast.EXPR_binary (binop, a, b) -> - assert (is_prim_type (atom_type cx a)); - assert (is_prim_type (atom_type cx b)); + assert (is_prim_type (simplified_ty (atom_type cx a))); + assert (is_prim_type (simplified_ty (atom_type cx b))); trans_binary binop (trans_atom a) (trans_atom b) | Ast.EXPR_unary (unop, a) -> - assert (is_prim_type (atom_type cx a)); + assert (is_prim_type (simplified_ty (atom_type cx a))); let src = trans_atom a in let bits = Il.operand_bits word_bits src in let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in @@ -1904,6 +1927,7 @@ let trans_visitor | Ast.UNOP_cast t -> let t = Hashtbl.find cx.ctxt_all_cast_types t.id in let at = atom_type cx a in + let (t, at) = (simplified_ty t, simplified_ty at) in if (type_is_2s_complement at) && (type_is_2s_complement t) then @@ -2043,7 +2067,7 @@ let trans_visitor List.iter patch fwd_jmps and trans_check_expr (id:node_id) (e:Ast.expr) : unit = - match expr_type cx e with + match simplified_ty (expr_type cx e) with Ast.TY_bool -> let fwd_jmps = trans_cond false e in trans_cond_fail (Fmt.fmt_to_str Ast.fmt_expr e) fwd_jmps @@ -2096,8 +2120,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 @@ -2120,7 +2144,7 @@ let trans_visitor trans_void_upcall "upcall_kill" [| Il.Cell task |] (* - * A vec is implicitly exterior: every slot vec[T] is 1 word and + * A vec is implicitly boxed: every slot vec[T] is 1 word and * points to a refcounted structure. That structure has 3 words with * defined meaning at the beginning; data follows the header. * @@ -2134,19 +2158,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,18 +2178,35 @@ 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); + + and trans_init_box (dst:Ast.lval) (src:Ast.atom) : unit = + let src_op = trans_atom src in + let src_cell = Il.Mem (force_to_mem src_op) in + let src_ty = simplified_ty (atom_type cx src) in + let dst_sloti = lval_base_to_slot cx dst in + let dst_cell = cell_of_block_slot dst_sloti.id in + let dst_cell = deref_slot true dst_cell dst_sloti.node in + let dst_ty = slot_ty dst_sloti.node in + let (dst_cell, dst_ty) = + deref_ty DEREF_one_box true dst_cell dst_ty + in + let _ = assert (dst_ty = src_ty) in + trans_copy_ty (get_ty_params_of_current_frame()) true + dst_cell dst_ty src_cell src_ty None + + and get_dynamic_tydesc (idopt:node_id option) (t:Ast.ty) : Il.cell = let td = next_vreg_cell Il.voidptr_t in let root_desc = @@ -2213,44 +2253,40 @@ let trans_visitor (ty_align abi ty)) (tydesc_rty abi)) - and exterior_ctrl_cell (cell:Il.cell) (off:int) : Il.cell = - let (mem, _) = need_mem_cell (deref_imm cell (word_n off)) in - word_at mem - - and exterior_rc_cell (cell:Il.cell) : Il.cell = - exterior_ctrl_cell cell Abi.exterior_rc_slot_field_refcnt + and box_rc_cell (cell:Il.cell) : Il.cell = + get_element_ptr (deref cell) Abi.box_rc_slot_field_refcnt - and exterior_allocation_size - (slot:Ast.slot) + and box_allocation_size + (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" + | MEM_rc_struct -> word_n Abi.box_rc_header_size + | MEM_interior -> bug () "box_allocation_size of MEM_interior" in - let t = slot_ty slot in + let ty = simplified_ty ty 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 +2294,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 +2307,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,29 +2320,29 @@ 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. *) - check_exterior_rty src_cell; - check_exterior_rty dst_cell; + check_box_rty src_cell; + check_box_rty dst_cell; if dst_cell = src_cell then begin @@ -2323,9 +2359,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 +2373,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 +2388,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 box substructure. *) - drop_slot ty_params binding - (exterior_slot Ast.TY_int) curr_iso; + drop_ty ty_params binding (Ast.TY_box 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,139 +2471,143 @@ 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 -> + + note_drop_step ty "in box-drop path of drop_ty"; + + let _ = check_box_rty cell in + let null_jmp = null_check cell in + let rc = box_rc_cell cell in + let j = drop_refcount_and_cmp rc in + + (* FIXME (issue #25): check to see that the box has + * further box 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 -> + note_drop_step ty "in structured-interior path of drop_ty"; + iter_ty_parts ty_params cell ty + (drop_ty ty_params) curr_iso + + | MEM_interior -> + note_drop_step ty "in simple-interior path of drop_ty"; + (* 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) - (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 - - 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 _ = note_gc_step ty "severing" in + let sever_box c = + let _ = check_box_rty c in + let null_jmp = null_check c in + let rc = box_rc_cell c in + let _ = note_gc_step ty "severing GC cell" in + emit (Il.binary Il.SUB rc (Il.Cell rc) one); + mov c zero; + patch null_jmp + in + + match strip_mutable_or_constrained_ty ty with + Ast.TY_fn _ + | Ast.TY_obj _ -> + if type_has_state ty + then + let binding = get_element_ptr cell Abi.binding_field_binding in + sever_box binding; + + | _ -> + match ty_mem_ctrl ty with + MEM_gc -> + sever_box cell + + | 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) - (curr_iso:Ast.ty_iso option) - : unit = - match ty with - Ast.TY_chan _ -> - trans_upcall "upcall_clone_chan" dst - [| (Il.Cell clone_task); (Il.Cell src) |] - | Ast.TY_task - | Ast.TY_port _ - | _ when type_has_state ty - -> bug () "cloning mutable type" - | _ when i64_le (ty_sz abi ty) word_sz - -> mov dst (Il.Cell src) - | Ast.TY_fn _ - | Ast.TY_obj _ -> () - | _ -> - iter_ty_slots_full ty_params ty dst src - (clone_slot ty_params clone_task) curr_iso - - and copy_ty - (ty_params:Il.cell) (ty:Ast.ty) - (dst:Il.cell) - (src:Il.cell) (curr_iso:Ast.ty_iso option) : unit = - iflog (fun _ -> - annotate ("copy_ty: referent data of type " ^ - (Fmt.fmt_to_str Ast.fmt_ty ty))); - match ty with - Ast.TY_nil - | Ast.TY_bool - | Ast.TY_mach _ - | Ast.TY_int - | Ast.TY_uint - | Ast.TY_native _ - | Ast.TY_type - | Ast.TY_char -> - iflog - (fun _ -> annotate - (Printf.sprintf "copy_ty: simple mov (%Ld byte scalar)" - (ty_sz abi ty))); - mov dst (Il.Cell src) - - | Ast.TY_param (i, _) -> - iflog - (fun _ -> annotate - (Printf.sprintf "copy_ty: parametric copy %#d" i)); - aliasing false src - begin - fun src -> - let td = get_ty_param ty_params i in - let ty_params_ptr = get_tydesc_params ty_params td in - trans_call_dynamic_glue - td Abi.tydesc_field_copy_glue - (Some dst) [| ty_params_ptr; src; |] - end - - | Ast.TY_fn _ - | Ast.TY_obj _ -> - begin - let src_item = get_element_ptr src Abi.binding_field_item in - let dst_item = get_element_ptr dst Abi.binding_field_item in - let src_binding = get_element_ptr src Abi.binding_field_binding in - let dst_binding = get_element_ptr dst Abi.binding_field_binding in - mov dst_item (Il.Cell src_item); - let null_jmp = null_check src_binding in - (* Copy if we have a src binding. *) - (* FIXME (issue #58): this is completely wrong, call - * through to the binding's self-copy fptr. For now - * this only works by accident. - *) - trans_copy_slot ty_params true - dst_binding (exterior_slot Ast.TY_int) - src_binding (exterior_slot Ast.TY_int) - curr_iso; - patch null_jmp - end - - | _ -> - iter_ty_slots_full ty_params ty dst src - (fun dst src slot curr_iso -> - trans_copy_slot ty_params true - dst slot src slot curr_iso) - curr_iso + let ty = strip_mutable_or_constrained_ty ty in + match ty with + Ast.TY_chan _ -> + trans_upcall "upcall_clone_chan" dst + [| (Il.Cell clone_task); (Il.Cell src) |] + | Ast.TY_task + | Ast.TY_port _ + | _ when type_has_state ty + -> bug () "cloning state type" + | _ when i64_le (ty_sz abi ty) word_sz + -> mov dst (Il.Cell src) + | Ast.TY_fn _ + | Ast.TY_obj _ -> () + | Ast.TY_box 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_parts_full ty_params dst src ty + (clone_ty ty_params clone_task) curr_iso and free_ty (is_gc:bool) @@ -2591,8 +2621,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 @@ -2601,10 +2631,11 @@ let trans_visitor (curr_iso:Ast.ty_iso option) (t:Ast.ty) : Ast.ty = - match (curr_iso, t) with - (Some iso, Ast.TY_idx n) -> - Ast.TY_iso { iso with Ast.iso_index = n } - | (None, Ast.TY_idx _) -> + match (curr_iso, strip_mutable_or_constrained_ty t) with + (_, Ast.TY_idx _) -> bug () "traversing raw TY_idx (non-box )edge" + | (Some iso, Ast.TY_box (Ast.TY_idx n)) -> + Ast.TY_box (Ast.TY_iso { iso with Ast.iso_index = n }) + | (None, Ast.TY_box (Ast.TY_idx _)) -> bug () "TY_idx outside TY_iso" | _ -> t @@ -2612,78 +2643,50 @@ let trans_visitor (t:Ast.ty) (curr_iso:Ast.ty_iso option) : Ast.ty_iso option = - match t with - Ast.TY_iso tiso -> Some tiso + match strip_mutable_or_constrained_ty t with + Ast.TY_box (Ast.TY_iso tiso) -> Some tiso | _ -> curr_iso - and sever_slot + and mark_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 + (* Marking goes straight through aliases. Reachable means reachable. *) + mark_ty ty_params (deref_slot false cell slot) (slot_ty slot) curr_iso - | 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 + and mark_ty (ty_params:Il.cell) (cell:Il.cell) - (slot:Ast.slot) + (ty:Ast.ty) (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 + 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 box parts marking outgoing links. *) + let (body_mem, _) = + need_mem_cell + (get_element_ptr (deref cell) + Abi.box_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)))); + annotate ("mark interior memory " ^ + (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 @@ -2695,39 +2698,15 @@ let trans_visitor | _ -> () - and check_exterior_rty cell = + and check_box_rty cell = match cell with Il.Reg (_, Il.AddrTy (Il.StructTy fields)) | Il.Mem (_, Il.ScalarTy (Il.AddrTy (Il.StructTy fields))) when (((Array.length fields) > 0) && (fields.(0) = word_rty)) -> () | _ -> bug () - "expected plausibly-exterior cell, got %s" + "expected plausibly-box 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,104 +2734,101 @@ 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_local -> + drop_ty ty_params cell (slot_ty slot) curr_iso and note_drop_step ty step = if cx.ctxt_sess.Session.sess_trace_drop || cx.ctxt_sess.Session.sess_log_trans then - let slotstr = Fmt.fmt_to_str Ast.fmt_ty ty in - let str = step ^ " " ^ slotstr in + let mctrl_str = + 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 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_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_box (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 + iflog (fun _ -> annotate "init box: malloc"); + let sz = box_allocation_size ty in trans_malloc cell sz ctrl; - iflog (fun _ -> annotate "init exterior: load refcount"); - let rc = exterior_rc_cell cell in + iflog (fun _ -> annotate "init box: load refcount"); + let rc = box_rc_cell cell in mov rc one - | MEM_interior -> bug () "init_exterior_slot of MEM_interior" + | MEM_interior -> bug () "init_box of MEM_interior" + + and deref_ty + (dctrl:deref_ctrl) + (initializing:bool) + (cell:Il.cell) + (ty:Ast.ty) + : (Il.cell * Ast.ty) = + match (ty, dctrl) with + + | (Ast.TY_mutable ty, _) + | (Ast.TY_constrained (ty, _), _) -> + deref_ty dctrl initializing cell ty + + | (Ast.TY_box ty', DEREF_one_box) + | (Ast.TY_box ty', DEREF_all_boxes) -> + check_box_rty cell; + if initializing + then init_box cell ty; + let cell = + get_element_ptr_dyn_in_current_frame + (deref cell) + (Abi.box_rc_slot_field_body) + in + let inner_dctrl = + if dctrl = DEREF_one_box + then DEREF_none + else DEREF_all_boxes + in + (* Possibly deref recursively. *) + deref_ty inner_dctrl initializing cell ty' + + | _ -> (cell, ty) + and deref_slot (initializing:bool) @@ -2860,17 +2836,9 @@ let trans_visitor (slot:Ast.slot) : Il.cell = match slot.Ast.slot_mode with - Ast.MODE_interior _ -> + Ast.MODE_local -> 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,57 +2849,61 @@ 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 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 = iflog begin fun _ -> + log cx "trans_copy_ty"; + log cx " dst ty %a, src ty %a" + Ast.sprintf_ty dst_ty Ast.sprintf_ty src_ty; + log cx " dst cell %s, src cell %s" + (cell_str dst) (cell_str src); 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 (simplified_ty src_ty = simplified_ty dst_ty); + match (ty_mem_ctrl src_ty, ty_mem_ctrl dst_ty) with | (MEM_rc_opaque, MEM_rc_opaque) | (MEM_gc, MEM_gc) | (MEM_rc_struct, MEM_rc_struct) -> (* Lightweight copy: twiddle refcounts, move pointer. *) anno "refcounted light"; - add_to (exterior_rc_cell src) one; + add_to (box_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 +2932,116 @@ 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); - iflog (fun _ -> - annotate ("heavy copy: slot preparation")); + let src_ty = strip_mutable_or_constrained_ty src_ty in + let dst_ty = strip_mutable_or_constrained_ty dst_ty in + let dst_ty = maybe_iso curr_iso dst_ty in + let src_ty = maybe_iso curr_iso src_ty in + + iflog + begin + fun _ -> + log cx "trans_copy_ty_heavy"; + log cx " dst ty %a, src ty %a" + Ast.sprintf_ty dst_ty Ast.sprintf_ty src_ty; + log cx " dst cell %s, src cell %s" + (cell_str dst) (cell_str src); + end; + + assert (src_ty = dst_ty); + iflog (fun _ -> + annotate ("heavy copy: slot preparation")); + + let curr_iso = maybe_enter_iso dst_ty curr_iso in + let (dst, ty) = deref_ty DEREF_none initializing dst dst_ty in + let (src, _) = deref_ty DEREF_none false src src_ty in + assert (ty = dst_ty); + match ty with + Ast.TY_nil + | Ast.TY_bool + | Ast.TY_mach _ + | Ast.TY_int + | Ast.TY_uint + | Ast.TY_native _ + | Ast.TY_type + | Ast.TY_char -> + iflog + (fun _ -> annotate + (Printf.sprintf "copy_ty: simple mov (%Ld byte scalar)" + (ty_sz abi ty))); + mov dst (Il.Cell src) + + | Ast.TY_param (i, _) -> + iflog + (fun _ -> annotate + (Printf.sprintf "copy_ty: parametric copy %#d" i)); + aliasing false src + begin + fun src -> + let td = get_ty_param ty_params i in + let ty_params_ptr = get_tydesc_params ty_params td in + trans_call_dynamic_glue + td Abi.tydesc_field_copy_glue + (Some dst) [| ty_params_ptr; src; |] + end + + | Ast.TY_fn _ + | Ast.TY_obj _ -> + begin + let src_item = get_element_ptr src Abi.binding_field_item in + let dst_item = get_element_ptr dst Abi.binding_field_item in + let src_binding = + get_element_ptr src Abi.binding_field_binding + in + let dst_binding = + get_element_ptr dst Abi.binding_field_binding + in + mov dst_item (Il.Cell src_item); + let null_jmp = null_check src_binding in + (* Copy if we have a src binding. *) + (* FIXME (issue #58): this is completely wrong, call + * through to the binding's self-copy fptr. For now + * this only works by accident. + *) + trans_copy_ty ty_params false + dst_binding (Ast.TY_box Ast.TY_int) + src_binding (Ast.TY_box Ast.TY_int) + curr_iso; + patch null_jmp + end + + | _ -> + 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 - let ty = slot_ty src_slot in - let ty = maybe_iso curr_iso ty in - let curr_iso = maybe_enter_iso ty curr_iso in - let dst_slot = { dst_slot with Ast.slot_ty = Some ty } in - let src_slot = { src_slot with Ast.slot_ty = Some ty } in - let dst = deref_slot initializing dst dst_slot in - let src = deref_slot false src src_slot in - copy_ty ty_params ty dst src curr_iso and trans_copy (initializing:bool) (dst:Ast.lval) (src:Ast.expr) : unit = - let (dst_cell, dst_slot) = trans_lval_maybe_init initializing dst in - match (slot_ty dst_slot, src) with - (Ast.TY_vec _, + 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_box 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 +3052,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 +3075,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 +3084,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 DEREF_none initializing dst_cell dst_ty in let caller_vtbl = get_element_ptr caller_obj Abi.binding_field_item @@ -3061,19 +3109,21 @@ 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 DEREF_none 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 +3139,136 @@ 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 + let dst_ty = slot_ty dst_slot in + let _ = + iflog (fun _ -> + log cx "trans_init_slot_from_cell"; + log cx " dst slot %a, src ty %a" + Ast.sprintf_slot dst_slot Ast.sprintf_ty src_ty; + log cx " dst cell %s, src cell %s" + (cell_str dst) (cell_str src)) in - match clone with - CLONE_chan clone_task -> + 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_local, 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 + (* 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 = + let _ = + iflog (fun _ -> + log cx "trans_init_slot_from_atom"; + log cx " dst slot %a, src ty %a" + Ast.sprintf_slot dst_slot + Ast.sprintf_ty (atom_type cx src_atom); + log cx " dst cell %s" + (cell_str dst)) + in + 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 + begin + log cx " forced-to-mem src cell %s" (cell_str src); + trans_init_slot_from_cell (get_ty_params_of_current_frame()) - clone_task dst src dst_slot None + clone dst dst_slot src (atom_type cx src_atom) + end + and trans_be_fn (cx:ctxt) @@ -3376,9 +3442,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) @@ -3386,6 +3453,8 @@ let trans_visitor (arg_slot:Ast.slot) (arg:Ast.atom) : unit = + log cx "trans_argN: arg slot %a, arg atom %a" + Ast.sprintf_slot arg_slot Ast.sprintf_atom arg; trans_init_slot_from_atom clone arg_cell arg_slot arg and code_of_cell (cell:Il.cell) : Il.code = @@ -3405,7 +3474,7 @@ let trans_visitor (oper_str operand) and ty_arg_slots (ty:Ast.ty) : Ast.slot array = - match ty with + match simplified_ty ty with Ast.TY_fn (tsig, _) -> tsig.Ast.sig_input_slots | _ -> bug () "Trans.ty_arg_slots on non-callable type: %a" Ast.sprintf_ty ty @@ -3509,9 +3578,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 +3680,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 +3694,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 +3837,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 +3845,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 +3854,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 +3870,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 +3880,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 +3977,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 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,26 +4046,17 @@ 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 - match src_ty with + 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 (simplified_ty src_ty = simplified_ty dst_ty); + match simplified_ty src_ty with Ast.TY_str | Ast.TY_vec _ -> let is_gc = if type_has_state src_ty then 1L else 0L in 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 +4077,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 +4099,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 +4122,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 DEREF_none false dst_cell dst_ty in let op = trans_binop binop in emit (Il.binary op dst_cell (Il.Cell dst_cell) src_oper); @@ -4087,7 +4145,7 @@ let trans_visitor Some params -> params | None -> [| |] in - match ty with + match simplified_ty ty with Ast.TY_fn _ -> let (dst_cell, _) = trans_lval_maybe_init init dst in let fn_ptr = @@ -4099,7 +4157,7 @@ let trans_visitor and trans_log id a = - match atom_type cx a with + match simplified_ty (atom_type cx a) with (* NB: If you extend this, be sure to update the * typechecking code in type.ml as well. *) Ast.TY_str -> trans_log_str a @@ -4159,46 +4217,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 DEREF_none 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 DEREF_none 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 -> @@ -4216,6 +4271,9 @@ let trans_visitor trans_init_chan dst p end + | Ast.STMT_init_box (dst, src) -> + trans_init_box dst src + | Ast.STMT_block block -> trans_block block @@ -4424,7 +4482,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 +4497,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_box state_ty in + let state_ptr_rty = referent_type abi state_ptr_ty in + let state_malloc_sz = box_allocation_size state_ptr_ty in let ctor_ty = Hashtbl.find cx.ctxt_all_item_types obj_id in let obj_ty = @@ -4508,10 +4559,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 +4740,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; @@ -4721,8 +4784,8 @@ let trans_visitor else ignore (Stack.pop curr_file) in - let visit_local_mod_item_pre n _ i = - iflog (fun _ -> log cx "translating local item #%d = %s" + let visit_defined_mod_item_pre n _ i = + iflog (fun _ -> log cx "translating defined item #%d = %s" (int_of_node i.id) (path_name())); match i.node.Ast.decl_item with Ast.MOD_ITEM_fn f -> trans_fn i.id f.Ast.fn_body @@ -4767,7 +4830,7 @@ let trans_visitor inner.Walk.visit_obj_drop_pre obj b in - let visit_local_obj_fn_pre _ _ fn = + let visit_defined_obj_fn_pre _ _ fn = trans_fn fn.id fn.node.Ast.fn_body in @@ -4782,7 +4845,7 @@ let trans_visitor then visit_required_obj_fn_pre obj ident fn else - visit_local_obj_fn_pre obj ident fn; + visit_defined_obj_fn_pre obj ident fn; end; inner.Walk.visit_obj_fn_pre obj ident fn in @@ -4794,7 +4857,7 @@ let trans_visitor then visit_required_mod_item_pre n p i else - visit_local_mod_item_pre n p i + visit_defined_mod_item_pre n p i end; inner.Walk.visit_mod_item_pre n p i in diff --git a/src/boot/me/transutil.ml b/src/boot/me/transutil.ml index cb867fef..0ec49c8e 100644 --- a/src/boot/me/transutil.ml +++ b/src/boot/me/transutil.ml @@ -7,7 +7,7 @@ open Semant;; * "simple" precise, mark-sweep, single-generation, per-task (thereby * preemptable and relatively quick) GC scheme on mutable memory. * - * - For the sake of this note, call any exterior of 'state' effect a gc_val. + * - For the sake of this note, call any box of 'state' effect a gc_val. * * - gc_vals come from the same malloc as all other values but undergo * different storage management. @@ -19,7 +19,7 @@ open Semant;; * * - A pointer to a gc_val, however, points to the third of these three * words. So a certain quantity of code can treat gc_vals the same way it - * would treat refcounted exterior vals. + * would treat refcounted box vals. * * - The first word at the head of a gc_val is used as a refcount, as in * non-gc allocations. @@ -57,6 +57,12 @@ open Semant;; *) +type deref_ctrl = + DEREF_one_box + | DEREF_all_boxes + | DEREF_none +;; + type mem_ctrl = MEM_rc_opaque | MEM_rc_struct @@ -112,29 +118,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_box 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_local -> + ty_mem_ctrl (slot_ty slot) ;; @@ -147,7 +159,7 @@ let iter_block_slots Hashtbl.iter begin fun key slot_id -> - let slot = referent_to_slot cx slot_id in + let slot = get_slot cx slot_id in fn key slot_id slot end block_slots @@ -174,7 +186,7 @@ let iter_arg_slots begin fun slot_id -> let key = Hashtbl.find cx.ctxt_slot_keys slot_id in - let slot = referent_to_slot cx slot_id in + let slot = get_slot cx slot_id in fn key slot_id slot end ls @@ -200,33 +212,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 346c6e39..b364ff56 100644 --- a/src/boot/me/type.ml +++ b/src/boot/me/type.ml @@ -5,17 +5,18 @@ type tyspec = TYSPEC_equiv of tyvar | TYSPEC_all | TYSPEC_resolved of (Ast.ty_param array) * Ast.ty - | TYSPEC_callable of (tyvar * tyvar array) (* out, ins *) - | TYSPEC_collection of tyvar (* vec or str *) - | TYSPEC_comparable (* comparable with = and != *) - | TYSPEC_plusable (* nums, vecs, and strings *) + | TYSPEC_box of tyvar (* @ of some t *) + | TYSPEC_mutable of tyvar (* something mutable *) + | TYSPEC_callable of (tyvar * tyvar array) (* out, ins *) + | TYSPEC_collection of tyvar (* vec or str *) + | TYSPEC_comparable (* comparable with = and != *) + | TYSPEC_plusable (* nums, vecs, and strings *) | TYSPEC_dictionary of dict - | TYSPEC_integral (* int-like *) - | TYSPEC_loggable - | TYSPEC_numeric (* int-like or float-like *) - | TYSPEC_ordered (* comparable with < etc. *) + | TYSPEC_integral (* int-like *) + | TYSPEC_numeric (* int-like or float-like *) + | TYSPEC_ordered (* comparable with < etc. *) | TYSPEC_record of dict - | TYSPEC_tuple of tyvar array (* heterogeneous tuple *) + | TYSPEC_tuple of tyvar array (* heterogeneous tuple *) | TYSPEC_vector of tyvar | TYSPEC_app of (tyvar * Ast.ty array) @@ -33,6 +34,7 @@ type binopsig = | BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *) ;; + let rec tyspec_to_str (ts:tyspec) : string = let fmt = Format.fprintf in @@ -85,7 +87,6 @@ let rec tyspec_to_str (ts:tyspec) : string = | TYSPEC_comparable -> fmt ff "<comparable>" | TYSPEC_plusable -> fmt ff "<plusable>" | TYSPEC_integral -> fmt ff "<integral>" - | TYSPEC_loggable -> fmt ff "<loggable>" | TYSPEC_numeric -> fmt ff "<numeric>" | TYSPEC_ordered -> fmt ff "<ordered>" | TYSPEC_resolved (params, ty) -> @@ -104,6 +105,18 @@ let rec tyspec_to_str (ts:tyspec) : string = | TYSPEC_equiv tv -> fmt_tyspec ff (!tv) + | TYSPEC_box tv -> + fmt_obr ff; + fmt ff "box "; + fmt_tyspec ff (!tv); + fmt_cbr ff; + + | TYSPEC_mutable tv -> + fmt_obr ff; + fmt ff "mut "; + fmt_tyspec ff (!tv); + fmt_cbr ff + | TYSPEC_callable (out, ins) -> fmt_obb ff; fmt ff "callable fn("; @@ -119,9 +132,11 @@ let rec tyspec_to_str (ts:tyspec) : string = fmt_cbb ff; | TYSPEC_tuple tvs -> - fmt ff "("; + fmt_obr ff; + fmt ff "tuple ("; fmt_tvs ff tvs; fmt ff ")"; + fmt_cbr ff; | TYSPEC_vector tv -> fmt_obb ff; @@ -160,7 +175,41 @@ let rec resolve_tyvar (tv:tyvar) : tyvar = | _ -> tv ;; +type unify_ctxt = + { mut_ok: bool; + box_ok: bool } +;; + +let arg_pass_ctx = + { box_ok = false; + mut_ok = true } +;; + +let rval_ctx = + { box_ok = true; + mut_ok = true } +;; + +let lval_ctx = + { box_ok = false; + mut_ok = true } +;; + +let init_ctx = + { box_ok = true; + mut_ok = true } +;; + +let strict_ctx = + { box_ok = false; + mut_ok = false } +;; + + let process_crate (cx:ctxt) (crate:Ast.crate) : unit = + + let depth = ref 0 in + let log cx = Session.log "type" cx.ctxt_sess.Session.sess_log_type cx.ctxt_sess.Session.sess_log_out @@ -197,15 +246,17 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let visitor (cx:ctxt) (inner:Walk.visitor) : Walk.visitor = let rec unify_slot + (ucx:unify_ctxt) (slot:Ast.slot) (id_opt:node_id option) (tv:tyvar) : unit = match id_opt with - Some id -> unify_tyvars (Hashtbl.find bindings id) tv + Some id -> + unify_tyvars ucx (Hashtbl.find bindings id) tv | None -> match slot.Ast.slot_ty with None -> bug () "untyped unidentified slot" - | Some ty -> unify_ty ty tv + | Some ty -> unify_ty ucx ty tv and check_sane_tyvar tv = match !tv with @@ -213,24 +264,36 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = bug () "named-type in type checker" | _ -> () - and unify_tyvars (av:tyvar) (bv:tyvar) : unit = - iflog cx (fun _ -> - log cx "unifying types:"; - log cx "input tyvar A: %s" (tyspec_to_str !av); - log cx "input tyvar B: %s" (tyspec_to_str !bv)); - check_sane_tyvar av; - check_sane_tyvar bv; - - unify_tyvars' av bv; - - iflog cx (fun _ -> - log cx "unified types:"; - log cx "output tyvar A: %s" (tyspec_to_str !av); - log cx "output tyvar B: %s" (tyspec_to_str !bv)); - check_sane_tyvar av; - check_sane_tyvar bv; - - and unify_tyvars' (av:tyvar) (bv:tyvar) : unit = + and unify_tyvars (ucx:unify_ctxt) (av:tyvar) (bv:tyvar) : unit = + let indent = String.make (4 * (!depth)) ' ' in + iflog cx + (fun _ -> + log cx "%s> unifying types:" indent; + if ucx.box_ok || ucx.mut_ok + then + log cx "%s> (w/ %s%s%s)" + indent + (if ucx.box_ok then "ext-ok" else "") + (if ucx.box_ok && ucx.mut_ok then " " else "") + (if ucx.mut_ok then "mut-ok" else ""); + log cx "%s> input tyvar A: %s" indent (tyspec_to_str !av); + log cx "%s> input tyvar B: %s" indent (tyspec_to_str !bv)); + check_sane_tyvar av; + check_sane_tyvar bv; + + incr depth; + unify_tyvars' ucx av bv; + decr depth; + + iflog cx + (fun _ -> + log cx "%s< unified types:" indent; + log cx "%s< output tyvar A: %s" indent (tyspec_to_str !av); + log cx "%s< output tyvar B: %s" indent (tyspec_to_str !bv)); + check_sane_tyvar av; + check_sane_tyvar bv; + + and unify_tyvars' (ucx:unify_ctxt) (av:tyvar) (bv:tyvar) : unit = let (a, b) = ((resolve_tyvar av), (resolve_tyvar bv)) in let fail () = err None "mismatched types: %s vs. %s" (tyspec_to_str !av) @@ -241,7 +304,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let c = Hashtbl.create ((Hashtbl.length a) + (Hashtbl.length b)) in let merge ident tv_a = if Hashtbl.mem c ident - then unify_tyvars (Hashtbl.find c ident) tv_a + then unify_tyvars ucx (Hashtbl.find c ident) tv_a else Hashtbl.add c ident tv_a in Hashtbl.iter (Hashtbl.add c) b; @@ -253,17 +316,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 ucx (find_ty ident) tv in Hashtbl.iter check_entry dct in @@ -274,11 +334,27 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let check_entry (query:Ast.ident) tv : unit = match htab_search fns query with None -> fail () - | Some fn -> unify_ty (Ast.TY_fn fn) tv + | Some fn -> unify_ty ucx (Ast.TY_fn fn) tv in Hashtbl.iter check_entry dct in + let rec unify_resolved_types + (ty_a:Ast.ty) + (ty_b:Ast.ty) + : Ast.ty = + match ty_a, ty_b with + a, b when a = b -> a + | Ast.TY_box a, b | b, Ast.TY_box a when ucx.box_ok -> + Ast.TY_box (unify_resolved_types a b) + | Ast.TY_mutable a, b | b, Ast.TY_mutable a when ucx.mut_ok -> + Ast.TY_mutable (unify_resolved_types a b) + | Ast.TY_constrained (a, constrs), b + | b, Ast.TY_constrained (a, constrs) -> + Ast.TY_constrained ((unify_resolved_types a b), constrs) + | _ -> fail() + in + let rec is_comparable_or_ordered (comparable:bool) (ty:Ast.ty) : bool = match ty with Ast.TY_mach _ | Ast.TY_int | Ast.TY_uint @@ -292,43 +368,43 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | Ast.TY_named _ -> bug () "unexpected named type" | Ast.TY_constrained (ty, _) -> is_comparable_or_ordered comparable ty + | Ast.TY_mutable ty -> + is_comparable_or_ordered comparable ty + | Ast.TY_box ty -> + ucx.box_ok && is_comparable_or_ordered comparable ty in - let floating (ty:Ast.ty) : bool = + let rec floating (ty:Ast.ty) : bool = match ty with Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true + | Ast.TY_mutable ty when ucx.mut_ok -> floating ty + | Ast.TY_box ty when ucx.box_ok -> floating ty | _ -> false in - let integral (ty:Ast.ty) : bool = + let rec integral (ty:Ast.ty) : bool = match 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 | Ast.TY_mach TY_i64 -> true + | Ast.TY_mutable ty when ucx.mut_ok -> integral ty + | Ast.TY_box ty when ucx.box_ok -> integral ty | _ -> false in let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in - let plusable (ty:Ast.ty) : bool = + let rec plusable (ty:Ast.ty) : bool = match ty with Ast.TY_str -> true | Ast.TY_vec _ -> true + | Ast.TY_mutable ty when ucx.mut_ok -> plusable ty + | Ast.TY_box ty when ucx.box_ok -> plusable ty | _ -> numeric ty in - let loggable (ty:Ast.ty) : bool = - match ty with - Ast.TY_str | Ast.TY_bool | Ast.TY_int | Ast.TY_uint - | Ast.TY_char - | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16 | Ast.TY_mach TY_u32 - | Ast.TY_mach TY_i8 | Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32 - -> true - | _ -> false - in - let result = match (!a, !b) with (TYSPEC_equiv _, _) | (_, TYSPEC_equiv _) -> @@ -336,44 +412,110 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_all, other) | (other, TYSPEC_all) -> other + (* box *) + + | (TYSPEC_box a', TYSPEC_box b') -> + unify_tyvars ucx a' b'; !a + + | (TYSPEC_box tv, + TYSPEC_resolved (params, Ast.TY_box ty)) + | (TYSPEC_resolved (params, Ast.TY_box ty), + TYSPEC_box tv) -> + unify_ty_parametric ucx ty params tv; !a + + | (_, TYSPEC_resolved (params, Ast.TY_box ty)) + when ucx.box_ok -> + unify_ty_parametric ucx ty params a; !b + + | (TYSPEC_resolved (params, Ast.TY_box ty), _) + when ucx.box_ok -> + unify_ty_parametric ucx ty params b; !a + + | (TYSPEC_box a', _) when ucx.box_ok + -> unify_tyvars ucx a' b; !a + | (_, TYSPEC_box b') when ucx.box_ok + -> unify_tyvars ucx a b'; !b + + | (_, TYSPEC_box _) + | (TYSPEC_box _, _) -> fail() + + (* mutable *) + + | (TYSPEC_mutable a', TYSPEC_mutable b') -> + unify_tyvars ucx a' b'; !a + + | (TYSPEC_mutable tv, + TYSPEC_resolved (params, Ast.TY_mutable ty)) + | (TYSPEC_resolved (params, Ast.TY_mutable ty), + TYSPEC_mutable tv) -> + unify_ty_parametric ucx ty params tv; !a + + | (_, TYSPEC_resolved (params, Ast.TY_mutable ty)) + when ucx.mut_ok -> + unify_ty_parametric ucx ty params a; !b + + | (TYSPEC_resolved (params, Ast.TY_mutable ty), _) + when ucx.mut_ok -> + unify_ty_parametric ucx ty params b; !a + + | (TYSPEC_mutable a', _) when ucx.mut_ok + -> unify_tyvars ucx a' b; !a + | (_, TYSPEC_mutable b') when ucx.mut_ok + -> unify_tyvars ucx a b'; !b + + | (_, TYSPEC_mutable _) + | (TYSPEC_mutable _, _) -> fail() + (* resolved *) | (TYSPEC_resolved (params_a, ty_a), TYSPEC_resolved (params_b, ty_b)) -> - if params_a <> params_b || ty_a <> ty_b - then fail() - else TYSPEC_resolved (params_a, ty_a) + if params_a <> params_b then fail() + else TYSPEC_resolved + (params_a, (unify_resolved_types ty_a ty_b)) | (TYSPEC_resolved (params, ty), TYSPEC_callable (out_tv, in_tvs)) | (TYSPEC_callable (out_tv, in_tvs), TYSPEC_resolved (params, ty)) -> let unify_in_slot i in_slot = - unify_slot in_slot None in_tvs.(i) + unify_slot arg_pass_ctx in_slot None in_tvs.(i) in - begin + let rec unify ty = match ty with Ast.TY_fn ({ Ast.sig_input_slots = in_slots; Ast.sig_output_slot = out_slot }, _) -> if Array.length in_slots != Array.length in_tvs - then fail (); - unify_slot out_slot None out_tv; - Array.iteri unify_in_slot in_slots + then + fail () + else + unify_slot arg_pass_ctx out_slot None out_tv; + Array.iteri unify_in_slot in_slots; + ty + | Ast.TY_box ty when ucx.box_ok + -> Ast.TY_box (unify ty) + | Ast.TY_mutable ty when ucx.mut_ok + -> Ast.TY_mutable (unify ty) | _ -> fail () - end; - TYSPEC_resolved (params, ty) + in + TYSPEC_resolved (params, unify ty) | (TYSPEC_resolved (params, ty), TYSPEC_collection tv) | (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) -> - begin + let rec unify ty = match ty with - Ast.TY_vec slot -> unify_slot slot None tv - | Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv + Ast.TY_vec ty' -> unify_ty ucx ty' tv; ty + | Ast.TY_str -> + unify_ty ucx (Ast.TY_mach TY_u8) tv; ty + | Ast.TY_box ty + when ucx.box_ok -> Ast.TY_box (unify ty) + | Ast.TY_mutable ty + when ucx.mut_ok -> Ast.TY_mutable (unify ty) | _ -> fail () - end; - TYSPEC_resolved (params, ty) + in + TYSPEC_resolved (params, unify ty) | (TYSPEC_resolved (params, ty), TYSPEC_comparable) | (TYSPEC_comparable, TYSPEC_resolved (params, ty)) -> @@ -387,15 +529,21 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_resolved (params, ty), TYSPEC_dictionary dct) | (TYSPEC_dictionary dct, TYSPEC_resolved (params, ty)) -> - begin + let rec unify ty = match ty with Ast.TY_rec fields -> - unify_dict_with_record_fields dct fields + unify_dict_with_record_fields dct fields; + ty | Ast.TY_obj (_, fns) -> - unify_dict_with_obj_fns dct fns + unify_dict_with_obj_fns dct fns; + ty + | Ast.TY_box ty + when ucx.box_ok -> Ast.TY_box (unify ty) + | Ast.TY_mutable ty + when ucx.mut_ok -> Ast.TY_mutable (unify ty) | _ -> fail () - end; - TYSPEC_resolved (params, ty) + in + TYSPEC_resolved (params, unify ty) | (TYSPEC_resolved (params, ty), TYSPEC_integral) | (TYSPEC_integral, TYSPEC_resolved (params, ty)) -> @@ -403,12 +551,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = then fail () else TYSPEC_resolved (params, ty) - | (TYSPEC_resolved (params, ty), TYSPEC_loggable) - | (TYSPEC_loggable, TYSPEC_resolved (params, ty)) -> - if not (loggable ty) - then fail () - else TYSPEC_resolved (params, ty) - | (TYSPEC_resolved (params, ty), TYSPEC_numeric) | (TYSPEC_numeric, TYSPEC_resolved (params, ty)) -> if not (numeric ty) then fail () @@ -422,52 +564,66 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_resolved (params, ty), TYSPEC_app (tv, args)) | (TYSPEC_app (tv, args), TYSPEC_resolved (params, ty)) -> let ty = rebuild_ty_under_params ty params args false in - unify_ty ty tv; + unify_ty ucx ty tv; TYSPEC_resolved ([| |], ty) | (TYSPEC_resolved (params, ty), TYSPEC_record dct) | (TYSPEC_record dct, TYSPEC_resolved (params, ty)) -> - begin + let rec unify ty = match ty with Ast.TY_rec fields -> - unify_dict_with_record_fields dct fields + unify_dict_with_record_fields dct fields; + ty + | Ast.TY_box ty + when ucx.box_ok -> Ast.TY_box (unify ty) + | Ast.TY_mutable ty + when ucx.mut_ok -> Ast.TY_mutable (unify ty) | _ -> fail () - end; - TYSPEC_resolved (params, ty) + in + TYSPEC_resolved (params, unify ty) | (TYSPEC_resolved (params, ty), TYSPEC_tuple tvs) | (TYSPEC_tuple tvs, TYSPEC_resolved (params, ty)) -> - begin + let rec unify ty = 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 ucx (elem_tys.(i)) tv in - Array.iteri check_elem tvs + Array.iteri check_elem tvs; + ty + | Ast.TY_box ty + when ucx.box_ok -> Ast.TY_box (unify ty) + | Ast.TY_mutable ty + when ucx.box_ok -> Ast.TY_mutable (unify ty) | _ -> fail () - end; - TYSPEC_resolved (params, ty) + in + TYSPEC_resolved (params, unify ty) | (TYSPEC_resolved (params, ty), TYSPEC_vector tv) | (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) -> - begin + let rec unify ty = match ty with - Ast.TY_vec slot -> - unify_slot slot None tv; - TYSPEC_resolved (params, ty) + Ast.TY_vec ty' -> unify_ty ucx ty' tv; ty + | Ast.TY_box ty when ucx.box_ok -> + Ast.TY_box (unify ty) + | Ast.TY_mutable ty when ucx.mut_ok -> + Ast.TY_mutable (unify ty) | _ -> fail () - end + in + TYSPEC_resolved (params, unify ty) (* callable *) | (TYSPEC_callable (a_out_tv, a_in_tvs), TYSPEC_callable (b_out_tv, b_in_tvs)) -> - unify_tyvars a_out_tv b_out_tv; + unify_tyvars arg_pass_ctx a_out_tv b_out_tv; let check_in_tv i a_in_tv = - unify_tyvars a_in_tv b_in_tvs.(i) + unify_tyvars arg_pass_ctx + a_in_tv b_in_tvs.(i) in Array.iteri check_in_tv a_in_tvs; TYSPEC_callable (a_out_tv, a_in_tvs) @@ -477,7 +633,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_callable _, TYSPEC_plusable) | (TYSPEC_callable _, TYSPEC_dictionary _) | (TYSPEC_callable _, TYSPEC_integral) - | (TYSPEC_callable _, TYSPEC_loggable) | (TYSPEC_callable _, TYSPEC_numeric) | (TYSPEC_callable _, TYSPEC_ordered) | (TYSPEC_callable _, TYSPEC_app _) @@ -489,7 +644,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_plusable, TYSPEC_callable _) | (TYSPEC_dictionary _, TYSPEC_callable _) | (TYSPEC_integral, TYSPEC_callable _) - | (TYSPEC_loggable, TYSPEC_callable _) | (TYSPEC_numeric, TYSPEC_callable _) | (TYSPEC_ordered, TYSPEC_callable _) | (TYSPEC_app _, TYSPEC_callable _) @@ -500,7 +654,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = (* collection *) | (TYSPEC_collection av, TYSPEC_collection bv) -> - unify_tyvars av bv; + unify_tyvars ucx av bv; TYSPEC_collection av | (TYSPEC_collection av, TYSPEC_comparable) @@ -512,7 +666,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_collection _, TYSPEC_dictionary _) | (TYSPEC_collection _, TYSPEC_integral) - | (TYSPEC_collection _, TYSPEC_loggable) | (TYSPEC_collection _, TYSPEC_numeric) | (TYSPEC_collection _, TYSPEC_ordered) | (TYSPEC_collection _, TYSPEC_app _) @@ -520,7 +673,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_collection _, TYSPEC_tuple _) | (TYSPEC_dictionary _, TYSPEC_collection _) | (TYSPEC_integral, TYSPEC_collection _) - | (TYSPEC_loggable, TYSPEC_collection _) | (TYSPEC_numeric, TYSPEC_collection _) | (TYSPEC_ordered, TYSPEC_collection _) | (TYSPEC_app _, TYSPEC_collection _) @@ -529,7 +681,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_collection av, TYSPEC_vector bv) | (TYSPEC_vector bv, TYSPEC_collection av) -> - unify_tyvars av bv; + unify_tyvars ucx av bv; TYSPEC_vector av (* comparable *) @@ -546,9 +698,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_comparable, TYSPEC_integral) | (TYSPEC_integral, TYSPEC_comparable) -> TYSPEC_integral - | (TYSPEC_comparable, TYSPEC_loggable) - | (TYSPEC_loggable, TYSPEC_comparable) -> TYSPEC_loggable - | (TYSPEC_comparable, TYSPEC_numeric) | (TYSPEC_numeric, TYSPEC_comparable) -> TYSPEC_numeric @@ -577,9 +726,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_plusable, TYSPEC_integral) | (TYSPEC_integral, TYSPEC_plusable) -> TYSPEC_integral - | (TYSPEC_plusable, TYSPEC_loggable) - | (TYSPEC_loggable, TYSPEC_plusable) -> TYSPEC_plusable - | (TYSPEC_plusable, TYSPEC_numeric) | (TYSPEC_numeric, TYSPEC_plusable) -> TYSPEC_numeric @@ -604,12 +750,10 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = TYSPEC_dictionary (merge_dicts da db) | (TYSPEC_dictionary _, TYSPEC_integral) - | (TYSPEC_dictionary _, TYSPEC_loggable) | (TYSPEC_dictionary _, TYSPEC_numeric) | (TYSPEC_dictionary _, TYSPEC_ordered) | (TYSPEC_dictionary _, TYSPEC_app _) | (TYSPEC_integral, TYSPEC_dictionary _) - | (TYSPEC_loggable, TYSPEC_dictionary _) | (TYSPEC_numeric, TYSPEC_dictionary _) | (TYSPEC_ordered, TYSPEC_dictionary _) | (TYSPEC_app _, TYSPEC_dictionary _) -> fail () @@ -626,10 +770,8 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = (* integral *) | (TYSPEC_integral, TYSPEC_integral) - | (TYSPEC_integral, TYSPEC_loggable) | (TYSPEC_integral, TYSPEC_numeric) | (TYSPEC_integral, TYSPEC_ordered) - | (TYSPEC_loggable, TYSPEC_integral) | (TYSPEC_numeric, TYSPEC_integral) | (TYSPEC_ordered, TYSPEC_integral) -> TYSPEC_integral @@ -642,25 +784,6 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | (TYSPEC_tuple _, TYSPEC_integral) | (TYSPEC_vector _, TYSPEC_integral) -> fail () - (* loggable *) - - | (TYSPEC_loggable, TYSPEC_loggable) -> TYSPEC_loggable - - | (TYSPEC_loggable, TYSPEC_numeric) - | (TYSPEC_numeric, TYSPEC_loggable) -> TYSPEC_numeric - - | (TYSPEC_loggable, TYSPEC_ordered) - | (TYSPEC_ordered, TYSPEC_loggable) -> TYSPEC_ordered - - | (TYSPEC_loggable, TYSPEC_app _) - | (TYSPEC_loggable, TYSPEC_record _) - | (TYSPEC_loggable, TYSPEC_tuple _) - | (TYSPEC_loggable, TYSPEC_vector _) - | (TYSPEC_app _, TYSPEC_loggable) - | (TYSPEC_record _, TYSPEC_loggable) - | (TYSPEC_tuple _, TYSPEC_loggable) - | (TYSPEC_vector _, TYSPEC_loggable) -> fail () - (* numeric *) | (TYSPEC_numeric, TYSPEC_numeric) -> TYSPEC_numeric @@ -698,7 +821,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = then fail() else begin - unify_tyvars tv_a tv_b; + unify_tyvars ucx tv_a tv_b; TYSPEC_app (tv_a, args_a) end @@ -731,7 +854,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = else if i >= len_b then tvs_a.(i) else begin - unify_tyvars tvs_a.(i) tvs_b.(i); + unify_tyvars strict_ctx tvs_a.(i) tvs_b.(i); tvs_a.(i) end in @@ -743,7 +866,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = (* vector *) | (TYSPEC_vector av, TYSPEC_vector bv) -> - unify_tyvars av bv; + unify_tyvars strict_ctx av bv; TYSPEC_vector av in let c = ref result in @@ -751,18 +874,19 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = b := TYSPEC_equiv c and unify_ty_parametric + (ucx:unify_ctxt) (ty:Ast.ty) (tps:Ast.ty_param array) (tv:tyvar) : unit = - unify_tyvars (ref (TYSPEC_resolved (tps, ty))) tv + unify_tyvars ucx (ref (TYSPEC_resolved (tps, ty))) tv - and unify_ty (ty:Ast.ty) (tv:tyvar) : unit = - unify_ty_parametric ty [||] tv + and unify_ty (ucx:unify_ctxt) (ty:Ast.ty) (tv:tyvar) : unit = + unify_ty_parametric ucx ty [||] tv in - let rec unify_lit (lit:Ast.lit) (tv:tyvar) : unit = + let rec unify_lit (ucx:unify_ctxt) (lit:Ast.lit) (tv:tyvar) : unit = let ty = match lit with Ast.LIT_nil -> Ast.TY_nil @@ -772,16 +896,16 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = | Ast.LIT_uint (_, _) -> Ast.TY_uint | Ast.LIT_char _ -> Ast.TY_char in - unify_ty ty tv + unify_ty ucx ty tv - and unify_atom (atom:Ast.atom) (tv:tyvar) : unit = + and unify_atom (ucx:unify_ctxt) (atom:Ast.atom) (tv:tyvar) : unit = match atom with Ast.ATOM_literal { node = literal; id = _ } -> - unify_lit literal tv + unify_lit ucx literal tv | Ast.ATOM_lval lval -> - unify_lval lval tv + unify_lval ucx lval tv - and unify_expr (expr:Ast.expr) (tv:tyvar) : unit = + and unify_expr (ucx:unify_ctxt) (expr:Ast.expr) (tv:tyvar) : unit = match expr with Ast.EXPR_binary (binop, lhs, rhs) -> let binop_sig = match binop with @@ -812,64 +936,64 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = begin match binop_sig with BINOPSIG_bool_bool_bool -> - unify_atom lhs + unify_atom rval_ctx lhs (ref (TYSPEC_resolved ([||], Ast.TY_bool))); - unify_atom rhs + unify_atom rval_ctx rhs (ref (TYSPEC_resolved ([||], Ast.TY_bool))); - unify_ty Ast.TY_bool tv + unify_ty rval_ctx Ast.TY_bool tv | BINOPSIG_comp_comp_bool -> let tv_a = ref TYSPEC_comparable in - unify_atom lhs tv_a; - unify_atom rhs tv_a; - unify_ty Ast.TY_bool tv + unify_atom rval_ctx lhs tv_a; + unify_atom rval_ctx rhs tv_a; + unify_ty rval_ctx Ast.TY_bool tv | BINOPSIG_ord_ord_bool -> let tv_a = ref TYSPEC_ordered in - unify_atom lhs tv_a; - unify_atom rhs tv_a; - unify_ty Ast.TY_bool tv + unify_atom rval_ctx lhs tv_a; + unify_atom rval_ctx rhs tv_a; + unify_ty rval_ctx Ast.TY_bool tv | BINOPSIG_integ_integ_integ -> let tv_a = ref TYSPEC_integral in - unify_atom lhs tv_a; - unify_atom rhs tv_a; - unify_tyvars tv tv_a + unify_atom rval_ctx lhs tv_a; + unify_atom rval_ctx rhs tv_a; + unify_tyvars rval_ctx tv tv_a | BINOPSIG_num_num_num -> let tv_a = ref TYSPEC_numeric in - unify_atom lhs tv_a; - unify_atom rhs tv_a; - unify_tyvars tv tv_a + unify_atom rval_ctx lhs tv_a; + unify_atom rval_ctx rhs tv_a; + unify_tyvars rval_ctx tv tv_a | BINOPSIG_plus_plus_plus -> let tv_a = ref TYSPEC_plusable in - unify_atom lhs tv_a; - unify_atom rhs tv_a; - unify_tyvars tv tv_a + unify_atom rval_ctx lhs tv_a; + unify_atom rval_ctx rhs tv_a; + unify_tyvars rval_ctx tv tv_a end | Ast.EXPR_unary (unop, atom) -> begin match unop with Ast.UNOP_not -> - unify_atom atom + unify_atom rval_ctx atom (ref (TYSPEC_resolved ([||], Ast.TY_bool))); - unify_ty Ast.TY_bool tv + unify_ty rval_ctx Ast.TY_bool tv | Ast.UNOP_bitnot -> let tv_a = ref TYSPEC_integral in - unify_atom atom tv_a; - unify_tyvars tv tv_a + unify_atom rval_ctx atom tv_a; + unify_tyvars rval_ctx tv tv_a | Ast.UNOP_neg -> let tv_a = ref TYSPEC_numeric in - unify_atom atom tv_a; - unify_tyvars tv tv_a + unify_atom rval_ctx atom tv_a; + unify_tyvars rval_ctx tv tv_a | Ast.UNOP_cast t -> (* FIXME (issue #84): check cast-validity in * post-typecheck pass. Only some casts make sense. *) let tv_a = ref TYSPEC_all in let t = Hashtbl.find cx.ctxt_all_cast_types t.id in - unify_atom atom tv_a; - unify_ty t tv + unify_atom rval_ctx atom tv_a; + unify_ty rval_ctx t tv end - | Ast.EXPR_atom atom -> unify_atom atom tv + | Ast.EXPR_atom atom -> unify_atom ucx atom tv - and unify_lval' (lval:Ast.lval) (tv:tyvar) : unit = + and unify_lval' (ucx:unify_ctxt) (lval:Ast.lval) (tv:tyvar) : unit = let note_args args = iflog cx (fun _ -> log cx "noting lval '%a' type arguments: %a" Ast.sprintf_lval lval Ast.sprintf_app_args args); @@ -891,7 +1015,21 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = log cx "lval-base slot tyspec for %a = %s" Ast.sprintf_lval lval (tyspec_to_str (!tv)); end; - unify_slot slot (Some referent) tv + begin + match htab_search + cx.ctxt_auto_deref_lval nbi.id + with + None -> + htab_put cx.ctxt_auto_deref_lval + nbi.id ucx.box_ok + | Some b -> + (* A given source-occurrence of a name-base + * should never change its auto-deref + * nature. + *) + assert (b = ucx.box_ok); + end; + unify_slot ucx slot (Some referent) tv | _ -> let spec = (!(Hashtbl.find bindings referent)) in @@ -913,7 +1051,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = ref (TYSPEC_app (tv, args)) | _ -> err None "bad lval / tyspec combination" in - unify_tyvars (ref spec) tv + unify_tyvars ucx (ref spec) tv end | Ast.LVAL_ext (base, comp) -> let base_ts = match comp with @@ -934,19 +1072,22 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = TYSPEC_tuple (Array.init (i + 1) init) | Ast.COMP_atom atom -> - unify_atom atom + unify_atom rval_ctx atom (ref (TYSPEC_resolved ([||], Ast.TY_int))); TYSPEC_collection tv + + | Ast.COMP_deref -> + TYSPEC_box tv in let base_tv = ref base_ts in - unify_lval' base base_tv; + unify_lval' { ucx with box_ok = true } 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 ucx (project_type ty comp) tv | _ -> () - and unify_lval (lval:Ast.lval) (tv:tyvar) : unit = + and unify_lval (ucx:unify_ctxt) (lval:Ast.lval) (tv:tyvar) : unit = let id = lval_base_id lval in (* Fetch lval with type components resolved. *) let lval = Hashtbl.find cx.ctxt_all_lvals id in @@ -954,13 +1095,13 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = "fetched resolved version of lval #%d = %a" (int_of_node id) Ast.sprintf_lval lval); Hashtbl.add lval_tyvars id tv; - unify_lval' lval tv + unify_lval' ucx lval tv in let gen_atom_tvs atoms = let gen_atom_tv atom = let tv = ref TYSPEC_all in - unify_atom atom tv; + unify_atom strict_ctx atom tv; tv in Array.map gen_atom_tv atoms @@ -970,97 +1111,114 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let check_callable out_tv callee args = let in_tvs = gen_atom_tvs args in let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in - unify_lval callee callee_tv; + unify_lval rval_ctx callee callee_tv; in + + let set_auto_deref lv b = + Hashtbl.replace cx.ctxt_auto_deref_lval (lval_base_id lv) b; + in + + let ty t = ref (TYSPEC_resolved ([||], t)) in + let any _ = ref TYSPEC_all in + match stmt.node with - Ast.STMT_spawn (out, _, callee, args) -> - let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_nil)) in - unify_lval out (ref (TYSPEC_resolved ([||], Ast.TY_task))); + Ast.STMT_spawn (dst, _, callee, args) -> + let out_tv = ty Ast.TY_nil in + unify_lval lval_ctx dst (ty Ast.TY_task); check_callable out_tv callee args - | Ast.STMT_init_rec (lval, fields, Some base) -> + | Ast.STMT_init_rec (dst, fields, Some base) -> let dct = Hashtbl.create 10 in let tvrec = ref (TYSPEC_record dct) in - let add_field (ident, _, _, atom) = - let tv = ref TYSPEC_all in - unify_atom atom tv; + let add_field (ident, atom) = + let tv = any() in + unify_atom arg_pass_ctx atom tv; Hashtbl.add dct ident tv in Array.iter add_field fields; - let tvbase = ref TYSPEC_all in - unify_lval base tvbase; - unify_tyvars tvrec tvbase; - unify_lval lval tvrec + let tvbase = any() in + unify_lval rval_ctx base tvbase; + unify_tyvars rval_ctx tvrec tvbase; + unify_lval init_ctx dst tvrec - | Ast.STMT_init_rec (lval, fields, None) -> + | Ast.STMT_init_rec (dst, fields, None) -> let dct = Hashtbl.create 10 in - let add_field (ident, _, _, atom) = - let tv = ref TYSPEC_all in - unify_atom atom tv; + let add_field (ident, atom) = + let tv = any() in + unify_atom arg_pass_ctx atom tv; Hashtbl.add dct ident tv in Array.iter add_field fields; - unify_lval lval (ref (TYSPEC_record dct)) + unify_lval init_ctx dst (ref (TYSPEC_record dct)) - | Ast.STMT_init_tup (lval, members) -> - let member_to_tv (_, _, atom) = - let tv = ref TYSPEC_all in - unify_atom atom tv; + | Ast.STMT_init_tup (dst, members) -> + let member_to_tv atom = + let tv = any() in + unify_atom arg_pass_ctx atom tv; tv in let member_tvs = Array.map member_to_tv members in - unify_lval lval (ref (TYSPEC_tuple member_tvs)) + unify_lval init_ctx dst (ref (TYSPEC_tuple member_tvs)) - | Ast.STMT_init_vec (lval, _, atoms) -> - let tv = ref TYSPEC_all in - let unify_with_tv atom = unify_atom atom tv in + | Ast.STMT_init_vec (dst, atoms) -> + let tv = any() in + let unify_with_tv atom = unify_atom arg_pass_ctx atom tv in Array.iter unify_with_tv atoms; - unify_lval lval (ref (TYSPEC_vector tv)) - - | Ast.STMT_init_str (lval, _) -> - unify_lval lval (ref (TYSPEC_resolved ([||], Ast.TY_str))) - - | Ast.STMT_copy (lval, expr) -> - let tv = ref TYSPEC_all in - unify_expr expr tv; - unify_lval lval tv - - | Ast.STMT_copy_binop (lval, binop, at) -> - let tv = ref TYSPEC_all in - unify_expr (Ast.EXPR_binary (binop, Ast.ATOM_lval lval, at)) tv; - unify_lval lval tv; + unify_lval init_ctx dst (ref (TYSPEC_vector tv)) + + | Ast.STMT_init_str (dst, _) -> + unify_lval init_ctx dst (ty Ast.TY_str) + + | Ast.STMT_copy (dst, expr) -> + let tv = any() in + unify_expr arg_pass_ctx expr tv; + unify_lval lval_ctx dst tv + + | Ast.STMT_copy_binop (dst, binop, at) -> + let tv = any() in + unify_expr arg_pass_ctx + (Ast.EXPR_binary (binop, Ast.ATOM_lval dst, at)) tv; + (* Force-override the 'auto-deref' judgment that was cached + * in cx.ctxt_auto_deref_lval by preceding unify_expr call. + *) + set_auto_deref dst false; + unify_lval lval_ctx dst tv; | Ast.STMT_call (out, callee, args) -> - let out_tv = ref TYSPEC_all in - unify_lval out out_tv; + let out_tv = any() in + unify_lval arg_pass_ctx out out_tv; check_callable out_tv callee args - | Ast.STMT_log atom -> unify_atom atom (ref TYSPEC_loggable) + | Ast.STMT_log atom -> + begin + match atom with + Ast.ATOM_lval lv -> set_auto_deref lv true + | _ -> () + end | Ast.STMT_check_expr expr -> - unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool))) + unify_expr rval_ctx expr (ty Ast.TY_bool) | Ast.STMT_check (_, check_calls) -> - let out_tv = ref (TYSPEC_resolved ([||], Ast.TY_bool)) in + let out_tv = ty Ast.TY_bool in Array.iter (fun (callee, args) -> check_callable out_tv callee args) check_calls - | Ast.STMT_while { Ast.while_lval = (_, expr); Ast.while_body = _ } -> - unify_expr expr (ref (TYSPEC_resolved ([||], Ast.TY_bool))) + | Ast.STMT_while { Ast.while_lval = (_, expr) } + | Ast.STMT_do_while { Ast.while_lval = (_, expr) } -> + unify_expr rval_ctx expr (ty Ast.TY_bool) | Ast.STMT_if { Ast.if_test = if_test } -> - unify_expr if_test (ref (TYSPEC_resolved ([||], Ast.TY_bool))); - - | Ast.STMT_decl _ -> () + unify_expr rval_ctx if_test (ty Ast.TY_bool); | Ast.STMT_ret atom_opt | Ast.STMT_put atom_opt -> begin match atom_opt with - None -> unify_ty Ast.TY_nil (retval_tv()) - | Some atom -> unify_atom atom (retval_tv()) + None -> unify_ty arg_pass_ctx Ast.TY_nil (retval_tv()) + | Some atom -> unify_atom arg_pass_ctx atom (retval_tv()) end | Ast.STMT_be (callee, args) -> @@ -1070,15 +1228,15 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = (* FIXME (issue #81): handle binding type parameters * eventually. *) - let out_tv = ref TYSPEC_all in + let out_tv = any() in let residue = ref [] in let gen_atom_opt_tvs atoms = let gen_atom_tv atom_opt = - let tv = ref TYSPEC_all in + let tv = any() in begin match atom_opt with None -> residue := tv :: (!residue); - | Some atom -> unify_atom atom tv + | Some atom -> unify_atom arg_pass_ctx atom tv end; tv in @@ -1089,14 +1247,14 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let arg_residue_tvs = Array.of_list (List.rev (!residue)) in let callee_tv = ref (TYSPEC_callable (out_tv, in_tvs)) in let bound_tv = ref (TYSPEC_callable (out_tv, arg_residue_tvs)) in - unify_lval callee callee_tv; - unify_lval bound bound_tv + unify_lval rval_ctx callee callee_tv; + unify_lval lval_ctx bound bound_tv | Ast.STMT_for_each fe -> - let out_tv = ref TYSPEC_all in + let out_tv = any() in let (si, _) = fe.Ast.for_each_slot in let (callee, args) = fe.Ast.for_each_call in - unify_slot si.node (Some si.id) out_tv; + unify_slot lval_ctx si.node (Some si.id) out_tv; check_callable out_tv callee args | Ast.STMT_for fo -> @@ -1104,23 +1262,71 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let seq_tv = ref (TYSPEC_collection mem_tv) in let (si, _) = fo.Ast.for_slot in let (_, seq) = fo.Ast.for_seq in - unify_lval seq seq_tv; - unify_slot si.node (Some si.id) mem_tv + unify_lval rval_ctx seq seq_tv; + unify_slot lval_ctx si.node (Some si.id) mem_tv | Ast.STMT_alt_tag { Ast.alt_tag_lval = lval; Ast.alt_tag_arms = arms } -> - let lval_tv = ref TYSPEC_all in - unify_lval lval lval_tv; + let lval_tv = any() in + unify_lval arg_pass_ctx lval lval_tv; Array.iter (fun _ -> push_pat_tv lval_tv) arms - (* FIXME (issue #52): plenty more to handle here. *) - | _ -> - log cx "warning: not typechecking stmt %s\n" - (Ast.sprintf_stmt () stmt) + | Ast.STMT_join lval -> + unify_lval rval_ctx lval (ty Ast.TY_task); + + | Ast.STMT_init_box (dst, v) -> + let in_tv = any() in + let tv = ref (TYSPEC_mutable (ref (TYSPEC_box in_tv))) in + unify_lval strict_ctx dst tv; + unify_atom rval_ctx v in_tv; + + (* FIXME (issue #52): Finish these. *) + (* Fake-typecheck a few comm-related statements for now, just enough + * to supply the auto-deref contexts; we will need new tyspecs for + * port and channel constraints. + *) + + | Ast.STMT_recv (dst, port) -> + set_auto_deref dst rval_ctx.box_ok; + set_auto_deref port rval_ctx.box_ok; + + | Ast.STMT_send (chan, v) -> + set_auto_deref chan rval_ctx.box_ok; + set_auto_deref v rval_ctx.box_ok; + + | Ast.STMT_init_chan (dst, port_opt) -> + begin + match port_opt with + None -> () + | Some port -> set_auto_deref port rval_ctx.box_ok + end; + set_auto_deref dst init_ctx.box_ok + + | Ast.STMT_init_port dst -> + set_auto_deref dst init_ctx.box_ok + + + (* Nothing to typecheck on these. *) + | Ast.STMT_block _ + | Ast.STMT_decl _ + | Ast.STMT_yield + | Ast.STMT_fail -> () + + (* Unimplemented. *) + | Ast.STMT_check_if _ + | Ast.STMT_prove _ + | Ast.STMT_note _ + | Ast.STMT_alt_port _ + | Ast.STMT_alt_type _ + | Ast.STMT_put_each _ + | Ast.STMT_slice _ -> err None "Unimplemented typecheck for stmt" in let visit_stmt_pre (stmt:Ast.stmt) : unit = try + log cx ""; + log cx "typechecking stmt: %a" Ast.sprintf_stmt stmt; + log cx ""; visit_stmt_pre_full stmt; (* * Reset any item-parameters that were resolved to types @@ -1129,6 +1335,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = Hashtbl.iter (fun _ params -> Array.iter (fun tv -> tv := TYSPEC_all) params) item_params; + log cx "finished typechecking stmt: %a" Ast.sprintf_stmt stmt; with Semant_err (None, msg) -> raise (Semant_err ((Some stmt.id), msg)) @@ -1137,7 +1344,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let enter_fn fn retspec = let out = fn.Ast.fn_output_slot in push_retval_tv (ref retspec); - unify_slot out.node (Some out.id) (retval_tv()) + unify_slot arg_pass_ctx out.node (Some out.id) (retval_tv()) in let visit_obj_fn_pre obj ident fn = @@ -1181,8 +1388,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)) + local_slot (Ast.TY_vec Ast.TY_str) in match tsig.Ast.sig_input_slots with [| |] -> () @@ -1205,12 +1411,12 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let visit_pat_pre (pat:Ast.pat) : unit = let expected = pat_tv() in match pat with - Ast.PAT_lit lit -> unify_lit lit expected + Ast.PAT_lit lit -> unify_lit strict_ctx lit expected | Ast.PAT_tag (lval, _) -> let expect ty = let tv = ref TYSPEC_all in - unify_ty ty tv; + unify_ty strict_ctx ty tv; push_pat_tv tv; in @@ -1222,7 +1428,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = * exactly to that function type, rebuilt under any latent type * parameters applied in the lval. *) let lval_tv = ref TYSPEC_all in - unify_lval lval lval_tv; + unify_lval strict_ctx lval lval_tv; let tag_ctor_ty = match !(resolve_tyvar lval_tv) with TYSPEC_resolved (_, ty) -> ty @@ -1234,19 +1440,13 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let tag_ty_tup = tag_or_iso_ty_tup_by_name tag_ty lval_nm in 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 + unify_ty strict_ctx tag_ty tag_tv; + unify_tyvars strict_ctx expected tag_tv; + List.iter expect (List.rev (Array.to_list tag_ty_tup)); | Ast.PAT_slot (sloti, _) -> - unify_slot sloti.node (Some sloti.id) expected + unify_slot lval_ctx sloti.node (Some sloti.id) expected | Ast.PAT_wild -> () in @@ -1274,7 +1474,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = match defn with DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = None } -> Queue.add id auto_queue; - Hashtbl.add bindings id (ref TYSPEC_all) + Hashtbl.add bindings id (ref (TYSPEC_mutable (ref TYSPEC_all))) | DEFN_slot { Ast.slot_mode = _; Ast.slot_ty = Some ty } -> let _ = iflog cx (fun _ -> log cx "initial slot #%d type: %a" (int_of_node id) Ast.sprintf_ty ty) @@ -1336,25 +1536,40 @@ 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 -> + log cx "setting auto slot #%d = %a to type %a" + (int_of_node id) + Ast.sprintf_slot_key + (Hashtbl.find cx.ctxt_slot_keys id) + Ast.sprintf_ty ty; + 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 - let get_resolved_ty tv id = + let rec get_resolved_ty tv id = let ts = !(resolve_tyvar tv) in match ts with TYSPEC_resolved ([||], ty) -> ty - | TYSPEC_vector (tv) -> - begin - match !(resolve_tyvar tv) with - TYSPEC_resolved ([||], ty) -> - (Ast.TY_vec (interior_slot ty)) - | _ -> - err (Some id) - "unresolved vector-element type in %s (%d)" - (tyspec_to_str ts) (int_of_node id) - end + | TYSPEC_box tv -> + Ast.TY_box (get_resolved_ty tv id) + + | TYSPEC_mutable tv -> + Ast.TY_mutable (get_resolved_ty tv id) + + | TYSPEC_vector tv -> + Ast.TY_vec (get_resolved_ty tv id) + + | TYSPEC_tuple tvs -> + Ast.TY_tup + (Array.map + (fun tv -> get_resolved_ty tv id) tvs) + | _ -> err (Some id) "unresolved type %s (%d)" (tyspec_to_str ts) @@ -1369,6 +1584,13 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit = let record_lval_ty id tv = let ty = get_resolved_ty tv id in + let _ = + iflog cx + (fun _ -> + log cx "recording resolved lval #%d type %a" + (int_of_node id) + Ast.sprintf_ty ty) + in Hashtbl.add cx.ctxt_all_lval_types id ty in diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml index d42aaf6d..2c0c4b15 100644 --- a/src/boot/me/typestate.ml +++ b/src/boot/me/typestate.ml @@ -68,9 +68,10 @@ let determine_constr_key if referent_is_slot cx aid then if type_has_state - (slot_ty (referent_to_slot cx aid)) + (strip_mutable_or_constrained_ty + (slot_ty (get_slot cx aid))) then err (Some aid) - "predicate applied to slot of mutable type" + "predicate applied to slot of state type" else aid else (* Items are always constant, they're ok. @@ -419,7 +420,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; @@ -439,6 +440,12 @@ let condition_assigning_visitor raise_precondition s.id precond; raise_postcondition s.id postcond + | Ast.STMT_init_box (dst, src) -> + let precond = slot_inits (atom_slots cx src) in + let postcond = slot_inits (lval_slots cx dst) in + raise_precondition s.id precond; + raise_postcondition s.id postcond + | Ast.STMT_copy (dst, src) -> let precond = slot_inits (expr_slots cx src) in let postcond = slot_inits (lval_slots cx dst) in @@ -980,16 +987,23 @@ 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, _) -> + | Ast.STMT_init_chan (lv_dst, _) + | Ast.STMT_init_box (lv_dst, _) -> init_lval lv_dst | Ast.STMT_for f -> diff --git a/src/boot/me/walk.ml b/src/boot/me/walk.ml index 203acfce..0b60c832 100644 --- a/src/boot/me/walk.ml +++ b/src/boot/me/walk.ml @@ -235,7 +235,7 @@ and walk_mod_item : unit = let children _ = match item.node.Ast.decl_item with - Ast.MOD_ITEM_type ty -> walk_ty v ty + Ast.MOD_ITEM_type (_, ty) -> walk_ty v ty | Ast.MOD_ITEM_fn f -> walk_fn v f item.id | Ast.MOD_ITEM_tag (htup, ttag, _) -> walk_header_tup v htup; @@ -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_box 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_box (dst, src) -> + walk_lval v dst; + walk_atom v src + | Ast.STMT_for f -> walk_stmt_for f diff --git a/src/lib/util.rs b/src/lib/util.rs index bf57bb52..e0e52c8f 100644 --- a/src/lib/util.rs +++ b/src/lib/util.rs @@ -1,8 +1,4 @@ type option[T] = tag(none(), some(T)); -type box[T] = tup(@T); -type boxo[T] = option[box[T]]; -type boxm[T] = tup(mutable @T); -type boxmo[T] = option[boxm[T]]; type map[T, U] = fn(&T) -> U; @@ -17,28 +13,6 @@ fn option_map[T, U](map[T, U] f, &option[T] opt) -> option[U] { } } -fn unbox[T](&box[T] b) -> T { - ret b._0; -} - - -fn unboxm[T](&boxm[T] b) -> T { - ret b._0; -} - -fn unboxo[T](boxo[T] b) -> option[T] { - // Pending issue #90, no need to alias the function item in order to pass - // it as an arg. - let map[box[T], T] f = unbox[T]; - be option_map[box[T], T](f, b); -} - -fn unboxmo[T](boxmo[T] b) -> option[T] { - // Issue #90, as above - let map[boxm[T], T] f = unboxm[T]; - be option_map[boxm[T], T](f, b); -} - fn id[T](T x) -> T { ret x; } diff --git a/src/rt/rust_crate_reader.cpp b/src/rt/rust_crate_reader.cpp index 3c36729f..b9b4497c 100644 --- a/src/rt/rust_crate_reader.cpp +++ b/src/rt/rust_crate_reader.cpp @@ -255,12 +255,19 @@ rust_crate_reader::die::die(die_reader *rdr, uintptr_t off) if (!ab_idx) { ab = NULL; dom->log(rust_log::DWARF, "DIE <0x%" PRIxPTR "> (null)", off); + dom->get_log().outdent(); } else { ab = rdr->abbrevs.get_abbrev(ab_idx); - dom->log(rust_log::DWARF, "DIE <0x%" PRIxPTR "> abbrev 0x%" - PRIxPTR, off, ab_idx); - dom->log(rust_log::DWARF, " tag 0x%x, has children: %d", - ab->tag, ab->has_children); + if (!ab) { + dom->log(rust_log::DWARF, " bad abbrev number: 0x%" + PRIxPTR, ab_idx); + rdr->fail(); + } else { + dom->log(rust_log::DWARF, "DIE <0x%" PRIxPTR "> abbrev 0x%" + PRIxPTR, off, ab_idx); + dom->log(rust_log::DWARF, " tag 0x%x, has children: %d", + ab->tag, ab->has_children); + } } } @@ -334,6 +341,12 @@ rust_crate_reader::die::step_attr(attr &a) const return rdr->is_ok() || rdr->at_end(); break; + case DW_FORM_block4: + rdr->get(u32); + rdr->adv(u32); + return rdr->is_ok() || rdr->at_end(); + break; + default: rdr->mem.dom->log(rust_log::DWARF, " unknown dwarf form: 0x%" PRIxPTR, a.form); @@ -451,19 +464,21 @@ rust_crate_reader::die::next() const { rdr_sess use(rdr); if (start_attrs()) { - attr a; - while (step_attr(a)) { - I(dom, !(a.is_numeric() && a.is_string())); - if (a.is_numeric()) - dom->log(rust_log::DWARF, " attr num: 0x%" - PRIxPTR, a.get_num(dom)); - else if (a.is_string()) - dom->log(rust_log::DWARF, " attr str: %s", - a.get_str(dom)); - else - dom->log(rust_log::DWARF, " attr ??:"); - } + attr a; + while (step_attr(a)) { + I(dom, !(a.is_numeric() && a.is_string())); + if (a.is_numeric()) + dom->log(rust_log::DWARF, " attr num: 0x%" + PRIxPTR, a.get_num(dom)); + else if (a.is_string()) + dom->log(rust_log::DWARF, " attr str: %s", + a.get_str(dom)); + else + dom->log(rust_log::DWARF, " attr ??:"); + } } + if (has_children()) + dom->get_log().indent(); } return die(rdr, rdr->tell_off()); } diff --git a/src/rt/rust_task.cpp b/src/rt/rust_task.cpp index bf92ba90..5e230a58 100644 --- a/src/rt/rust_task.cpp +++ b/src/rt/rust_task.cpp @@ -413,6 +413,7 @@ rust_task::link_gc(gc_alloc *gcm) { I(dom, gcm->next == NULL); gcm->prev = NULL; gcm->next = gc_alloc_chain; + gc_alloc_chain = gcm; } void diff --git a/src/rt/rust_upcall.cpp b/src/rt/rust_upcall.cpp index ffe77532..b9cd68fc 100644 --- a/src/rt/rust_upcall.cpp +++ b/src/rt/rust_upcall.cpp @@ -328,11 +328,16 @@ upcall_malloc(rust_task *task, size_t nbytes, type_desc *td) { LOG_UPCALL_ENTRY(task); + task->dom->log(rust_log::UPCALL|rust_log::MEM, + "upcall malloc(%" PRIdPTR ", 0x%" PRIxPTR ")" + " with gc-chain head = 0x%" PRIxPTR, + nbytes, td, task->gc_alloc_chain); void *p = task->malloc(nbytes, td); task->dom->log(rust_log::UPCALL|rust_log::MEM, - "upcall malloc(%u) = 0x%" PRIxPTR + "upcall malloc(%" PRIdPTR ", 0x%" PRIxPTR + ") = 0x%" PRIxPTR " with gc-chain head = 0x%" PRIxPTR, - nbytes, (uintptr_t)p, task->gc_alloc_chain); + nbytes, td, (uintptr_t)p, task->gc_alloc_chain); return (uintptr_t) p; } diff --git a/src/test/run-pass/acyclic-unwind.rs b/src/test/run-pass/acyclic-unwind.rs index b549cffe..192a01f3 100644 --- a/src/test/run-pass/acyclic-unwind.rs +++ b/src/test/run-pass/acyclic-unwind.rs @@ -4,10 +4,10 @@ io fn f(chan[int] c) { type t = tup(int,int,int); - // Allocate an exterior. + // Allocate a box. let @t x = tup(1,2,3); - // Signal parent that we've allocated an exterior. + // Signal parent that we've allocated a box. c <| 1; while (true) { diff --git a/src/test/run-pass/box-unbox.rs b/src/test/run-pass/box-unbox.rs index 821ac74c..9c00f55c 100644 --- a/src/test/run-pass/box-unbox.rs +++ b/src/test/run-pass/box-unbox.rs @@ -1,10 +1,10 @@ type box[T] = tup(@T); -fn unbox[T](box[T] b) -> T { ret b._0; } +fn unbox[T](box[T] b) -> T { ret *b._0; } fn main() { let int foo = 17; - let box[int] bfoo = tup(foo); + let box[int] bfoo = tup(@foo); log "see what's in our box"; check (unbox[int](bfoo) == foo); } diff --git a/src/test/run-pass/deref.rs b/src/test/run-pass/deref.rs new file mode 100644 index 00000000..36a28ba5 --- /dev/null +++ b/src/test/run-pass/deref.rs @@ -0,0 +1,4 @@ +fn main() { + let @int x = @10; + let int y = *x; +}
\ No newline at end of file diff --git a/src/test/run-pass/exterior.rs b/src/test/run-pass/exterior.rs index bb0b91eb..0e93e25a 100644 --- a/src/test/run-pass/exterior.rs +++ b/src/test/run-pass/exterior.rs @@ -10,7 +10,7 @@ fn f(@point p) { fn main() { let point a = rec(x=10, y=11, z=mutable 12); - let @point b = a; + let @point b = @a; check (b.z == 12); f(b); check (a.z == 12); diff --git a/src/test/run-pass/generic-tag.rs b/src/test/run-pass/generic-tag.rs index 9a98ead5..0e1c6a65 100644 --- a/src/test/run-pass/generic-tag.rs +++ b/src/test/run-pass/generic-tag.rs @@ -1,6 +1,6 @@ type option[T] = tag(some(@T), none()); fn main() { - let option[int] a = some[int](10); + let option[int] a = some[int](@10); a = none[int](); }
\ No newline at end of file diff --git a/src/test/run-pass/lazy-and-or.rs b/src/test/run-pass/lazy-and-or.rs index 81f09843..fe0ffe6b 100644 --- a/src/test/run-pass/lazy-and-or.rs +++ b/src/test/run-pass/lazy-and-or.rs @@ -1,4 +1,4 @@ -fn incr(mutable &int x) -> bool { +fn incr(& mutable int x) -> bool { x += 1; check (false); ret false; diff --git a/src/test/run-pass/list.rs b/src/test/run-pass/list.rs index 38601f8f..c615b67c 100644 --- a/src/test/run-pass/list.rs +++ b/src/test/run-pass/list.rs @@ -3,5 +3,5 @@ type list = tag(cons(int,@list), nil()); fn main() { - cons(10, cons(11, cons(12, nil()))); + cons(10, @cons(11, @cons(12, @nil()))); } diff --git a/src/test/run-pass/mlist.rs b/src/test/run-pass/mlist.rs index ba71aa58..c9bdb283 100644 --- a/src/test/run-pass/mlist.rs +++ b/src/test/run-pass/mlist.rs @@ -3,5 +3,5 @@ type mlist = tag(cons(int,mutable @mlist), nil()); fn main() { - cons(10, cons(11, cons(12, nil()))); + cons(10, @cons(11, @cons(12, @nil()))); } diff --git a/src/test/run-pass/obj-drop.rs b/src/test/run-pass/obj-drop.rs index 6d4ca3d4..107e6693 100644 --- a/src/test/run-pass/obj-drop.rs +++ b/src/test/run-pass/obj-drop.rs @@ -1,6 +1,6 @@ fn main() { obj handle(@int i) { } - // This just tests whether the obj leaks its exterior state members. - auto ob = handle(0xf00f00); + // This just tests whether the obj leaks its box state members. + auto ob = handle(@0xf00f00); }
\ No newline at end of file diff --git a/src/test/run-pass/output-slot-variants.rs b/src/test/run-pass/output-slot-variants.rs index 3dd5ae2e..5142a9b1 100644 --- a/src/test/run-pass/output-slot-variants.rs +++ b/src/test/run-pass/output-slot-variants.rs @@ -3,7 +3,7 @@ fn ret_int_i() -> int { } fn ret_ext_i() -> @int { - ret 10; + ret @10; } fn ret_int_tup() -> tup(int,int) { @@ -11,7 +11,7 @@ fn ret_int_tup() -> tup(int,int) { } fn ret_ext_tup() -> @tup(int,int) { - ret tup(10, 10); + ret @tup(10, 10); } fn ret_ext_mem() -> tup(@int, @int) { @@ -19,7 +19,7 @@ fn ret_ext_mem() -> tup(@int, @int) { } fn ret_ext_ext_mem() -> @tup(@int, @int) { - ret tup(@10, @10); + ret @tup(@10, @10); } fn main() { diff --git a/src/test/run-pass/vec-drop.rs b/src/test/run-pass/vec-drop.rs index 267c7a78..fff9a1ee 100644 --- a/src/test/run-pass/vec-drop.rs +++ b/src/test/run-pass/vec-drop.rs @@ -1,4 +1,4 @@ fn main() { // This just tests whether the vec leaks its members. - let vec[@tup(int,int)] pvec = vec(tup(1,2),tup(3,4),tup(5,6)); + let vec[@tup(int,int)] pvec = vec(@tup(1,2),@tup(3,4),@tup(5,6)); } diff --git a/src/test/run-pass/writealias.rs b/src/test/run-pass/writealias.rs index 96b2a9d7..061b1b57 100644 --- a/src/test/run-pass/writealias.rs +++ b/src/test/run-pass/writealias.rs @@ -2,7 +2,7 @@ type point = rec(int x, int y, mutable int z); -fn f(mutable &point p) { +fn f(& mutable point p) { p.z = 13; } |