From 1f9fd2710ec9122ddddcedaab51650a92ad7c8cf Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Tue, 29 Jun 2010 12:00:15 -0700 Subject: Initial stab at lowering mutable and exterior into the type system. --- src/boot/fe/ast.ml | 101 ++++++++++++++++++++++++++------------------ src/boot/fe/item.ml | 16 +++++-- src/boot/fe/parser.ml | 2 - src/boot/fe/pexp.ml | 115 +++++++++++++++++++++----------------------------- 4 files changed, 119 insertions(+), 115 deletions(-) (limited to 'src/boot/fe') diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml index 770b57bf..8b1ce71f 100644 --- a/src/boot/fe/ast.ml +++ b/src/boot/fe/ast.ml @@ -9,11 +9,6 @@ open Common;; open Fmt;; -(* - * Slot names are given by a dot-separated path within the current - * module namespace. - *) - type ident = string ;; @@ -70,11 +65,11 @@ and ty = | TY_str | TY_tup of ty_tup - | TY_vec of slot + | TY_vec of ty | TY_rec of ty_rec (* - * Note that ty_idx is only valid inside a slot of a ty_iso group, not + * Note that ty_idx is only valid inside a ty of a ty_iso group, not * in a general type term. *) | TY_tag of ty_tag @@ -93,18 +88,25 @@ and ty = | TY_named of name | TY_type + | TY_exterior of ty + | TY_mutable of ty + | TY_constrained of (ty * constrs) +(* + * FIXME: this should be cleaned up to be a different + * type definition. Only args can be by-ref, only locals + * can be auto. The structure here is historical. + *) + and mode = - MODE_exterior | MODE_interior | MODE_alias and slot = { slot_mode: mode; - slot_mutable: bool; slot_ty: ty option; } -and ty_tup = slot array +and ty_tup = ty array (* In closed type terms a constraint may refer to components of the term by * anchoring off the "formal symbol" '*', which represents "the term this @@ -147,7 +149,7 @@ and constr = and constrs = constr array -and ty_rec = (ident * slot) array +and ty_rec = (ident * ty) array (* ty_tag is a sum type. * @@ -185,9 +187,9 @@ and ty_obj = (effect * ((ident,ty_fn) Hashtbl.t)) and check_calls = (lval * (atom array)) array -and rec_input = (ident * mode * bool * atom) +and rec_input = (ident * atom) -and tup_input = (mode * bool * atom) +and tup_input = atom and stmt' = @@ -195,10 +197,11 @@ and stmt' = STMT_spawn of (lval * domain * lval * (atom array)) | STMT_init_rec of (lval * (rec_input array) * lval option) | STMT_init_tup of (lval * (tup_input array)) - | STMT_init_vec of (lval * slot * (atom array)) + | STMT_init_vec of (lval * atom array) | STMT_init_str of (lval * string) | STMT_init_port of lval | STMT_init_chan of (lval * (lval option)) + | STMT_init_exterior of (lval * atom) | STMT_copy of (lval * expr) | STMT_copy_binop of (lval * binop * atom) | STMT_call of (lval * lval * (atom array)) @@ -516,13 +519,8 @@ and fmt_name (ff:Format.formatter) (n:name) : unit = fmt ff "."; fmt_name_component ff nc -and fmt_mutable (ff:Format.formatter) (m:bool) : unit = - if m - then fmt ff "mutable "; - and fmt_mode (ff:Format.formatter) (m:mode) : unit = match m with - MODE_exterior -> fmt ff "@@" | MODE_alias -> fmt ff "&" | MODE_interior -> () @@ -530,10 +528,27 @@ and fmt_slot (ff:Format.formatter) (s:slot) : unit = match s.slot_ty with None -> fmt ff "auto" | Some t -> - fmt_mutable ff s.slot_mutable; fmt_mode ff s.slot_mode; fmt_ty ff t +and fmt_tys + (ff:Format.formatter) + (tys:ty array) + : unit = + fmt_bracketed_arr_sep "(" ")" "," fmt_ty ff tys + +and fmt_ident_tys + (ff:Format.formatter) + (entries:(ident * ty) array) + : unit = + fmt_bracketed_arr_sep "(" ")" "," + (fun ff (ident, ty) -> + fmt_ty ff ty; + fmt ff " "; + fmt_ident ff ident) + ff + entries + and fmt_slots (ff:Format.formatter) (slots:slot array) @@ -594,7 +609,7 @@ and fmt_tag (ff:Format.formatter) (ttag:ty_tag) : unit = then first := false else fmt ff ",@ "); fmt_name ff name; - fmt_slots ff ttup None + fmt_tys ff ttup end ttag; fmt ff "@])@]" @@ -623,19 +638,15 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit = | TY_char -> fmt ff "char" | TY_str -> fmt ff "str" - | TY_tup slots -> (fmt ff "tup"; fmt_slots ff slots None) - | TY_vec s -> (fmt ff "vec["; fmt_slot ff s; fmt ff "]") + | TY_tup tys -> (fmt ff "tup"; fmt_tys ff tys) + | TY_vec t -> (fmt ff "vec["; fmt_ty ff t; fmt ff "]") | TY_chan t -> (fmt ff "chan["; fmt_ty ff t; fmt ff "]") | TY_port t -> (fmt ff "port["; fmt_ty ff t; fmt ff "]") - | TY_rec slots -> - let (idents, slots) = - let (idents, slots) = List.split (Array.to_list slots) in - (Array.of_list idents, Array.of_list slots) - in - fmt ff "@[rec"; - fmt_slots ff slots (Some idents); - fmt ff "@]" + | TY_rec entries -> + fmt ff "@[rec"; + fmt_ident_tys ff entries; + fmt ff "@]" | TY_param (i, e) -> (fmt_effect ff e; if e <> PURE then fmt ff " "; @@ -644,6 +655,14 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit = | TY_named n -> fmt_name ff n | TY_type -> fmt ff "type" + | TY_exterior t -> + fmt ff "@@"; + fmt_ty ff t + + | TY_mutable t -> + fmt ff "mutable "; + fmt_ty ff t + | TY_fn tfn -> fmt_ty_fn ff None tfn | TY_task -> fmt ff "task" | TY_tag ttag -> fmt_tag ff ttag @@ -964,7 +983,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = fmt_lval ff lv; fmt ff " "; fmt_binop ff binop; - fmt ff "="; + fmt ff "= "; fmt_atom ff at; fmt ff ";" @@ -999,11 +1018,9 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = do if i != 0 then fmt ff ", "; - let (ident, mode, mut, atom) = entries.(i) in + let (ident, atom) = entries.(i) in fmt_ident ff ident; fmt ff " = "; - fmt_mutable ff mut; - fmt_mode ff mode; fmt_atom ff atom; done; begin @@ -1015,7 +1032,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = end; fmt ff ");" - | STMT_init_vec (dst, _, atoms) -> + | STMT_init_vec (dst, atoms) -> fmt_lval ff dst; fmt ff " = vec("; for i = 0 to (Array.length atoms) - 1 @@ -1033,10 +1050,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = do if i != 0 then fmt ff ", "; - let (mode, mut, atom) = entries.(i) in - fmt_mutable ff mut; - fmt_mode ff mode; - fmt_atom ff atom; + fmt_atom ff entries.(i); done; fmt ff ");"; @@ -1153,6 +1167,12 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit = fmt_lval ff t; fmt ff ";" + | STMT_init_exterior (lv, at) -> + fmt_lval ff lv; + fmt ff " = @"; + fmt_atom ff at; + fmt ff ";" + | STMT_alt_tag _ -> fmt ff "?stmt_alt_tag?" | STMT_alt_type _ -> fmt ff "?stmt_alt_type?" | STMT_alt_port _ -> fmt ff "?stmt_alt_port?" @@ -1321,7 +1341,6 @@ let sprintf_lval_component = sprintf_fmt fmt_lval_component;; let sprintf_atom = sprintf_fmt fmt_atom;; let sprintf_slot = sprintf_fmt fmt_slot;; let sprintf_slot_key = sprintf_fmt fmt_slot_key;; -let sprintf_mutable = sprintf_fmt fmt_mutable;; let sprintf_ty = sprintf_fmt fmt_ty;; let sprintf_effect = sprintf_fmt fmt_effect;; let sprintf_tag = sprintf_fmt fmt_tag;; diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml index 3efd4e2a..5c0a7c65 100644 --- a/src/boot/fe/item.ml +++ b/src/boot/fe/item.ml @@ -128,6 +128,13 @@ and parse_auto_slot_and_init and parse_stmts (ps:pstate) : Ast.stmt array = let apos = lexpos ps in + let ensure_mutable slot = + match slot.Ast.slot_ty with + None -> slot + | Some (Ast.TY_mutable _) -> slot + | Some t -> { slot with Ast.slot_ty = Some (Ast.TY_mutable t) } + in + let rec name_to_lval (apos:pos) (bpos:pos) (name:Ast.name) : Ast.lval = match name with @@ -236,7 +243,6 @@ and parse_stmts (ps:pstate) : Ast.stmt array = Ast.NAME_base (Ast.BASE_ident ident) -> let slot = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; Ast.slot_ty = None } in Ast.PAT_slot @@ -456,7 +462,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array = bump ps; let (stmts, slot, ident) = ctxt "stmt slot" parse_slot_and_ident_and_init ps in - let slot = Pexp.apply_mutability slot true in + let slot = ensure_mutable slot in let bpos = lexpos ps in let decl = Ast.DECL_slot (Ast.KEY_ident ident, (span ps apos bpos slot)) @@ -467,7 +473,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array = bump ps; let (stmts, slot, ident) = ctxt "stmt slot" parse_auto_slot_and_init ps in - let slot = Pexp.apply_mutability slot true in + let slot = ensure_mutable slot in let bpos = lexpos ps in let decl = Ast.DECL_slot (Ast.KEY_ident ident, (span ps apos bpos slot)) @@ -979,7 +985,9 @@ and expand_tags (ps, "unexpected name type while expanding tag")) in let header = - Array.map (fun slot -> (clone_span ps item slot)) tup + Array.map (fun ty -> (clone_span ps item + { Ast.slot_mode = Ast.MODE_alias; + Ast.slot_ty = Some ty})) tup in let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in let cloned_params = diff --git a/src/boot/fe/parser.ml b/src/boot/fe/parser.ml index 5df44303..97cf8985 100644 --- a/src/boot/fe/parser.ml +++ b/src/boot/fe/parser.ml @@ -181,13 +181,11 @@ let err (str:string) (ps:pstate) = let (slot_nil:Ast.slot) = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; Ast.slot_ty = Some Ast.TY_nil } ;; let (slot_auto:Ast.slot) = { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = true; Ast.slot_ty = None } ;; diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml index e859d135..25352e5c 100644 --- a/src/boot/fe/pexp.ml +++ b/src/boot/fe/pexp.ml @@ -22,7 +22,7 @@ type pexp' = | PEXP_bind of (pexp * pexp option array) | PEXP_rec of ((Ast.ident * pexp) array * pexp option) | PEXP_tup of (pexp array) - | PEXP_vec of (Ast.slot * (pexp array)) + | PEXP_vec of (pexp array) | PEXP_port | PEXP_chan of (pexp option) | PEXP_binop of (Ast.binop * pexp * pexp) @@ -261,11 +261,10 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | VEC -> bump ps; - Ast.TY_vec (bracketed LBRACKET RBRACKET (parse_slot false) ps) + Ast.TY_vec (bracketed LBRACKET RBRACKET parse_ty ps) | IDENT _ -> Ast.TY_named (parse_name ps) - | TAG -> bump ps; let htab = Hashtbl.create 4 in @@ -273,7 +272,7 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = let ident = parse_ident ps in let tup = match peek ps with - LPAREN -> paren_comma_list (parse_slot false) ps + LPAREN -> paren_comma_list parse_ty ps | _ -> raise (err "tag variant missing argument list" ps) in htab_put htab (Ast.NAME_base (Ast.BASE_ident ident)) tup @@ -287,9 +286,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | REC -> bump ps; let parse_rec_entry ps = - let mut = parse_mutability ps in - let (slot, ident) = parse_slot_and_ident false ps in - (ident, apply_mutability slot mut) + let (ty, ident) = parse_ty_and_ident ps in + (ident, ty) in let entries = paren_comma_list parse_rec_entry ps in let labels = Array.map (fun (l, _) -> l) entries in @@ -300,8 +298,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | TUP -> bump ps; - let slots = paren_comma_list (parse_slot false) ps in - Ast.TY_tup slots + let tys = paren_comma_list parse_ty ps in + Ast.TY_tup tys | MACH m -> bump ps; @@ -333,6 +331,14 @@ and parse_atomic_ty (ps:pstate) : Ast.ty = | _ -> raise (unexpected ps) end + | AT -> + bump ps; + Ast.TY_exterior (parse_ty ps) + + | MUTABLE -> + bump ps; + Ast.TY_mutable (parse_ty ps) + | LPAREN -> begin bump ps; @@ -356,21 +362,15 @@ and flag (ps:pstate) (tok:token) : bool = and parse_mutability (ps:pstate) : bool = flag ps MUTABLE -and apply_mutability (slot:Ast.slot) (mut:bool) : Ast.slot = - { slot with Ast.slot_mutable = mut } - and parse_slot (aliases_ok:bool) (ps:pstate) : Ast.slot = - let mut = parse_mutability ps in let mode = match (peek ps, aliases_ok) with - (AT, _) -> bump ps; Ast.MODE_exterior - | (AND, true) -> bump ps; Ast.MODE_alias + (AND, true) -> bump ps; Ast.MODE_alias | (AND, false) -> raise (err "alias slot in prohibited context" ps) | _ -> Ast.MODE_interior in let ty = parse_ty ps in { Ast.slot_mode = mode; - Ast.slot_mutable = mut; Ast.slot_ty = Some ty } and parse_slot_and_ident @@ -381,6 +381,13 @@ and parse_slot_and_ident let ident = ctxt "slot and ident: ident" parse_ident ps in (slot, ident) +and parse_ty_and_ident + (ps:pstate) + : (Ast.ty * Ast.ident) = + let ty = ctxt "ty and ident: ty" parse_ty ps in + let ident = ctxt "ty and ident: ident" parse_ident ps in + (ty, ident) + and parse_slot_and_optional_ignored_ident (aliases_ok:bool) (ps:pstate) @@ -494,16 +501,9 @@ and parse_bottom_pexp (ps:pstate) : pexp = | VEC -> bump ps; begin - let slot = - match peek ps with - LBRACKET -> bracketed LBRACKET RBRACKET (parse_slot false) ps - | _ -> { Ast.slot_mode = Ast.MODE_interior; - Ast.slot_mutable = false; - Ast.slot_ty = None } - in let pexps = ctxt "vec pexp: exprs" parse_pexp_list ps in let bpos = lexpos ps in - span ps apos bpos (PEXP_vec (slot, pexps)) + span ps apos bpos (PEXP_vec pexps) end @@ -1088,7 +1088,9 @@ and desugar_expr_atom | PEXP_call _ | PEXP_bind _ | PEXP_spawn _ - | PEXP_custom _ -> + | PEXP_custom _ + | PEXP_exterior _ + | PEXP_mutable _ -> let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in let stmts = desugar_expr_init ps tmp pexp in (Array.append [| decl_stmt |] stmts, @@ -1101,31 +1103,6 @@ and desugar_expr_atom let (stmts, lval) = desugar_lval ps pexp in (stmts, Ast.ATOM_lval lval) - | PEXP_exterior _ -> - raise (err "exterior symbol in atom context" ps) - - | PEXP_mutable _ -> - raise (err "mutable keyword in atom context" ps) - - -and desugar_expr_mode_mut_atom - (ps:pstate) - (pexp:pexp) - : (Ast.stmt array * (Ast.mode * bool * Ast.atom)) = - let desugar_inner mode mut e = - let (stmts, atom) = desugar_expr_atom ps e in - (stmts, (mode, mut, atom)) - in - match pexp.node with - PEXP_mutable {node=(PEXP_exterior e); id=_} -> - desugar_inner Ast.MODE_exterior true e - | PEXP_exterior e -> - desugar_inner Ast.MODE_exterior false e - | PEXP_mutable e -> - desugar_inner Ast.MODE_interior true e - | _ -> - desugar_inner Ast.MODE_interior false pexp - and desugar_expr_atoms (ps:pstate) (pexps:pexp array) @@ -1138,12 +1115,6 @@ and desugar_opt_expr_atoms : (Ast.stmt array * Ast.atom option array) = arj1st (Array.map (desugar_opt_expr_atom ps) pexps) -and desugar_expr_mode_mut_atoms - (ps:pstate) - (pexps:pexp array) - : (Ast.stmt array * (Ast.mode * bool * Ast.atom) array) = - arj1st (Array.map (desugar_expr_mode_mut_atom ps) pexps) - and desugar_expr_init (ps:pstate) (dst_lval:Ast.lval) @@ -1253,10 +1224,10 @@ and desugar_expr_init Array.map begin fun (ident, pexp) -> - let (stmts, (mode, mut, atom)) = - desugar_expr_mode_mut_atom ps pexp + let (stmts, atom) = + desugar_expr_atom ps pexp in - (stmts, (ident, mode, mut, atom)) + (stmts, (ident, atom)) end args end @@ -1278,19 +1249,19 @@ and desugar_expr_init end | PEXP_tup args -> - let (arg_stmts, arg_mode_atoms) = - desugar_expr_mode_mut_atoms ps args + let (arg_stmts, arg_atoms) = + desugar_expr_atoms ps args in - let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_mode_atoms)) in + let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_atoms)) in aa arg_stmts [| stmt |] | PEXP_str s -> let stmt = ss (Ast.STMT_init_str (dst_lval, s)) in [| stmt |] - | PEXP_vec (slot, args) -> + | PEXP_vec args -> let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in - let stmt = ss (Ast.STMT_init_vec (dst_lval, slot, arg_atoms)) in + let stmt = ss (Ast.STMT_init_vec (dst_lval, arg_atoms)) in aa arg_stmts [| stmt |] | PEXP_port -> @@ -1315,11 +1286,19 @@ and desugar_expr_init in aa port_stmts [| chan_stmt |] - | PEXP_exterior _ -> - raise (err "exterior symbol in initialiser context" ps) + | PEXP_exterior arg -> + let (arg_stmts, arg_mode_atom) = + desugar_expr_atom ps arg + in + let stmt = ss (Ast.STMT_init_exterior (dst_lval, arg_mode_atom)) in + aa arg_stmts [| stmt |] - | PEXP_mutable _ -> - raise (err "mutable keyword in initialiser context" ps) + | PEXP_mutable arg -> + (* Initializing a local from a "mutable" atom is the same as + * initializing it from an immutable one; all locals are mutable + * anyways. So this is just a fall-through. + *) + desugar_expr_init ps dst_lval arg | PEXP_custom (n, a, b) -> let (arg_stmts, args) = desugar_expr_atoms ps a in -- cgit v1.2.3