From be5e40a58eb316bd56b6dd81703efc7cb0ca2ce8 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Fri, 4 Jan 2019 18:28:54 +0000 Subject: [PATCH 01/45] modified Ir.ml and desugar.ml to preserve types --- src/desugar.ml | 85 +++++++++++++++++++++++++++++++++++++++----------- src/ir.ml | 8 +++-- 2 files changed, 71 insertions(+), 22 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index d8ef7f918b3..8d38fb32433 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -1,12 +1,19 @@ open Source module S = Syntax module I = Ir +module T = Type -(* Combinators used in the desguaring *) +(* Combinators used in the desguaring *) -let true_lit : Ir.exp = I.LitE (S.BoolLit true) @@ no_region -let false_lit : Ir.exp = I.LitE (S.BoolLit false) @@ no_region +let bool_lit b : Ir.exp = + {Source.it = I.LitE (S.BoolLit b); + Source.at = no_region; + Source.note = {S.note_typ = T.bool; + S.note_eff = T.Triv} + } +let true_lit : Ir.exp = bool_lit true +let false_lit : Ir.exp = bool_lit false let apply_sign op l = Syntax.(match op, l with | PosOp, l -> l @@ -15,8 +22,8 @@ let apply_sign op l = Syntax.(match op, l with | _, _ -> raise (Invalid_argument "Invalid signed pattern") ) -let phrase ce f x = f ce x.it @@ x.at -let phrase' ce f x = f ce x.at x.note x.it @@ x.at +let phrase ce f x = {x with it = f ce x.it} +let phrase' ce f x = {x with it = f ce x.at x.note x.it} let rec exps ce es = List.map (exp ce) es @@ -34,7 +41,7 @@ let | S.TupE es -> I.TupE (exps ce es) | S.ProjE (e, i) -> I.ProjE (exp ce e, i) | S.OptE e -> I.OptE (exp ce e) - | S.ObjE (s, i, es) -> obj ce at s None i es + | S.ObjE (s, i, es) -> obj ce at s None i es note.S.note_typ | S.DotE (e, n) -> begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) @@ -74,29 +81,54 @@ let and field_to_dec ce (f : S.exp_field) : Ir.dec = match f.it.S.mut.it with - | S.Const -> I.LetD (I.VarP f.it.S.id @@ no_region, exp ce f.it.S.exp) @@ f.at - | S.Var -> I.VarD (f.it.S.id, exp ce f.it.S.exp) @@ f.at + | S.Const -> + {it = I.LetD ({it = I.VarP f.it.S.id; at = no_region; + note = {f.it.S.exp.note with S.note_eff = T.Triv} + }, + exp ce f.it.S.exp); + at = f.at; + note = { f.it.S.exp.note with S.note_typ = T.unit} + } + | S.Var -> + {it = I.VarD (f.it.S.id, exp ce f.it.S.exp); + at = f.at; + note = { f.it.S.exp.note with S.note_typ = T.unit} + } and field_to_obj_entry (f : S.exp_field) = match f.it.S.priv.it with | S.Private -> [] | S.Public -> [ (f.it.S.name, f.it.S.id) ] - and obj ce at s class_id self_id es = + and obj ce at s class_id self_id es obj_typ = match s.it with - | Type.Object _ -> build_obj ce at None self_id es + | Type.Object _ -> build_obj ce at None self_id es obj_typ | Type.Actor -> I.ActorE (self_id, exp_fields ce es) - and build_obj ce at class_id self_id es = + and build_obj ce at class_id self_id es obj_typ = I.BlockE ( List.map (field_to_dec ce) es @ - [ I.LetD ( - I.VarP self_id @@ at, - I.NewObjE - (Type.Object Type.Local @@ at, - List.concat (List.map field_to_obj_entry es)) @@ at - ) @@ at; - I.ExpD (I.VarE self_id @@ at) @@ at]) + [ {it = I.LetD ( + {it = I.VarP self_id; + at = at; + note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}, + {it = I.NewObjE + (Type.Object Type.Local @@ at, + List.concat (List.map field_to_obj_entry es)); + at = at; + note = {S.note_typ = obj_typ; S.note_eff = T.Triv}} + ); + at = no_region; + note = {S.note_typ = T.unit; + S.note_eff = T.Triv}}; + {it = I.ExpD {it = I.VarE self_id; + at; + note = {S.note_typ = obj_typ; + S.note_eff = T.Triv}}; + at = at; + note = {S.note_typ = obj_typ; + S.note_eff = T.Triv}}; + ]) and exp_fields ce fs = List.map (exp_field ce) fs and exp_field ce f = phrase ce exp_field' f @@ -115,8 +147,23 @@ let | S.TypD (i, ty, t) -> I.TypD (i, ty, t) | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in + let inst = List.map + (fun tp -> + match !(tp.note) with + | Some c -> T.Con(c,[]) + | None -> assert false) + tp in + let obj_typ = + match n.S.note_typ with + | T.Func(s,c,bds,dom,[rng]) -> + assert(List.length inst = List.length bds); + T.open_ inst rng + | _ -> assert false + in I.FuncD (cc, fun_id, tp, pat ce p, S.PrimT "dummy" @@ at, - obj ce at s (Some fun_id) self_id es @@ at) + {it = obj ce at s (Some fun_id) self_id es obj_typ; + at = at; + note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}) and cases ce cs = List.map (case ce) cs and case ce c = phrase ce case' c diff --git a/src/ir.ml b/src/ir.ml index 944aacda41a..5499b421778 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -1,6 +1,8 @@ (* Patterns *) -type pat = pat' Source.phrase +type 'a phrase = ('a,Syntax.typ_note) Source.annotated_phrase + +type pat = pat' phrase and pat' = | WildP (* wildcard *) | VarP of Syntax.id (* variable *) @@ -11,7 +13,7 @@ and pat' = (* Expressions *) -type exp = exp' Source.phrase +type exp = exp' phrase and exp' = | PrimE of string (* primitive *) | VarE of Syntax.id (* variable *) @@ -55,7 +57,7 @@ and case' = {pat : pat; exp : exp} (* Declarations *) -and dec = dec' Source.phrase +and dec = dec' phrase and dec' = | ExpD of exp (* plain expression *) | LetD of pat * exp (* immutable *) From e9d5dbb02978a375bc50a76e8d63176db98e1a2e Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 7 Jan 2019 18:14:14 +0000 Subject: [PATCH 02/45] tidy --- src/async.ml | 29 +++++++++-------------------- src/desugar.ml | 2 +- src/parser.mly | 34 +++++++++++++++++----------------- src/syntax.ml | 8 +++++--- src/syntaxops.ml | 18 +++++++++--------- 5 files changed, 41 insertions(+), 50 deletions(-) diff --git a/src/async.ml b/src/async.ml index 44598d27c35..207abde1902 100644 --- a/src/async.ml +++ b/src/async.ml @@ -33,14 +33,14 @@ let fullfillT as_seq typ = T.Func(T.Call T.Local, T.Returns, [], as_seq typ, []) let tupT ts = {it = TupT ts; at = no_region; - note = ()} + note = empty_typ_note} let unitT = tupT [] let funcT(s,bds,t1,t2) = {it = FuncT (s, bds, t1, t2); at = no_region; - note = ()} + note = empty_typ_note} let t_async as_seq t = T.Func (T.Call T.Local, T.Returns, [], [T.Func(T.Call T.Local, T.Returns, [],as_seq t,[])], []) @@ -56,10 +56,13 @@ let new_asyncT = let new_asyncE = idE ("@new_async"@@no_region) new_asyncT -let bogusT = PrimT "BogusT"@@no_region (* bogus, but we shouln't use it anymore *) - +let bogusT t= + { it = PrimT "BogusT" (* bogus, but we shouln't use it anymore *); + at = no_region; + note = { note_typ = t; note_eff = T.Triv}; + } let new_async t1 = - let call_new_async = callE new_asyncE [{it = bogusT; at = no_region; note = ref t1} ] (tupE[]) (T.seq (new_async_ret unary t1)) in + let call_new_async = callE new_asyncE [{it = bogusT t1; at = no_region; note = ref t1} ] (tupE[]) (T.seq (new_async_ret unary t1)) in let async = fresh_id (typ (projE call_new_async 0)) in let fullfill = fresh_id (typ (projE call_new_async 1)) in (async,fullfill),call_new_async @@ -102,20 +105,6 @@ let new_nary_async_reply t1 = let replyTT t = funcT(sharableS,[],t,unitT) -let shared_funcD f x e = - match f.it,x.it with - | VarE _, VarE _ -> - let note = {note_typ = T.Func(T.Call T.Sharable, T.Returns, [], as_seq (typ x), as_seq (typ e)); - note_eff = T.Triv} in - {it=FuncD(T.Sharable @@ no_region, (id_of_exp f), - [], - {it=VarP (id_of_exp x);at=no_region;note=x.note}, - PrimT "Any"@@no_region, (* bogus, but we shouldn't use it anymore *) - e); - at = no_region; - note;} - | _ -> assert false - let letEta e scope = match e.it with | VarE _ -> scope e (* pure, so reduce *) @@ -264,7 +253,7 @@ and t_exp' (exp:Syntax.exp) = let ((nary_async,nary_reply),def) = new_nary_async_reply t1 in (blockE [letP (tupP [varP nary_async; varP nary_reply]) def; funcD k v1 (nary_reply -*- v1); - shared_funcD post u (t_exp exp2 -*- k); + funcD post u (t_exp exp2 -*- k); expD (post -*- tupE[]); expD nary_async]) .it diff --git a/src/desugar.ml b/src/desugar.ml index 8d38fb32433..7ed9118734d 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -160,7 +160,7 @@ let T.open_ inst rng | _ -> assert false in - I.FuncD (cc, fun_id, tp, pat ce p, S.PrimT "dummy" @@ at, + I.FuncD (cc, fun_id, tp, pat ce p, {it = S.PrimT "dummy"; at = at; note = S.empty_typ_note}, {it = obj ce at s (Some fun_id) self_id es obj_typ; at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}) diff --git a/src/parser.mly b/src/parser.mly index b38a338fdeb..f0d23e04b78 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -54,9 +54,9 @@ let assign_op lhs rhs_f at = let share_typ t = match t.it with | ObjT ({it = Type.Object Type.Local; _} as s, tfs) -> - ObjT ({s with it = Type.Object Type.Sharable}, tfs) @@ t.at + { t with it = ObjT ({s with it = Type.Object Type.Sharable}, tfs)} | FuncT ({it = Type.Call Type.Local; _} as s, tbs, t1, t2) -> - FuncT ({s with it = Type.Call Type.Sharable}, tbs, t1, t2) @@ t.at + { t with it = FuncT ({s with it = Type.Call Type.Sharable}, tbs, t1, t2)} | _ -> t let share_typfield tf = @@ -194,43 +194,43 @@ typ_obj : typ_nullary : | LPAR t=typ RPAR - { ParT(t) @@ at $loc } + { ParT(t) @? at $loc } | LPAR ts=seplist1(typ_item, COMMA) RPAR - { TupT(ts) @@ at $sloc } + { TupT(ts) @? at $sloc } | x=id tso=typ_args? - { VarT(x, Lib.Option.get tso []) @@ at $sloc } + { VarT(x, Lib.Option.get tso []) @? at $sloc } | LBRACKET m=var_opt t=typ RBRACKET - { ArrayT(m, t) @@ at $sloc } + { ArrayT(m, t) @? at $sloc } | tfs=typ_obj - { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @@ at $sloc } + { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @? at $sloc } typ_post : | t=typ_nullary { t } | t=typ_post QUEST - { OptT(t) @@ at $sloc } + { OptT(t) @? at $sloc } typ_pre : | t=typ_post { t } | PRIM s=TEXT - { PrimT(s) @@ at $sloc } + { PrimT(s) @? at $sloc } | ASYNC t=typ_pre - { AsyncT(t) @@ at $sloc } + { AsyncT(t) @? at $sloc } | LIKE t=typ_pre - { LikeT(t) @@ at $sloc } + { LikeT(t) @? at $sloc } | s=obj_sort tfs=typ_obj { let tfs' = if s.it = Type.Object Type.Local then tfs else List.map share_typfield tfs - in ObjT(s, tfs') @@ at $sloc } + in ObjT(s, tfs') @? at $sloc } typ : | t=typ_pre { t } | s=func_sort_opt tps=typ_params_opt t1=typ_post ARROW t2=typ - { FuncT(s, tps, t1, t2) @@ at $sloc } + { FuncT(s, tps, t1, t2) @? at $sloc } typ_item : | id COLON t=typ { t } @@ -248,14 +248,14 @@ typ_field : { {id = x; typ = t; mut} @@ at $sloc } | x=id tps=typ_params_opt t1=typ_nullary t2=return_typ { let t = FuncT(Type.Call Type.Local @@ no_region, tps, t1, t2) - @@ span x.at t2.at in + @? span x.at t2.at in {id = x; typ = t; mut = Const @@ no_region} @@ at $sloc } typ_bind : | x=id SUB t=typ { {var = x; bound = t} @! at $sloc } | x=id - { {var = x; bound = PrimT "Any" @@ at $sloc} @! at $sloc } + { {var = x; bound = PrimT "Any" @? at $sloc} @! at $sloc } @@ -404,7 +404,7 @@ exp_nondec : { e } | LABEL x=id rt=return_typ_nullary? e=exp { let x' = ("continue " ^ x.it) @@ x.at in - let t = Lib.Option.get rt (TupT [] @@ at $sloc) in + let t = Lib.Option.get rt (TupT [] @? at $sloc) in let e' = match e.it with | WhileE (e1, e2) -> WhileE (e1, LabelE (x', t, e2) @? e2.at) @? e.at @@ -569,7 +569,7 @@ dec : func_dec : | tps=typ_params_opt p=pat_nullary rt=return_typ? fb=func_body - { let t = Lib.Option.get rt (TupT([]) @@ no_region) in + { let t = Lib.Option.get rt (TupT([]) @? no_region) in (* This is a hack to support local func declarations that return a computed async. These should be defined using RHS syntax EQ e to avoid the implicit AsyncE introduction around bodies declared as blocks *) diff --git a/src/syntax.ml b/src/syntax.ml index 943e2ab65ac..2238f807c7a 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -4,7 +4,6 @@ type typ_note = {note_typ : Type.typ; note_eff : Type.eff} let empty_typ_note = {note_typ = Type.Pre; note_eff = Type.Triv} - (* Identifiers *) type id = string Source.phrase @@ -24,7 +23,7 @@ type func_sort = Type.func_sort Source.phrase type mut = mut' Source.phrase and mut' = Const | Var -type typ = typ' Source.phrase +type typ = (typ',typ_note) Source.annotated_phrase and typ' = | PrimT of string (* primitive *) | VarT of id * typ list (* constructor *) @@ -205,7 +204,10 @@ and prog' = dec list let seqT ts = match ts with | [t] -> t - | ts -> {Source.it = TupT ts; at = Source.no_region; Source.note = ()} + | ts -> {Source.it = TupT ts; + at = Source.no_region; + Source.note = {note_typ = Type.Tup (List.map (fun t -> t.Source.note.note_typ) ts); + note_eff = Type.Triv}} let as_seqT t = match t.Source.it with diff --git a/src/syntaxops.ml b/src/syntaxops.ml index 0f50b675592..b11c78b3495 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -266,20 +266,20 @@ let expD exp = { exp with it = ExpD exp} let letE x exp1 exp2 = blockE [letD x exp1; expD exp2] -(* Mono-morphic function declaration *) +(* Mono-morphic function declaration, sharing inferred from f's type *) let funcD f x e = match f.it,x.it with | VarE _, VarE _ -> - let note = {note_typ = T.Func(T.Call T.Local, T.Returns, [], T.as_seq (typ x), T.as_seq (typ e)); - note_eff = T.Triv} in - assert (f.note = note); - {it=FuncD(T.Local @@ no_region, (id_of_exp f), + let sharing = match f.note.note_typ with + | T.Func(T.Call sharing, _, _, _, _) -> sharing + | _ -> assert false in + {it=FuncD(sharing @@ no_region, (id_of_exp f), [], - {it=VarP (id_of_exp x);at=no_region;note=x.note}, - PrimT "Any"@@no_region, (* bogus, but we shouldn't use it anymore *) + {it = VarP (id_of_exp x); at = no_region; note = x.note}, + {it = PrimT "Any"; at = no_region; note = empty_typ_note }, (* bogus, but we shouldn't use it anymore *) e); at = no_region; - note;} + note = f.note} | _ -> failwith "Impossible: funcD" @@ -292,7 +292,7 @@ let nary_funcD f xs e = id_of_exp f, [], seqP (List.map varP xs), - PrimT "Any"@@no_region, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = empty_typ_note }, (* bogus, but we shouldn't use it anymore *) e); at = no_region; note = f.note;} From e1e93b8d8ce4b796d08f929779206a93800d393b Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 7 Jan 2019 19:41:32 +0000 Subject: [PATCH 03/45] use semantic, not syntactic types in IR --- src/arrange_ir.ml | 17 ++++++------ src/arrange_type.ml | 63 +++++++++++++++++++++++++++++++++++++++++++++ src/async.ml | 11 ++++++-- src/desugar.ml | 10 +++---- src/ir.ml | 8 +++--- src/syntax.ml | 4 +-- src/syntaxops.ml | 13 +++++----- src/typing.ml | 5 ++++ 8 files changed, 103 insertions(+), 28 deletions(-) create mode 100644 src/arrange_type.ml diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index c461f77c8fd..b7298ba386d 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -1,8 +1,11 @@ open Source +open Arrange_type (* currently not used *) open Ir open Wasm.Sexpr -let ($$) head inner = Node (head, inner) +(* for concision, we shadow the imported definition of [Array_type.typ] and pretty print types instead *) + +let typ t = Atom (Type.string_of_typ t) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] @@ -18,7 +21,7 @@ let rec exp e = match e.it with | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] | ArrayE (m, es) -> "ArrayE" $$ [Arrange.mut m] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] - | CallE (cc, e1, ts, e2) -> "CallE" $$ [call_conv cc; exp e1] @ List.map Arrange.typ ts @ [exp e2] + | CallE (cc, e1, ts, e2) -> "CallE" $$ [call_conv cc; exp e1] @ List.map typ ts @ [exp e2] | BlockE ds -> "BlockE" $$ List.map dec ds | IfE (e1, e2, e3) -> "IfE" $$ [exp e1; exp e2; exp e3] | SwitchE (e, cs) -> "SwitchE" $$ [exp e] @ List.map case cs @@ -26,7 +29,7 @@ let rec exp e = match e.it with | LoopE (e1, None) -> "LoopE" $$ [exp e1] | LoopE (e1, Some e2) -> "LoopE" $$ [exp e1; exp e2] | ForE (p, e1, e2) -> "ForE" $$ [pat p; exp e1; exp e2] - | LabelE (i, t, e) -> "LabelE" $$ [id i; Arrange.typ t; exp e] + | LabelE (i, t, e) -> "LabelE" $$ [id i; typ t; exp e] | BreakE (i, e) -> "BreakE" $$ [id i; exp e] | RetE e -> "RetE" $$ [exp e] | AsyncE e -> "AsyncE" $$ [exp e] @@ -51,13 +54,9 @@ and pat p = match p.it with and case c = "case" $$ [pat c.it.pat; exp c.it.exp] -and typ t = Atom (Type.string_of_typ t) - and exp_field (ef : exp_field) = (Syntax.string_of_name ef.it.name.it) $$ [id ef.it.id; exp ef.it.exp; Arrange.mut ef.it.mut; Arrange.priv ef.it.priv] -and id i = Atom i.it - and name n = Atom (Syntax.string_of_name n.it) and call_conv cc = Atom (Value.string_of_call_conv cc) @@ -67,8 +66,8 @@ and dec d = match d.it with | LetD (p, e) -> "LetD" $$ [pat p; exp e] | VarD (i, e) -> "VarD" $$ [id i; exp e] | FuncD (cc, i, tp, p, t, e) -> - "FuncD" $$ [call_conv cc; id i] @ List.map Arrange.typ_bind tp @ [pat p; Arrange.typ t; exp e] + "FuncD" $$ [call_conv cc; id i] @ List.map Arrange.typ_bind tp @ [pat p; typ t; exp e] | TypD (i, tp, t) -> - "TypD" $$ [id i] @ List.map Arrange.typ_bind tp @ [Arrange.typ t] + "TypD" $$ [id i] @ List.map Arrange.typ_bind tp @ [typ t] and prog prog = "BlockE" $$ List.map dec prog.it diff --git a/src/arrange_type.ml b/src/arrange_type.ml new file mode 100644 index 00000000000..86622214469 --- /dev/null +++ b/src/arrange_type.ml @@ -0,0 +1,63 @@ +open Source +open Type +open Wasm.Sexpr + +let ($$) head inner = Node (head, inner) + +let id i = Atom i.it + +let rec sharing sh = match sh with + | Type.Local -> "Local" + | Type.Sharable -> "Sharable" + +and control c = match c with + | Type.Returns -> "Returns" + | Type.Promises -> "Promises" + +and obj_sort s = match s with + | Type.Object sh -> Atom ("Object " ^ sharing sh) + | Type.Actor -> Atom "Actor" + +and func_sort s = match s with + | Type.Call sh -> Atom ("Call " ^ sharing sh) + | Type.Construct -> Atom "Construct" + +and prim p = match p with + | Null -> Atom "Null" + | Bool -> Atom "Bool" + | Nat -> Atom "Nat" + | Int -> Atom "Int" + | Word8 -> Atom "Word8" + | Word16 -> Atom "Word16" + | Word32 -> Atom "Word32" + | Word64 -> Atom "Word64" + | Float -> Atom "Float" + | Char -> Atom "Char" + | Text -> Atom "Text" + +and con c = Atom (Con.to_string c) + +let rec typ (t:Type.typ) = match t with + | Var (s, i) -> "Var" $$ [Atom s; Atom (string_of_int i)] + | Con (c,ts) -> "Con" $$ (con c::List.map typ ts) + | Prim p -> "Prim" $$ [prim p] + | Obj (s, ts) -> "Obj" $$ [obj_sort s] @ List.map typ_field ts + | Array t -> "Array" $$ [typ t] + | Opt t -> "Opt" $$ [typ t] + | Tup ts -> "Tup" $$ List.map typ ts + | Func (s, c, tbs, at, rt) -> "Func" $$ [func_sort s; Atom (control c)] @ List.map typ_bind tbs @ [ "" $$ (List.map typ at); "" $$ (List.map typ rt)] + | Async t -> "Async" $$ [typ t] + | Like t -> "Like" $$ [typ t] + | Mut t -> "Mut" $$ [typ t] + | Class -> Atom "Class" + | Shared -> Atom "Shared" + | Any -> Atom "Any" + | Non -> Atom "Non" + | Pre -> Atom "Pre" + +and typ_bind (tb : Type.bind) = + tb.var $$ [typ tb.bound] + +and typ_field (tf : Type.field) = + tf.name $$ [typ tf.typ] + diff --git a/src/async.ml b/src/async.ml index 207abde1902..7180898e556 100644 --- a/src/async.ml +++ b/src/async.ml @@ -33,7 +33,9 @@ let fullfillT as_seq typ = T.Func(T.Call T.Local, T.Returns, [], as_seq typ, []) let tupT ts = {it = TupT ts; at = no_region; - note = empty_typ_note} + note = + {note_typ = T.Tup (List.map (fun t -> t.note.note_typ) ts); + note_eff = T.Triv}} let unitT = tupT [] @@ -61,8 +63,13 @@ let bogusT t= at = no_region; note = { note_typ = t; note_eff = T.Triv}; } + let new_async t1 = - let call_new_async = callE new_asyncE [{it = bogusT t1; at = no_region; note = ref t1} ] (tupE[]) (T.seq (new_async_ret unary t1)) in + let call_new_async = + callE new_asyncE + [{it = bogusT t1; at = no_region; note = ref t1}] + (tupE[]) + (T.seq (new_async_ret unary t1)) in let async = fresh_id (typ (projE call_new_async 0)) in let fullfill = fresh_id (typ (projE call_new_async 1)) in (async,fullfill),call_new_async diff --git a/src/desugar.ml b/src/desugar.ml index 7ed9118734d..9891bcd4ad4 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -54,7 +54,7 @@ let | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in - let inst = List.map (fun t -> t.Source.it ) inst in + let inst = List.map (fun t -> !(t.Source.note)) inst in I.CallE (cc, exp ce e1, inst, exp ce e2) | S.BlockE ds -> I.BlockE (decs ce ds) | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) @@ -66,7 +66,7 @@ let | S.LoopE (e1, None) -> I.LoopE (exp ce e1, None) | S.LoopE (e1, Some e2) -> I.LoopE (exp ce e1, Some (exp ce e2)) | S.ForE (p, e1, e2) -> I.ForE (pat ce p, exp ce e1, exp ce e2) - | S.LabelE (l, t, e) -> I.LabelE (l, t, exp ce e) + | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note.S.note_typ, exp ce e) | S.BreakE (l, e) -> I.BreakE (l, exp ce e) | S.RetE e -> I.RetE (exp ce e) | S.AsyncE e -> I.AsyncE (exp ce e) @@ -143,8 +143,8 @@ let | S.VarD (i, e) -> I.VarD (i, exp ce e) | S.FuncD (s, i, tp, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, tp, pat ce p, ty, exp ce e) - | S.TypD (i, ty, t) -> I.TypD (i, ty, t) + I.FuncD (cc, i, tp, pat ce p, ty.note.S.note_typ, exp ce e) + | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note.S.note_typ) | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map @@ -160,7 +160,7 @@ let T.open_ inst rng | _ -> assert false in - I.FuncD (cc, fun_id, tp, pat ce p, {it = S.PrimT "dummy"; at = at; note = S.empty_typ_note}, + I.FuncD (cc, fun_id, tp, pat ce p, obj_typ, (* TBR *) {it = obj ce at s (Some fun_id) self_id es obj_typ; at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}) diff --git a/src/ir.ml b/src/ir.ml index 5499b421778..96ad3fcb76d 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -30,14 +30,14 @@ and exp' = | AssignE of exp * exp (* assignment *) | ArrayE of Syntax.mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) - | CallE of Value. call_conv * exp * Syntax.typ list * exp (* function call *) + | CallE of Value. call_conv * exp * Type.typ list * exp (* function call *) | BlockE of dec list (* block *) | IfE of exp * exp * exp (* conditional *) | SwitchE of exp * case list (* switch *) | WhileE of exp * exp (* while-do loop *) | LoopE of exp * exp option (* do-while loop *) | ForE of pat * exp * exp (* iteration *) - | LabelE of Syntax.id * Syntax.typ * exp (* label *) + | LabelE of Syntax.id * Type.typ * exp (* label *) | BreakE of Syntax.id * exp (* break *) | RetE of exp (* return *) | AsyncE of exp (* async *) @@ -62,8 +62,8 @@ and dec' = | ExpD of exp (* plain expression *) | LetD of pat * exp (* immutable *) | VarD of Syntax.id * exp (* mutable *) - | FuncD of Value.call_conv * Syntax.id * Syntax.typ_bind list * pat * Syntax.typ * exp (* function *) - | TypD of Syntax.id * Syntax.typ_bind list * Syntax.typ (* type *) + | FuncD of Value.call_conv * Syntax.id * Syntax.typ_bind list * pat * Type.typ * exp (* function *) + | TypD of Syntax.id * Syntax.typ_bind list * Type.typ (* type *) (* Program *) diff --git a/src/syntax.ml b/src/syntax.ml index 2238f807c7a..833a8e4d2f0 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -10,8 +10,8 @@ type id = string Source.phrase (* Names (not alpha-convertible), used for field and class names *) type name = name' Source.phrase -and name' = Name of string -let string_of_name (Name s ) = s +and name' = Name of string +let string_of_name (Name s ) = s (* Types *) diff --git a/src/syntaxops.ml b/src/syntaxops.ml index b11c78b3495..4bdd5feb866 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -270,13 +270,13 @@ let letE x exp1 exp2 = blockE [letD x exp1; expD exp2] let funcD f x e = match f.it,x.it with | VarE _, VarE _ -> - let sharing = match f.note.note_typ with - | T.Func(T.Call sharing, _, _, _, _) -> sharing + let sharing,t1,t2 = match f.note.note_typ with + | T.Func(T.Call sharing, _, _, ts1, ts2) -> sharing,T.seq ts1, T.seq ts2 | _ -> assert false in {it=FuncD(sharing @@ no_region, (id_of_exp f), [], - {it = VarP (id_of_exp x); at = no_region; note = x.note}, - {it = PrimT "Any"; at = no_region; note = empty_typ_note }, (* bogus, but we shouldn't use it anymore *) + {it = VarP (id_of_exp x); at = no_region; note = {note_typ = t1; note_eff = T.Triv}}, + {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) e); at = no_region; note = f.note} @@ -287,12 +287,13 @@ let funcD f x e = let nary_funcD f xs e = match f.it,f.note.note_typ with | VarE _, - T.Func(T.Call sharing,_,_,_,_) -> + T.Func(T.Call sharing,_,_,_,ts2) -> + let t2 = T.seq ts2 in {it=FuncD(sharing @@ no_region, id_of_exp f, [], seqP (List.map varP xs), - {it = PrimT "Any"; at = no_region; note = empty_typ_note }, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) e); at = no_region; note = f.note;} diff --git a/src/typing.ml b/src/typing.ml index f4aae00b4e6..c7d9b4e7625 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -133,6 +133,11 @@ let infer_mut mut : T.typ -> T.typ = | Var -> fun t -> T.Mut t let rec check_typ env typ : T.typ = + let t = check_typ' env typ in + typ.note <- {note_typ = t; note_eff = T.Triv}; + t + +and check_typ' env typ : T.typ = match typ.it with | VarT (id, typs) -> (match T.Env.find_opt id.it env.typs with From f44d211b2f471a34d97539493fcd5f57bf82bf4c Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 11:57:50 +0000 Subject: [PATCH 04/45] remove inst type from syntax (now redundant) --- src/arrange.ml | 4 +--- src/async.ml | 10 +++------- src/desugar.ml | 2 +- src/parser.mly | 3 +-- src/syntax.ml | 6 ++---- src/syntaxops.mli | 2 +- src/tailcall.ml | 2 +- src/typing.ml | 4 +--- 8 files changed, 11 insertions(+), 22 deletions(-) diff --git a/src/arrange.ml b/src/arrange.ml index bdcf92c657e..7375d89455b 100644 --- a/src/arrange.ml +++ b/src/arrange.ml @@ -17,7 +17,7 @@ let rec exp e = match e.it with | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] | ArrayE (m, es) -> "ArrayE" $$ [mut m] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] - | CallE (e1, ts, e2) -> "CallE" $$ [exp e1] @ List.map inst ts @ [exp e2] + | CallE (e1, ts, e2) -> "CallE" $$ [exp e1] @ List.map typ ts @ [exp e2] | BlockE ds -> "BlockE" $$ List.map dec ds | NotE e -> "NotE" $$ [exp e] | AndE (e1, e2) -> "AndE" $$ [exp e1; exp e2] @@ -135,8 +135,6 @@ and typ_bind (tb : typ_bind) and exp_field (ef : exp_field) = (string_of_name ef.it.name.it) $$ [id ef.it.id; exp ef.it.exp; mut ef.it.mut; priv ef.it.priv] -and inst t = typ t.it - and operator_type t = Atom (Type.string_of_typ t) and typ t = match t.it with diff --git a/src/async.ml b/src/async.ml index 7180898e556..f569322146d 100644 --- a/src/async.ml +++ b/src/async.ml @@ -67,7 +67,7 @@ let bogusT t= let new_async t1 = let call_new_async = callE new_asyncE - [{it = bogusT t1; at = no_region; note = ref t1}] + [bogusT t1] (tupE[]) (T.seq (new_async_ret unary t1)) in let async = fresh_id (typ (projE call_new_async 0)) in @@ -273,7 +273,7 @@ and t_exp' (exp:Syntax.exp) = in let exp1' = t_exp exp1 in let exp2' = t_exp exp2 in - let typs = List.map t_inst typs in + let typs = List.map t_typT typs in let ((nary_async,nary_reply),def) = new_nary_async_reply t2 in let _ = letEta in (blockE (letP (tupP [varP nary_async; varP nary_reply]) def:: @@ -283,7 +283,7 @@ and t_exp' (exp:Syntax.exp) = expD nary_async])))) .it | CallE (exp1, typs, exp2) -> - CallE(t_exp exp1, List.map t_inst typs, t_exp exp2) + CallE(t_exp exp1, List.map t_typT typs, t_exp exp2) | BlockE decs -> BlockE (t_decs decs) | NotE exp1 -> @@ -418,10 +418,6 @@ and t_asyncT t = unitT) -and t_inst t : inst = - { it = t_typT t.it; - at = t.at; - note = ref (t_typ (!(t.note)))} and t_typT t = { t with it = t_typT' t.it } diff --git a/src/desugar.ml b/src/desugar.ml index 9891bcd4ad4..9240a7c533a 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -54,7 +54,7 @@ let | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in - let inst = List.map (fun t -> !(t.Source.note)) inst in + let inst = List.map (fun t -> t.Source.note.S.note_typ) inst in I.CallE (cc, exp ce e1, inst, exp ce e2) | S.BlockE ds -> I.BlockE (decs ce ds) | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) diff --git a/src/parser.mly b/src/parser.mly index f0d23e04b78..3fdb3084cf8 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -353,8 +353,7 @@ exp_post : { DotE(e, {x with it = Name x.it}) @? at $sloc } | e1=exp_post tso=typ_args? e2=exp_nullary { let typ_args = Lib.Option.get tso [] in - let typ_insts = List.map (fun typ_arg -> {it = typ_arg; at = typ_arg.at; note = ref Type.Pre}) typ_args in - CallE(e1, typ_insts, e2) @? at $sloc } + CallE(e1, typ_args, e2) @? at $sloc } exp_un : | e=exp_post diff --git a/src/syntax.ml b/src/syntax.ml index 833a8e4d2f0..f583ea21b0c 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -98,6 +98,7 @@ type relop = (* Patterns *) +(* TODO: replace typ_note by typ (pats don't have effects *) type pat = (pat', typ_note) Source.annotated_phrase and pat' = | WildP (* wildcard *) @@ -122,9 +123,6 @@ and pat_field' = {id : id; pat : pat} type priv = priv' Source.phrase and priv' = Public | Private -(* type instantiations *) -type inst = (typ, Type.typ ref) Source.annotated_phrase - (* Filled in for overloaded operators during type checking. Initially Type.Pre. *) type op_type = Type.typ ref @@ -144,7 +142,7 @@ and exp' = | AssignE of exp * exp (* assignment *) | ArrayE of mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) - | CallE of exp * inst list * exp (* function call *) + | CallE of exp * typ list * exp (* function call *) | BlockE of dec list (* block *) | NotE of exp (* negation *) | AndE of exp * exp (* conjunction *) diff --git a/src/syntaxops.mli b/src/syntaxops.mli index 96c9e16a1ac..6a920ce4078 100644 --- a/src/syntaxops.mli +++ b/src/syntaxops.mli @@ -49,7 +49,7 @@ val letE : var -> exp -> exp -> exp val unitE : exp val boolE : bool -> exp -val callE : exp -> Syntax.inst list -> exp -> typ -> exp +val callE : exp -> Syntax.typ list -> exp -> typ -> exp val ifE : exp -> exp -> exp -> typ -> exp val dotE : exp -> name -> typ -> exp diff --git a/src/tailcall.ml b/src/tailcall.ml index fe150feec4d..efe22e3738b 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -64,7 +64,7 @@ let bind env i info = let are_generic_insts tbs insts = List.for_all2 (fun tb inst -> - match !(tb.note),!(inst.note) with + match !(tb.note),inst.note.note_typ with | Some c1, Con(c2,[]) -> c1 = c2 (* conservative, but safe *) | Some c1, _ -> false | None,_ -> assert false) tbs insts diff --git a/src/typing.ml b/src/typing.ml index c7d9b4e7625..f344369b363 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -248,10 +248,8 @@ and check_typ_bounds env (tbs : T.bind list) typs at : T.typ list = | [], _ -> local_error env at "too many type arguments"; [] | _, [] -> error env at "too few type arguments" -and check_inst_bounds env tbs (insts:inst list) at = - let typs = List.map (fun inst -> inst.it) insts in +and check_inst_bounds env tbs typs at = let tys = check_typ_bounds env tbs typs at in - List.iter2 (fun inst ty -> inst.note := ty) insts tys; tys (* Literals *) From cb4cd53990798758bca181425a5d1feb6beda2c6 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 12:00:29 +0000 Subject: [PATCH 05/45] update tests to reflect new arrange output --- .../ok/counter-class.wasm.stderr.ok | 8 ++--- test/run/ok/account.wasm.stderr.ok | 22 ++++++------ test/run/ok/bank-example.wasm.stderr.ok | 34 +++++++++---------- 3 files changed, 32 insertions(+), 32 deletions(-) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 4a8a2f469a6..0ec08be44e2 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -8,7 +8,7 @@ non-closed actor: (ActorE (shared 0 -> 0) dec (TupP) - (TupT) + () (BlockE (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) @@ -25,7 +25,7 @@ non-closed actor: (ActorE (shared 1 -> 0) read (VarP $1) - (TupT) + () (BlockE (LetD (TupP) (TupE)) (ExpD @@ -36,7 +36,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $0) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $0) (BlockE (ExpD (VarE c)))) ) ) @@ -45,7 +45,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $2) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) ) ) diff --git a/test/run/ok/account.wasm.stderr.ok b/test/run/ok/account.wasm.stderr.ok index f1b111c40ed..80de697a794 100644 --- a/test/run/ok/account.wasm.stderr.ok +++ b/test/run/ok/account.wasm.stderr.ok @@ -8,7 +8,7 @@ non-closed actor: (ActorE (shared 1 -> 0) getBalance (VarP $8) - (TupT) + () (BlockE (LetD (TupP) (TupE)) (ExpD @@ -19,7 +19,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $0) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $0) @@ -34,7 +34,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $9) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $8) (VarE $9)) ) ) @@ -53,7 +53,7 @@ non-closed actor: (ActorE (shared 2 -> 0) split (TupP (VarP amount) (VarP $10)) - (TupT) + () (BlockE (ExpD (CallE @@ -63,7 +63,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $1) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $1) @@ -92,7 +92,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $11) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $10) (VarE $11)) ) ) @@ -111,7 +111,7 @@ non-closed actor: (ActorE (shared 1 -> 0) join (VarP account) - (TupT) + () (BlockE (ExpD (AssertE (IsE (VarE account) (VarE Account)))) (LetD (VarP amount) (VarE balance)) @@ -136,7 +136,7 @@ non-closed actor: (ActorE (shared 2 -> 0) credit (TupP (VarP amount) (VarP caller)) - (TupT) + () (BlockE (ExpD (AssertE (IsE (VarE this) (VarE caller)))) (ExpD @@ -158,7 +158,7 @@ non-closed actor: (ActorE (shared 2 -> 0) isCompatible (TupP (VarP account) (VarP $12)) - (TupT) + () (BlockE (ExpD (CallE @@ -168,7 +168,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $2) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $2) @@ -191,7 +191,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $13) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $12) (VarE $13)) ) ) diff --git a/test/run/ok/bank-example.wasm.stderr.ok b/test/run/ok/bank-example.wasm.stderr.ok index 45a674ee096..b561c7dbe90 100644 --- a/test/run/ok/bank-example.wasm.stderr.ok +++ b/test/run/ok/bank-example.wasm.stderr.ok @@ -14,7 +14,7 @@ non-closed actor: (ActorE (shared 1 -> 0) getIssuer (VarP $32) - (TupT) + () (BlockE (LetD (TupP) (TupE)) (ExpD @@ -25,7 +25,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $0) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $0) @@ -40,7 +40,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $33) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $32) (VarE $33)) ) ) @@ -59,7 +59,7 @@ non-closed actor: (ActorE (shared 1 -> 0) getReserve (VarP $34) - (TupT) + () (BlockE (LetD (TupP) (TupE)) (ExpD @@ -70,7 +70,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $1) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $1) @@ -85,7 +85,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $35) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $34) (VarE $35)) ) ) @@ -108,7 +108,7 @@ non-closed actor: (ActorE (shared 1 -> 0) getBalance (VarP $38) - (TupT) + () (BlockE (LetD (TupP) (TupE)) (ExpD @@ -119,7 +119,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $3) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $3) @@ -134,7 +134,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $39) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $38) (VarE $39)) ) ) @@ -153,7 +153,7 @@ non-closed actor: (ActorE (shared 2 -> 0) split (TupP (VarP amount) (VarP $40)) - (TupT) + () (BlockE (ExpD (CallE @@ -163,7 +163,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $4) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $4) @@ -192,7 +192,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $41) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $40) (VarE $41)) ) ) @@ -211,7 +211,7 @@ non-closed actor: (ActorE (shared 1 -> 0) join (VarP account) - (TupT) + () (BlockE (ExpD (AssertE (IsE (VarE account) (VarE Account)))) (LetD (VarP amount) (VarE balance)) @@ -236,7 +236,7 @@ non-closed actor: (ActorE (shared 2 -> 0) credit (TupP (VarP amount) (VarP caller)) - (TupT) + () (BlockE (ExpD (AssertE (IsE (VarE self) (VarE caller)))) (ExpD @@ -258,7 +258,7 @@ non-closed actor: (ActorE (shared 2 -> 0) isCompatible (TupP (VarP account) (VarP $42)) - (TupT) + () (BlockE (ExpD (CallE @@ -268,7 +268,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $5) - (PrimT Any) + () (CallE ( 1 -> 0) (VarE $5) @@ -291,7 +291,7 @@ non-closed actor: (ActorE ( 1 -> 0) $lambda (VarP $43) - (PrimT Any) + () (CallE (shared 1 -> 0) (VarE $42) (VarE $43)) ) ) From 535449c9da9b88471513760a845347a21e6c865d Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 12:10:05 +0000 Subject: [PATCH 06/45] simplify note on typ_bind to typ from Con.t ref --- src/desugar.ml | 6 +++--- src/parser.mly | 2 +- src/syntax.ml | 2 +- src/tailcall.ml | 8 ++++---- src/typing.ml | 2 +- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index 9240a7c533a..cbabc86ad00 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -149,9 +149,9 @@ let let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map (fun tp -> - match !(tp.note) with - | Some c -> T.Con(c,[]) - | None -> assert false) + match tp.note with + | Type.Pre -> assert false + | t -> t) tp in let obj_typ = match n.S.note_typ with diff --git a/src/parser.mly b/src/parser.mly index 3fdb3084cf8..b0fe7e73dc9 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -21,7 +21,7 @@ let positions_to_region position1 position2 = let at (startpos, endpos) = positions_to_region startpos endpos let (@?) it at = {it; at; note = empty_typ_note} -let (@!) it at = {it; at; note = ref None} +let (@!) it at = {it; at; note = Type.Pre} let dup_var x = VarE (x.it @@ x.at) @? x.at diff --git a/src/syntax.ml b/src/syntax.ml index f583ea21b0c..07509551b15 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -43,7 +43,7 @@ and typ' = and typ_field = typ_field' Source.phrase and typ_field' = {id : id; typ : typ; mut : mut} -and typ_bind = (typ_bind', Con.t option ref) Source.annotated_phrase +and typ_bind = (typ_bind', Type.typ) Source.annotated_phrase and typ_bind' = {var : id; bound : typ} diff --git a/src/tailcall.ml b/src/tailcall.ml index efe22e3738b..2d544be28da 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -64,10 +64,10 @@ let bind env i info = let are_generic_insts tbs insts = List.for_all2 (fun tb inst -> - match !(tb.note),inst.note.note_typ with - | Some c1, Con(c2,[]) -> c1 = c2 (* conservative, but safe *) - | Some c1, _ -> false - | None,_ -> assert false) tbs insts + match tb.note,inst.note.note_typ with + | Con(c1,[]), Con(c2,[]) -> c1 = c2 (* conservative, but safe *) + | Con(c1,[]), _ -> false + | _,_ -> assert false) tbs insts let rec tailexp env e = {e with it = exp' env e} diff --git a/src/typing.ml b/src/typing.ml index f344369b363..fa2c4e5f9f0 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -217,7 +217,7 @@ and check_typ_field env s typ_field : T.field = and check_typ_binds env typ_binds : T.con list * T.typ list * typ_env * con_env = let xs = List.map (fun typ_bind -> typ_bind.it.var.it) typ_binds in let cs = List.map (fun x -> Con.fresh x) xs in - List.iter2 (fun typ_bind c -> typ_bind.note := Some c) typ_binds cs; + List.iter2 (fun typ_bind c -> typ_bind.note <- T.Con(c,[])) typ_binds cs; let te = List.fold_left2 (fun te typ_bind c -> let id = typ_bind.it.var in if T.Env.mem id.it te then From d828378498fb46f705842b33c595e02d5bd751c6 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 12:34:20 +0000 Subject: [PATCH 07/45] simplify pat annotations to typ from note_typ --- src/async.ml | 7 ++----- src/awaitopt.ml | 6 +++--- src/coverage.ml | 2 +- src/desugar.ml | 5 +++-- src/interpret.ml | 2 +- src/ir.ml | 2 +- src/parser.mly | 20 ++++++++++---------- src/syntax.ml | 3 +-- src/syntaxops.ml | 18 ++++++++++-------- src/tailcall.ml | 2 +- src/typing.ml | 8 ++++---- 11 files changed, 37 insertions(+), 38 deletions(-) diff --git a/src/async.ml b/src/async.ml index f569322146d..adb87e94a2b 100644 --- a/src/async.ml +++ b/src/async.ml @@ -63,7 +63,7 @@ let bogusT t= at = no_region; note = { note_typ = t; note_eff = T.Triv}; } - + let new_async t1 = let call_new_async = callE new_asyncE @@ -390,8 +390,7 @@ and t_fields fields = and t_pat pat = { pat with it = t_pat' pat.it; - note = {note_typ = t_typ pat.note.note_typ; - note_eff = pat.note.note_eff}} + note = t_typ pat.note} and t_pat' pat = match pat with @@ -417,8 +416,6 @@ and t_asyncT t = funcT(localS,[],t,unitT), unitT) - - and t_typT t = { t with it = t_typT' t.it } diff --git a/src/awaitopt.ml b/src/awaitopt.ml index 6f9887bcf41..86bef5367f3 100644 --- a/src/awaitopt.ml +++ b/src/awaitopt.ml @@ -339,7 +339,7 @@ and c_loop_some context k e1 e2 = and c_for context k pat e1 e2 = let v1 = fresh_id (typ e1) in - let next_typ = (T.Func(T.Call T.Local, T.Returns, [], [], [T.Opt (typ pat)])) in + let next_typ = (T.Func(T.Call T.Local, T.Returns, [], [], [T.Opt pat.note])) in let dotnext v = dotE v nextN next_typ -*- unitE in let loop = fresh_id (contT T.unit) in let v2 = fresh_id T.unit in @@ -588,7 +588,7 @@ and declare_id id typ exp = and declare_pat pat exp : exp = match pat.it with | WildP | LitP _ | SignP _ -> exp - | VarP id -> declare_id id (pat.note.note_typ) exp + | VarP id -> declare_id id pat.note exp | TupP pats -> declare_pats pats exp | OptP pat1 -> declare_pat pat1 exp | AltP (pat1, pat2) -> declare_pat pat1 exp @@ -609,7 +609,7 @@ and rename_pat' pat = | WildP -> (PatEnv.empty, pat.it) | LitP _ | SignP _ -> (PatEnv.empty, pat.it) | VarP id -> - let v = fresh_id pat.note.note_typ in + let v = fresh_id pat.note in (PatEnv.singleton id.it v, VarP (id_of_exp v)) | TupP pats -> diff --git a/src/coverage.ml b/src/coverage.ml index 3d2b96337ee..16d2a2ff54a 100644 --- a/src/coverage.ml +++ b/src/coverage.ml @@ -63,7 +63,7 @@ let rec match_pat ce ctxt desc pat t sets = | LitP lit -> match_lit ce ctxt desc (value_of_lit !lit) t sets | SignP (op, lit) -> - let f = Operator.unop pat.note.note_typ op in + let f = Operator.unop pat.note op in match_lit ce ctxt desc (f (value_of_lit !lit)) t sets | TupP pats -> let ts = Type.as_tup (Type.promote ce t) in diff --git a/src/desugar.ml b/src/desugar.ml index cbabc86ad00..3b4c1fb22f3 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -83,7 +83,7 @@ let match f.it.S.mut.it with | S.Const -> {it = I.LetD ({it = I.VarP f.it.S.id; at = no_region; - note = {f.it.S.exp.note with S.note_eff = T.Triv} + note = f.it.S.exp.note.S.note_typ }, exp ce f.it.S.exp); at = f.at; @@ -111,7 +111,8 @@ let [ {it = I.LetD ( {it = I.VarP self_id; at = at; - note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}, + note = obj_typ + }, {it = I.NewObjE (Type.Object Type.Local @@ at, List.concat (List.map field_to_obj_entry es)); diff --git a/src/interpret.ml b/src/interpret.ml index 10a1a34b7cc..f8e3df70a79 100644 --- a/src/interpret.ml +++ b/src/interpret.ml @@ -547,7 +547,7 @@ and match_pat pat v : val_env option = then Some V.Env.empty else None | SignP (op, lit) -> - let t = T.as_immut pat.note.note_typ in + let t = T.as_immut pat.note in match_pat {pat with it = LitP lit} (Operator.unop t op v) | TupP pats -> match_pats pats (V.as_tup v) V.Env.empty diff --git a/src/ir.ml b/src/ir.ml index 96ad3fcb76d..7effc1fbeae 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -2,7 +2,7 @@ type 'a phrase = ('a,Syntax.typ_note) Source.annotated_phrase -type pat = pat' phrase +type pat = (pat',Type.typ) Source.annotated_phrase and pat' = | WildP (* wildcard *) | VarP of Syntax.id (* variable *) diff --git a/src/parser.mly b/src/parser.mly index b0fe7e73dc9..afe3edf6cfd 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -30,7 +30,7 @@ let name_exp e = | VarE x -> [], e, dup_var x | _ -> let x = ("anon-val-" ^ string_of_pos (e.at.left)) @@ e.at in - [LetD (VarP x @? x.at, e) @? e.at], dup_var x, dup_var x + [LetD (VarP x @! x.at, e) @? e.at], dup_var x, dup_var x let assign_op lhs rhs_f at = let ds, lhs', rhs' = @@ -476,35 +476,35 @@ exp_field : pat_nullary : | UNDERSCORE - { WildP @? at $sloc } + { WildP @! at $sloc } | x=id - { VarP(x) @? at $sloc } + { VarP(x) @! at $sloc } | l=lit - { LitP(ref l) @? at $sloc } + { LitP(ref l) @! at $sloc } | LPAR p=pat RPAR { p } | LPAR ps=seplist1(pat_bin, COMMA) RPAR - { TupP(ps) @? at $sloc } + { TupP(ps) @! at $sloc } pat_post : | p=pat_nullary { p } | p=pat_post QUEST - { OptP(p) @? at $sloc } + { OptP(p) @! at $sloc } pat_un : | p=pat_post { p } | op=unop l=lit - { SignP(op, ref l) @? at $sloc } + { SignP(op, ref l) @! at $sloc } pat_bin : | p=pat_un { p } | p1=pat_bin OR p2=pat_bin - { AltP(p1, p2) @? at $sloc } + { AltP(p1, p2) @! at $sloc } | p=pat_bin COLON t=typ - { AnnotP(p, t) @? at $sloc } + { AnnotP(p, t) @! at $sloc } pat : | p=pat_bin @@ -563,7 +563,7 @@ dec : then efs else List.map share_expfield efs in - let p = VarP(xf anon $sloc) @? at $sloc in + let p = VarP(xf anon $sloc) @! at $sloc in LetD(p, ObjE(s, xf anon $sloc, efs') @? at $sloc) @? at $sloc } func_dec : diff --git a/src/syntax.ml b/src/syntax.ml index 07509551b15..efa635e8e90 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -98,8 +98,7 @@ type relop = (* Patterns *) -(* TODO: replace typ_note by typ (pats don't have effects *) -type pat = (pat', typ_note) Source.annotated_phrase +type pat = (pat', Type.typ) Source.annotated_phrase and pat' = | WildP (* wildcard *) | VarP of id (* variable *) diff --git a/src/syntaxops.ml b/src/syntaxops.ml index 4bdd5feb866..13502441a53 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -51,11 +51,15 @@ let fresh_id typ = (* Patterns *) -let varP x = {x with it=VarP (id_of_exp x)} +let varP x = + { it=VarP (id_of_exp x); + at = x.at; + note = x.note.note_typ + } + let tupP pats = {it = TupP pats; - note = {note_typ = T.Tup (List.map typ pats); - note_eff = T.Triv}; + note = T.Tup (List.map (fun p -> p.note) pats); at = no_region} let seqP ps = @@ -155,15 +159,13 @@ let switch_optE exp1 exp2 pat exp3 typ = { it = SwitchE (exp1, [{it = {pat = {it = LitP (ref NullLit); at = no_region; - note = {note_typ = exp1.note.note_typ; - note_eff = T.Triv}}; + note = exp1.note.note_typ}; exp = exp2}; at = no_region; note = ()}; {it = {pat = {it = OptP pat; at = no_region; - note = {note_typ = exp1.note.note_typ; - note_eff = T.Triv}}; + note = exp1.note.note_typ}; exp = exp3}; at = no_region; note = ()}] @@ -275,7 +277,7 @@ let funcD f x e = | _ -> assert false in {it=FuncD(sharing @@ no_region, (id_of_exp f), [], - {it = VarP (id_of_exp x); at = no_region; note = {note_typ = t1; note_eff = T.Triv}}, + {it = VarP (id_of_exp x); at = no_region; note = t1}, {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) e); at = no_region; diff --git a/src/tailcall.ml b/src/tailcall.ml index 2d544be28da..7d7b91c73a4 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -206,7 +206,7 @@ and dec' env d = | FuncD (({it=Local;_} as s), id, tbs, p, typT, exp0) -> let env = bind env id None in (fun env1 -> - let temp = fresh_id (Mut (typ p)) in + let temp = fresh_id (Mut p.note) in let l = fresh_lab () in let tail_called = ref false in let env2 = {tail_pos = true; diff --git a/src/typing.ml b/src/typing.ml index fa2c4e5f9f0..f207ce4b392 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -746,10 +746,10 @@ and infer_pat_exhaustive env pat : T.typ * val_env = t, ve and infer_pat env pat : T.typ * val_env = - assert (pat.note.note_typ = T.Pre); + assert (pat.note = T.Pre); let t, ve = infer_pat' env pat in if not env.pre then - pat.note <- {note_typ = T.normalize env.cons t; note_eff = T.Triv}; + pat.note <- T.normalize env.cons t; t, ve and infer_pat' env pat : T.typ * val_env = @@ -802,11 +802,11 @@ and check_pat_exhaustive env t pat : val_env = ve and check_pat env t pat : val_env = - assert (pat.note.note_typ = T.Pre); + assert (pat.note = T.Pre); if t = T.Pre then snd (infer_pat env pat) else let t' = T.normalize env.cons t in let ve = check_pat' env t pat in - if not env.pre then pat.note <- {note_typ = t'; note_eff = T.Triv}; + if not env.pre then pat.note <- t'; ve and check_pat' env t pat : val_env = From e96576b1c7bcf95020307cdd983cff8d1059f55c Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 12:50:44 +0000 Subject: [PATCH 08/45] simply annotation on types to typ from typ_note --- src/async.ml | 8 +++----- src/desugar.ml | 8 ++++---- src/parser.mly | 30 +++++++++++++++--------------- src/syntax.ml | 8 +++----- src/syntaxops.ml | 6 +++--- src/tailcall.ml | 2 +- src/typing.ml | 2 +- 7 files changed, 30 insertions(+), 34 deletions(-) diff --git a/src/async.ml b/src/async.ml index adb87e94a2b..13e775e0d33 100644 --- a/src/async.ml +++ b/src/async.ml @@ -33,16 +33,14 @@ let fullfillT as_seq typ = T.Func(T.Call T.Local, T.Returns, [], as_seq typ, []) let tupT ts = {it = TupT ts; at = no_region; - note = - {note_typ = T.Tup (List.map (fun t -> t.note.note_typ) ts); - note_eff = T.Triv}} + note = T.Tup (List.map (fun t -> t.note) ts)} let unitT = tupT [] let funcT(s,bds,t1,t2) = {it = FuncT (s, bds, t1, t2); at = no_region; - note = empty_typ_note} + note = T.Pre} (* TBR: try harder *) let t_async as_seq t = T.Func (T.Call T.Local, T.Returns, [], [T.Func(T.Call T.Local, T.Returns, [],as_seq t,[])], []) @@ -61,7 +59,7 @@ let new_asyncE = let bogusT t= { it = PrimT "BogusT" (* bogus, but we shouln't use it anymore *); at = no_region; - note = { note_typ = t; note_eff = T.Triv}; + note = t; } let new_async t1 = diff --git a/src/desugar.ml b/src/desugar.ml index 3b4c1fb22f3..94e59a0ea07 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -54,7 +54,7 @@ let | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in - let inst = List.map (fun t -> t.Source.note.S.note_typ) inst in + let inst = List.map (fun t -> t.Source.note) inst in I.CallE (cc, exp ce e1, inst, exp ce e2) | S.BlockE ds -> I.BlockE (decs ce ds) | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) @@ -66,7 +66,7 @@ let | S.LoopE (e1, None) -> I.LoopE (exp ce e1, None) | S.LoopE (e1, Some e2) -> I.LoopE (exp ce e1, Some (exp ce e2)) | S.ForE (p, e1, e2) -> I.ForE (pat ce p, exp ce e1, exp ce e2) - | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note.S.note_typ, exp ce e) + | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp ce e) | S.BreakE (l, e) -> I.BreakE (l, exp ce e) | S.RetE e -> I.RetE (exp ce e) | S.AsyncE e -> I.AsyncE (exp ce e) @@ -144,8 +144,8 @@ let | S.VarD (i, e) -> I.VarD (i, exp ce e) | S.FuncD (s, i, tp, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, tp, pat ce p, ty.note.S.note_typ, exp ce e) - | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note.S.note_typ) + I.FuncD (cc, i, tp, pat ce p, ty.note, exp ce e) + | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note) | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map diff --git a/src/parser.mly b/src/parser.mly index afe3edf6cfd..6d22700158f 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -194,43 +194,43 @@ typ_obj : typ_nullary : | LPAR t=typ RPAR - { ParT(t) @? at $loc } + { ParT(t) @! at $loc } | LPAR ts=seplist1(typ_item, COMMA) RPAR - { TupT(ts) @? at $sloc } + { TupT(ts) @! at $sloc } | x=id tso=typ_args? - { VarT(x, Lib.Option.get tso []) @? at $sloc } + { VarT(x, Lib.Option.get tso []) @! at $sloc } | LBRACKET m=var_opt t=typ RBRACKET - { ArrayT(m, t) @? at $sloc } + { ArrayT(m, t) @! at $sloc } | tfs=typ_obj - { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @? at $sloc } + { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @! at $sloc } typ_post : | t=typ_nullary { t } | t=typ_post QUEST - { OptT(t) @? at $sloc } + { OptT(t) @! at $sloc } typ_pre : | t=typ_post { t } | PRIM s=TEXT - { PrimT(s) @? at $sloc } + { PrimT(s) @! at $sloc } | ASYNC t=typ_pre - { AsyncT(t) @? at $sloc } + { AsyncT(t) @! at $sloc } | LIKE t=typ_pre - { LikeT(t) @? at $sloc } + { LikeT(t) @! at $sloc } | s=obj_sort tfs=typ_obj { let tfs' = if s.it = Type.Object Type.Local then tfs else List.map share_typfield tfs - in ObjT(s, tfs') @? at $sloc } + in ObjT(s, tfs') @! at $sloc } typ : | t=typ_pre { t } | s=func_sort_opt tps=typ_params_opt t1=typ_post ARROW t2=typ - { FuncT(s, tps, t1, t2) @? at $sloc } + { FuncT(s, tps, t1, t2) @! at $sloc } typ_item : | id COLON t=typ { t } @@ -248,14 +248,14 @@ typ_field : { {id = x; typ = t; mut} @@ at $sloc } | x=id tps=typ_params_opt t1=typ_nullary t2=return_typ { let t = FuncT(Type.Call Type.Local @@ no_region, tps, t1, t2) - @? span x.at t2.at in + @! span x.at t2.at in {id = x; typ = t; mut = Const @@ no_region} @@ at $sloc } typ_bind : | x=id SUB t=typ { {var = x; bound = t} @! at $sloc } | x=id - { {var = x; bound = PrimT "Any" @? at $sloc} @! at $sloc } + { {var = x; bound = PrimT "Any" @! at $sloc} @! at $sloc } @@ -403,7 +403,7 @@ exp_nondec : { e } | LABEL x=id rt=return_typ_nullary? e=exp { let x' = ("continue " ^ x.it) @@ x.at in - let t = Lib.Option.get rt (TupT [] @? at $sloc) in + let t = Lib.Option.get rt (TupT [] @! at $sloc) in let e' = match e.it with | WhileE (e1, e2) -> WhileE (e1, LabelE (x', t, e2) @? e2.at) @? e.at @@ -568,7 +568,7 @@ dec : func_dec : | tps=typ_params_opt p=pat_nullary rt=return_typ? fb=func_body - { let t = Lib.Option.get rt (TupT([]) @? no_region) in + { let t = Lib.Option.get rt (TupT([]) @! no_region) in (* This is a hack to support local func declarations that return a computed async. These should be defined using RHS syntax EQ e to avoid the implicit AsyncE introduction around bodies declared as blocks *) diff --git a/src/syntax.ml b/src/syntax.ml index efa635e8e90..be07497cffa 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -23,7 +23,7 @@ type func_sort = Type.func_sort Source.phrase type mut = mut' Source.phrase and mut' = Const | Var -type typ = (typ',typ_note) Source.annotated_phrase +type typ = (typ',Type.typ) Source.annotated_phrase and typ' = | PrimT of string (* primitive *) | VarT of id * typ list (* constructor *) @@ -197,17 +197,15 @@ and prog' = dec list (* n-ary arguments/result sequences *) - let seqT ts = match ts with | [t] -> t | ts -> {Source.it = TupT ts; at = Source.no_region; - Source.note = {note_typ = Type.Tup (List.map (fun t -> t.Source.note.note_typ) ts); - note_eff = Type.Triv}} + Source.note = Type.Tup (List.map (fun t -> t.Source.note) ts)} let as_seqT t = match t.Source.it with | TupT ts -> ts | _ -> [t] - + diff --git a/src/syntaxops.ml b/src/syntaxops.ml index 13502441a53..d8b87becbfb 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -278,7 +278,7 @@ let funcD f x e = {it=FuncD(sharing @@ no_region, (id_of_exp f), [], {it = VarP (id_of_exp x); at = no_region; note = t1}, - {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = t2}, (* bogus, but we shouldn't use it anymore *) e); at = no_region; note = f.note} @@ -295,10 +295,10 @@ let nary_funcD f xs e = id_of_exp f, [], seqP (List.map varP xs), - {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = t2}, (* bogus, but we shouldn't use it anymore *) e); at = no_region; - note = f.note;} + note = f.note} | _,_ -> failwith "Impossible: funcD" diff --git a/src/tailcall.ml b/src/tailcall.ml index 7d7b91c73a4..5648541fcc7 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -64,7 +64,7 @@ let bind env i info = let are_generic_insts tbs insts = List.for_all2 (fun tb inst -> - match tb.note,inst.note.note_typ with + match tb.note,inst.note with | Con(c1,[]), Con(c2,[]) -> c1 = c2 (* conservative, but safe *) | Con(c1,[]), _ -> false | _,_ -> assert false) tbs insts diff --git a/src/typing.ml b/src/typing.ml index f207ce4b392..dafe5976e16 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -134,7 +134,7 @@ let infer_mut mut : T.typ -> T.typ = let rec check_typ env typ : T.typ = let t = check_typ' env typ in - typ.note <- {note_typ = t; note_eff = T.Triv}; + typ.note <- t; t and check_typ' env typ : T.typ = From a6292f3166ab2acb3222b7c9de5c9175e28d3610 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 8 Jan 2019 12:50:44 +0000 Subject: [PATCH 09/45] simplify annotation on types to typ from typ_note --- src/async.ml | 8 +++----- src/desugar.ml | 8 ++++---- src/parser.mly | 30 +++++++++++++++--------------- src/syntax.ml | 8 +++----- src/syntaxops.ml | 6 +++--- src/tailcall.ml | 2 +- src/typing.ml | 2 +- 7 files changed, 30 insertions(+), 34 deletions(-) diff --git a/src/async.ml b/src/async.ml index adb87e94a2b..13e775e0d33 100644 --- a/src/async.ml +++ b/src/async.ml @@ -33,16 +33,14 @@ let fullfillT as_seq typ = T.Func(T.Call T.Local, T.Returns, [], as_seq typ, []) let tupT ts = {it = TupT ts; at = no_region; - note = - {note_typ = T.Tup (List.map (fun t -> t.note.note_typ) ts); - note_eff = T.Triv}} + note = T.Tup (List.map (fun t -> t.note) ts)} let unitT = tupT [] let funcT(s,bds,t1,t2) = {it = FuncT (s, bds, t1, t2); at = no_region; - note = empty_typ_note} + note = T.Pre} (* TBR: try harder *) let t_async as_seq t = T.Func (T.Call T.Local, T.Returns, [], [T.Func(T.Call T.Local, T.Returns, [],as_seq t,[])], []) @@ -61,7 +59,7 @@ let new_asyncE = let bogusT t= { it = PrimT "BogusT" (* bogus, but we shouln't use it anymore *); at = no_region; - note = { note_typ = t; note_eff = T.Triv}; + note = t; } let new_async t1 = diff --git a/src/desugar.ml b/src/desugar.ml index 3b4c1fb22f3..94e59a0ea07 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -54,7 +54,7 @@ let | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in - let inst = List.map (fun t -> t.Source.note.S.note_typ) inst in + let inst = List.map (fun t -> t.Source.note) inst in I.CallE (cc, exp ce e1, inst, exp ce e2) | S.BlockE ds -> I.BlockE (decs ce ds) | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) @@ -66,7 +66,7 @@ let | S.LoopE (e1, None) -> I.LoopE (exp ce e1, None) | S.LoopE (e1, Some e2) -> I.LoopE (exp ce e1, Some (exp ce e2)) | S.ForE (p, e1, e2) -> I.ForE (pat ce p, exp ce e1, exp ce e2) - | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note.S.note_typ, exp ce e) + | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp ce e) | S.BreakE (l, e) -> I.BreakE (l, exp ce e) | S.RetE e -> I.RetE (exp ce e) | S.AsyncE e -> I.AsyncE (exp ce e) @@ -144,8 +144,8 @@ let | S.VarD (i, e) -> I.VarD (i, exp ce e) | S.FuncD (s, i, tp, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, tp, pat ce p, ty.note.S.note_typ, exp ce e) - | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note.S.note_typ) + I.FuncD (cc, i, tp, pat ce p, ty.note, exp ce e) + | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note) | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map diff --git a/src/parser.mly b/src/parser.mly index afe3edf6cfd..6d22700158f 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -194,43 +194,43 @@ typ_obj : typ_nullary : | LPAR t=typ RPAR - { ParT(t) @? at $loc } + { ParT(t) @! at $loc } | LPAR ts=seplist1(typ_item, COMMA) RPAR - { TupT(ts) @? at $sloc } + { TupT(ts) @! at $sloc } | x=id tso=typ_args? - { VarT(x, Lib.Option.get tso []) @? at $sloc } + { VarT(x, Lib.Option.get tso []) @! at $sloc } | LBRACKET m=var_opt t=typ RBRACKET - { ArrayT(m, t) @? at $sloc } + { ArrayT(m, t) @! at $sloc } | tfs=typ_obj - { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @? at $sloc } + { ObjT(Type.Object Type.Local @@ at $sloc, tfs) @! at $sloc } typ_post : | t=typ_nullary { t } | t=typ_post QUEST - { OptT(t) @? at $sloc } + { OptT(t) @! at $sloc } typ_pre : | t=typ_post { t } | PRIM s=TEXT - { PrimT(s) @? at $sloc } + { PrimT(s) @! at $sloc } | ASYNC t=typ_pre - { AsyncT(t) @? at $sloc } + { AsyncT(t) @! at $sloc } | LIKE t=typ_pre - { LikeT(t) @? at $sloc } + { LikeT(t) @! at $sloc } | s=obj_sort tfs=typ_obj { let tfs' = if s.it = Type.Object Type.Local then tfs else List.map share_typfield tfs - in ObjT(s, tfs') @? at $sloc } + in ObjT(s, tfs') @! at $sloc } typ : | t=typ_pre { t } | s=func_sort_opt tps=typ_params_opt t1=typ_post ARROW t2=typ - { FuncT(s, tps, t1, t2) @? at $sloc } + { FuncT(s, tps, t1, t2) @! at $sloc } typ_item : | id COLON t=typ { t } @@ -248,14 +248,14 @@ typ_field : { {id = x; typ = t; mut} @@ at $sloc } | x=id tps=typ_params_opt t1=typ_nullary t2=return_typ { let t = FuncT(Type.Call Type.Local @@ no_region, tps, t1, t2) - @? span x.at t2.at in + @! span x.at t2.at in {id = x; typ = t; mut = Const @@ no_region} @@ at $sloc } typ_bind : | x=id SUB t=typ { {var = x; bound = t} @! at $sloc } | x=id - { {var = x; bound = PrimT "Any" @? at $sloc} @! at $sloc } + { {var = x; bound = PrimT "Any" @! at $sloc} @! at $sloc } @@ -403,7 +403,7 @@ exp_nondec : { e } | LABEL x=id rt=return_typ_nullary? e=exp { let x' = ("continue " ^ x.it) @@ x.at in - let t = Lib.Option.get rt (TupT [] @? at $sloc) in + let t = Lib.Option.get rt (TupT [] @! at $sloc) in let e' = match e.it with | WhileE (e1, e2) -> WhileE (e1, LabelE (x', t, e2) @? e2.at) @? e.at @@ -568,7 +568,7 @@ dec : func_dec : | tps=typ_params_opt p=pat_nullary rt=return_typ? fb=func_body - { let t = Lib.Option.get rt (TupT([]) @? no_region) in + { let t = Lib.Option.get rt (TupT([]) @! no_region) in (* This is a hack to support local func declarations that return a computed async. These should be defined using RHS syntax EQ e to avoid the implicit AsyncE introduction around bodies declared as blocks *) diff --git a/src/syntax.ml b/src/syntax.ml index efa635e8e90..be07497cffa 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -23,7 +23,7 @@ type func_sort = Type.func_sort Source.phrase type mut = mut' Source.phrase and mut' = Const | Var -type typ = (typ',typ_note) Source.annotated_phrase +type typ = (typ',Type.typ) Source.annotated_phrase and typ' = | PrimT of string (* primitive *) | VarT of id * typ list (* constructor *) @@ -197,17 +197,15 @@ and prog' = dec list (* n-ary arguments/result sequences *) - let seqT ts = match ts with | [t] -> t | ts -> {Source.it = TupT ts; at = Source.no_region; - Source.note = {note_typ = Type.Tup (List.map (fun t -> t.Source.note.note_typ) ts); - note_eff = Type.Triv}} + Source.note = Type.Tup (List.map (fun t -> t.Source.note) ts)} let as_seqT t = match t.Source.it with | TupT ts -> ts | _ -> [t] - + diff --git a/src/syntaxops.ml b/src/syntaxops.ml index 13502441a53..d8b87becbfb 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -278,7 +278,7 @@ let funcD f x e = {it=FuncD(sharing @@ no_region, (id_of_exp f), [], {it = VarP (id_of_exp x); at = no_region; note = t1}, - {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = t2}, (* bogus, but we shouldn't use it anymore *) e); at = no_region; note = f.note} @@ -295,10 +295,10 @@ let nary_funcD f xs e = id_of_exp f, [], seqP (List.map varP xs), - {it = PrimT "Any"; at = no_region; note = {note_typ = t2; note_eff = T.Triv} }, (* bogus, but we shouldn't use it anymore *) + {it = PrimT "Any"; at = no_region; note = t2}, (* bogus, but we shouldn't use it anymore *) e); at = no_region; - note = f.note;} + note = f.note} | _,_ -> failwith "Impossible: funcD" diff --git a/src/tailcall.ml b/src/tailcall.ml index 7d7b91c73a4..5648541fcc7 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -64,7 +64,7 @@ let bind env i info = let are_generic_insts tbs insts = List.for_all2 (fun tb inst -> - match tb.note,inst.note.note_typ with + match tb.note,inst.note with | Con(c1,[]), Con(c2,[]) -> c1 = c2 (* conservative, but safe *) | Con(c1,[]), _ -> false | _,_ -> assert false) tbs insts diff --git a/src/typing.ml b/src/typing.ml index f207ce4b392..dafe5976e16 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -134,7 +134,7 @@ let infer_mut mut : T.typ -> T.typ = let rec check_typ env typ : T.typ = let t = check_typ' env typ in - typ.note <- {note_typ = t; note_eff = T.Triv}; + typ.note <- t; t and check_typ' env typ : T.typ = From f87144eadb5ad1e0744a9223a12c182fef670a97 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 9 Jan 2019 13:03:33 +0000 Subject: [PATCH 10/45] check_ir.ml: WIP: checking of types (only) --- src/check_ir.ml | 1284 +++++++++++++++++++++++++++++++++++++++++++++++ src/pipeline.ml | 1 + src/typing.ml | 1 - 3 files changed, 1285 insertions(+), 1 deletion(-) create mode 100644 src/check_ir.ml diff --git a/src/check_ir.ml b/src/check_ir.ml new file mode 100644 index 00000000000..7549d5769cb --- /dev/null +++ b/src/check_ir.ml @@ -0,0 +1,1284 @@ +open Source + +module T = Type +module A = Effect + +(* TODO: fix uses of List.sort compare etc on fields rather than field names *) +(* TODO: annote DotE in checker for desugaring sans environments *) + + +(* Error bookkeeping *) + +(* Recovering from errors *) + +exception Recover + +let recover_with (x : 'a) (f : 'b -> 'a) (y : 'b) = try f y with Recover -> x +let recover_opt f y = recover_with None (fun y -> Some (f y)) y +let recover f y = recover_with () f y + +(* Scope (the external interface) *) + +type val_env = T.typ T.Env.t +type typ_env = T.con T.Env.t +type con_env = T.con_env + +type scope = Typing.scope = + { val_env : val_env; + typ_env : typ_env; (* TODO: delete me *) + con_env : con_env; + } + +let empty_scope : scope = + { val_env = T.Env.empty; + typ_env = T.Env.empty; + con_env = Con.Env.empty + } + +let adjoin_scope scope1 scope2 = + { val_env = T.Env.adjoin scope1.val_env scope2.val_env; + typ_env = T.Env.adjoin scope1.typ_env scope2.typ_env; (* TODO: delete me *) + con_env = Con.Env.adjoin scope1.con_env scope2.con_env; + } + +(* Contexts (internal) *) + +type lab_env = T.typ T.Env.t +type ret_env = T.typ option + +type env = + { vals : val_env; + typs : typ_env; (* TODO: remove me *) + cons : con_env; + labs : lab_env; + rets : ret_env; + async : bool; + pre : bool; + msgs : Diag.msg_store; + } + +let env_of_scope msgs scope = + { vals = scope.val_env; + typs = scope.typ_env; + cons = scope.con_env; + labs = T.Env.empty; + rets = None; + async = false; + pre = false; + msgs; + } + +(* More error bookkeeping *) + +let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "type"; text } +let type_warning at text : Diag.message = Diag.{ sev = Diag.Warning; at; cat = "type"; text } + +let local_error env at fmt = + Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_error at s)) fmt +let error env at fmt = + Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_error at s); raise Recover) fmt +let warn env at fmt = + Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_warning at s)) fmt + + +let add_lab c x t = {c with labs = T.Env.add x t c.labs} +let add_val c x t = {c with vals = T.Env.add x t c.vals} +(* +let add_con c con k = {c with cons = Con.Env.add con k c.cons} +let add_typ c x con k = + { c with + typs = T.Env.add x con c.typs; + cons = Con.Env.add con k c.cons; + } +*) + +let add_typs c xs cs ks = + { c with + (* typs = List.fold_right2 T.Env.add xs cs c.typs; *) + cons = List.fold_right2 Con.Env.add cs ks c.cons; + } + +let adjoin c scope = + { c with + vals = T.Env.adjoin c.vals scope.val_env; + (* typs = T.Env.adjoin c.typs scope.typ_env; *) + cons = Con.Env.adjoin c.cons scope.con_env; + } + +let adjoin_vals c ve = {c with vals = T.Env.adjoin c.vals ve} +let adjoin_cons c ce = {c with cons = Con.Env.adjoin c.cons ce} +let adjoin_typs c ce = + { c with + (* typs = T.Env.adjoin c.typs te; *) + cons = Con.Env.adjoin c.cons ce; + } + +let disjoint_union env at fmt env1 env2 = + try T.Env.disjoint_union env1 env2 + with T.Env.Clash k -> error env at fmt k + + +(* Types *) + +let check_ids env ids = ignore + (List.fold_left + (fun dom id -> + if List.mem id dom + then error env no_region "duplicate field name %s in object type" id + else id::dom + ) [] ids + ) + +let infer_mut mut : T.typ -> T.typ = + match mut.it with + | Syntax.Const -> fun t -> t + | Syntax.Var -> fun t -> T.Mut t + +let rec check_typ env typ : unit = + match typ with + | T.Pre -> + error env no_region "illegal T.Pre type" + | T.Var (s,i) -> + error env no_region "free type variable %s, index %i" s i + | T.Con(c,typs) -> + (match Con.Env.find_opt c env.cons with + | Some (T.Def (tbs, t) | T.Abs (tbs, t)) -> + check_typ_bounds env tbs typs no_region + | None -> error env no_region "unbound type constructor %s" (Con.to_string c) + ) + | T.Any -> () + | T.Non -> () + | T.Shared -> () + | T.Class -> () + | T.Prim _ -> () + | T.Array typ -> + check_typ env typ + | T.Tup typs -> + List.iter (check_typ env) typs + | T.Func (sort, control, binds, ts1, ts2) -> + let cs, ce = check_typ_binds env binds in + let env' = adjoin_typs env ce in + let ts = List.map (fun c -> T.Con(c,[])) cs in + let ts1 = List.map (T.open_ ts) ts1 in + let ts2 = List.map (T.open_ ts) ts2 in + List.iter (check_typ env') ts1; + List.iter (check_typ env') ts2; + if (control = T.Promises) then begin + match ts2 with + | [T.Async _ ] -> () + | _ -> + let t2 = T.seq ts2 in + error env no_region "promising function with non-async result type \n %s" + (T.string_of_typ_expand env'.cons t2) + end; + if sort = T.Call T.Sharable then begin + let t1 = T.seq ts1 in + if not (T.sub env'.cons t1 T.Shared) then + error env no_region "shared function has non-shared parameter type\n %s" + (T.string_of_typ_expand env'.cons t1); + begin match ts2 with + | [] -> () + | [T.Async t2] -> + if not (T.sub env'.cons t2 T.Shared) then + error env no_region "shared function has non-shared result type\n %s" + (T.string_of_typ_expand env'.cons t2); + | _ -> error env no_region "shared function has non-async result type\n %s" + (T.string_of_typ_expand env'.cons (T.seq ts2)) + end + end + | T.Opt typ -> + check_typ env typ + | T.Async typ -> + let t' = T.promote env.cons typ in + if not (T.sub env.cons t' T.Shared) then + error env no_region "async type has non-shared parameter type\n %s" + (T.string_of_typ_expand env.cons t') + | T.Like typ -> + check_typ env typ + | T.Obj (sort, fields) -> + check_ids env (List.map (fun (field : T.field) -> field.T.name) fields); + List.iter (check_typ_field env sort) fields + (* TODO: check fields are sorted, c.f. typecheck:ml: *) + (* T.Obj (sort.it, List.sort compare fs) *) (* IS THAT EVEN CORRECT? *) + | T.Mut typ -> + check_typ env typ + +and check_typ_field env s typ_field : unit = + let {T.name; T.typ} = typ_field in + check_typ env typ; + if s = T.Actor && not (T.is_func (T.promote env.cons typ)) then + error env no_region "actor field %s has non-function type\n %s" + name (T.string_of_typ_expand env.cons typ); + if s <> T.Object T.Local && not (T.sub env.cons typ T.Shared) then + error env no_region "shared object or actor field %s has non-shared type\n %s" + name (T.string_of_typ_expand env.cons typ) + +(* +and check_typ_binds env typ_binds : T.con list * T.typ list * typ_env * con_env = + let xs = List.map (fun typ_bind -> typ_bind.it.var.it) typ_binds in + let cs = List.map (fun x -> Con.fresh x) xs in + List.iter2 (fun typ_bind c -> typ_bind.note <- T.Con(c,[])) typ_binds cs; + let te = List.fold_left2 (fun te typ_bind c -> + let id = typ_bind.it.var in + if T.Env.mem id.it te then + error env id.at "duplicate type name %s in type parameter list" id.it; + T.Env.add id.it c te + ) T.Env.empty typ_binds cs in + let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in + let pre_env' = add_typs {env with pre = true} xs cs pre_ks in + let ts = List.map (fun typ_bind -> check_typ pre_env' typ_bind.it.bound) typ_binds in + let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in + let env' = add_typs env xs cs ks in + let _ = List.map (fun typ_bind -> check_typ env' typ_bind.it.bound) typ_binds in + cs, ts, te, Con.Env.from_list2 cs ks + *) +and check_typ_binds env typ_binds : T.con list * con_env = + let xs = List.map (fun typ_bind -> typ_bind.T.var) typ_binds in + let cs = List.map (fun x -> Con.fresh x) xs in + let _ (* te *) = List.fold_left2 (fun te typ_bind c -> + let id = typ_bind.T.var in + if T.Env.mem id te then + error env no_region "duplicate type name %s in type parameter list" id; + T.Env.add id c te + ) T.Env.empty typ_binds cs in + let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in + let pre_env' = add_typs {env with pre = true} xs cs pre_ks in + let ts = List.map (fun typ_bind -> let t = typ_bind.T.bound in + check_typ pre_env' t; + t) typ_binds in + let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in + let env' = add_typs env xs cs ks in + let _ = List.map (fun typ_bind -> check_typ env' typ_bind.T.bound) typ_binds in + cs, Con.Env.from_list2 cs ks + +and check_typ_bounds env (tbs : T.bind list) typs at : unit = + match tbs, typs with + | tb::tbs', typ::typs' -> + check_typ env typ; + if not env.pre then begin + if not (T.sub env.cons typ tb.T.bound) then + local_error env no_region "type argument\n %s\ndoes not match parameter bound\n %s" + (T.string_of_typ_expand env.cons typ) + (T.string_of_typ_expand env.cons tb.T.bound) + end; + check_typ_bounds env tbs' typs' at + | [], [] -> () + | [], _ -> local_error env at "too many type arguments" + | _, [] -> error env at "too few type arguments" + +and check_inst_bounds env tbs typs at = + let tys = check_typ_bounds env tbs typs at in + tys + +(* Literals *) + +let check_lit_val env t of_string at s = + try of_string s with _ -> + error env at "literal out of range for type %s" + (T.string_of_typ (T.Prim t)) + +let check_nat env = check_lit_val env T.Nat Value.Nat.of_string +let check_int env = check_lit_val env T.Int Value.Int.of_string +let check_word8 env = check_lit_val env T.Word8 Value.Word8.of_string_u +let check_word16 env = check_lit_val env T.Word16 Value.Word16.of_string_u +let check_word32 env = check_lit_val env T.Word32 Value.Word32.of_string_u +let check_word64 env = check_lit_val env T.Word64 Value.Word64.of_string_u +let check_float env = check_lit_val env T.Float Value.Float.of_string + + +let infer_lit env lit at : T.prim = + Syntax.( (* yuck *) + match !lit with + | NullLit -> T.Null + | BoolLit _ -> T.Bool + | NatLit _ -> T.Nat + | IntLit _ -> T.Int + | Word8Lit _ -> T.Word8 + | Word16Lit _ -> T.Word16 + | Word32Lit _ -> T.Word32 + | Word64Lit _ -> T.Word64 + | FloatLit _ -> T.Float + | CharLit _ -> T.Char + | TextLit _ -> T.Text + | PreLit (s, T.Nat) -> + lit := NatLit (check_nat env at s); (* default *) + T.Nat + | PreLit (s, T.Int) -> + lit := IntLit (check_int env at s); (* default *) + T.Int + | PreLit (s, T.Float) -> + lit := FloatLit (check_float env at s); (* default *) + T.Float + | PreLit _ -> + assert false + ) + +let check_lit env t lit at = + Syntax.( + match T.normalize env.cons t, !lit with + | T.Opt _, NullLit -> () + | T.Prim T.Nat, PreLit (s, T.Nat) -> + lit := NatLit (check_nat env at s) + | T.Prim T.Int, PreLit (s, (T.Nat | T.Int)) -> + lit := IntLit (check_int env at s) + | T.Prim T.Word8, PreLit (s, (T.Nat | T.Int)) -> + lit := Word8Lit (check_word8 env at s) + | T.Prim T.Word16, PreLit (s, (T.Nat | T.Int)) -> + lit := Word16Lit (check_word16 env at s) + | T.Prim T.Word32, PreLit (s, (T.Nat | T.Int)) -> + lit := Word32Lit (check_word32 env at s) + | T.Prim T.Word64, PreLit (s, (T.Nat | T.Int)) -> + lit := Word64Lit (check_word64 env at s) + | T.Prim T.Float, PreLit (s, (T.Nat | T.Int | T.Float)) -> + lit := FloatLit (check_float env at s) + | t, _ -> + let t' = T.Prim (infer_lit env lit at) in + if not (T.sub env.cons t' t) then + local_error env at "literal of type\n %s\ndoes not have expected type\n %s" + (T.string_of_typ t') (T.string_of_typ_expand env.cons t) + ) + +(**** +open Ir +(* Expressions *) + +let isAsyncE exp = + match exp.it with + | AsyncE _ -> true + | _ -> false + +let rec infer_exp env exp : T.typ = + T.as_immut (infer_exp_mut env exp) + +and infer_exp_promote env exp : T.typ = + let t = infer_exp env exp in + let t' = T.promote env.cons t in + if t' = T.Pre then + error env exp.at "cannot infer type of expression while trying to infer surrounding class type,\nbecause its type is a forward reference to type\n %s" + (T.string_of_typ_expand env.cons t); + t' + +and infer_exp_mut env exp : T.typ = + assert (exp.note.note_typ = T.Pre); + let t = infer_exp' env exp in + assert (t <> T.Pre); + if not env.pre then begin + let e = A.infer_effect_exp exp in + exp.note <- {note_typ = T.normalize env.cons t; note_eff = e} + end; + t + +and infer_exp' env exp : T.typ = + match exp.it with + | PrimE _ -> + error env exp.at "cannot infer type of primitive" + | VarE id -> + (match T.Env.find_opt id.it env.vals with + | Some T.Pre -> + error env id.at "cannot infer type of forward variable %s" id.it; + | Some t -> t + | None -> error env id.at "unbound variable %s" id.it + ) + | LitE lit -> + T.Prim (infer_lit env lit exp.at) + | UnE (ot, op, exp1) -> + let t1 = infer_exp_promote env exp1 in + (* Special case for subtyping *) + let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in + if not env.pre then begin + assert (!ot = Type.Pre); + if not (Operator.has_unop t op) then + error env exp.at "operator is not defined for operand type\n %s" + (T.string_of_typ_expand env.cons t); + ot := t; + end; + t + | BinE (ot, exp1, op, exp2) -> + let t1 = infer_exp_promote env exp1 in + let t2 = infer_exp_promote env exp2 in + let t = T.lub env.cons t1 t2 in + if not env.pre then begin + assert (!ot = Type.Pre); + if not (Operator.has_binop t op) then + error env exp.at "operator not defined for operand types\n %s and\n %s" + (T.string_of_typ_expand env.cons t1) + (T.string_of_typ_expand env.cons t2); + ot := t + end; + t + | RelE (ot,exp1, op, exp2) -> + let t1 = infer_exp_promote env exp1 in + let t2 = infer_exp_promote env exp2 in + let t = T.lub env.cons t1 t2 in + if not env.pre then begin + assert (!ot = Type.Pre); + if not (Operator.has_relop t op) then + error env exp.at "operator not defined for operand types\n %s and\n %s" + (T.string_of_typ_expand env.cons t1) + (T.string_of_typ_expand env.cons t2); + ot := t; + end; + T.bool + | TupE exps -> + let ts = List.map (infer_exp env) exps in + T.Tup ts + | OptE exp1 -> + let t1 = infer_exp env exp1 in + T.Opt t1 + | ProjE (exp1, n) -> + let t1 = infer_exp_promote env exp1 in + (try + let ts = T.as_tup_sub n env.cons t1 in + match List.nth_opt ts n with + | Some t -> t + | None -> + error env exp.at "tuple projection %n is out of bounds for type\n %s" + n (T.string_of_typ_expand env.cons t1) + with Invalid_argument _ -> + error env exp1.at "expected tuple type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + ) + | ObjE (sort, id, fields) -> + let env' = if sort.it = T.Actor then { env with async = false } else env in + infer_obj env' sort.it id fields + | DotE (exp1, {it = Name n;_}) -> + let t1 = infer_exp_promote env exp1 in + (try + let _, tfs = T.as_obj_sub n env.cons t1 in + match List.find_opt (fun {T.name; _} -> name = n) tfs with + | Some {T.typ = t; _} -> t + | None -> + error env exp1.at "field name %s does not exist in type\n %s" + n (T.string_of_typ_expand env.cons t1) + with Invalid_argument _ -> + error env exp1.at "expected object type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + ) + | AssignE (exp1, exp2) -> + if not env.pre then begin + let t1 = infer_exp_mut env exp1 in + try + let t2 = T.as_mut t1 in + check_exp env t2 exp2 + with Invalid_argument _ -> + error env exp.at "expected mutable assignment target"; + end; + T.unit + | ArrayE (mut, exps) -> + let ts = List.map (infer_exp env) exps in + let t1 = List.fold_left (T.lub env.cons) T.Non ts in + if + t1 = T.Any && List.for_all (fun t -> T.promote env.cons t <> T.Any) ts + then + warn env exp.at "this array has type %s because elements have inconsistent types" + (T.string_of_typ (T.Array t1)); + T.Array (match mut.it with Const -> t1 | Var -> T.Mut t1) + | IdxE (exp1, exp2) -> + let t1 = infer_exp_promote env exp1 in + (try + let t = T.as_array_sub env.cons t1 in + if not env.pre then check_exp env T.nat exp2; + t + with Invalid_argument _ -> + error env exp1.at "expected array type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + ) + | CallE (exp1, insts, exp2) -> + let t1 = infer_exp_promote env exp1 in + (try + let tbs, t2, t = T.as_func_sub (List.length insts) env.cons t1 in + let ts = check_inst_bounds env tbs insts exp.at in + if not env.pre then check_exp env (T.open_ ts t2) exp2; + T.open_ ts t + with Invalid_argument _ -> + error env exp1.at "expected function type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + ) + | BlockE decs -> + let t, scope = infer_block env decs exp.at in + (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> + error env exp.at "local class type %s is contained in inferred block type\n %s" + (Con.to_string c) + (T.string_of_typ_expand (Con.Env.adjoin env.cons scope.con_env) t) + ) + | NotE exp1 -> + if not env.pre then check_exp env T.bool exp1; + T.bool + | AndE (exp1, exp2) -> + if not env.pre then begin + check_exp env T.bool exp1; + check_exp env T.bool exp2 + end; + T.bool + | OrE (exp1, exp2) -> + if not env.pre then begin + check_exp env T.bool exp1; + check_exp env T.bool exp2 + end; + T.bool + | IfE (exp1, exp2, exp3) -> + if not env.pre then check_exp env T.bool exp1; + let t2 = infer_exp env exp2 in + let t3 = infer_exp env exp3 in + let t = T.lub env.cons t2 t3 in + if + t = T.Any && + T.promote env.cons t2 <> T.Any && T.promote env.cons t3 <> T.Any + then + warn env exp.at "this if has type %s because branches have inconsistent types,\ntrue produces\n %s\nfalse produces\n %s" + (T.string_of_typ t) + (T.string_of_typ_expand env.cons t2) + (T.string_of_typ_expand env.cons t3); + t + | SwitchE (exp1, cases) -> + let t1 = infer_exp_promote env exp1 in + let t = infer_cases env t1 T.Non cases in + if not env.pre then + if not (Coverage.check_cases env.cons cases t1) then + warn env exp.at "the cases in this switch do not cover all possible values"; + t + | WhileE (exp1, exp2) -> + if not env.pre then begin + check_exp env T.bool exp1; + check_exp env T.unit exp2 + end; + T.unit + | LoopE (exp1, expo) -> + if not env.pre then begin + check_exp env T.unit exp1; + Lib.Option.app (check_exp env T.bool) expo + end; + T.Non + | ForE (pat, exp1, exp2) -> + if not env.pre then begin + let t1 = infer_exp_promote env exp1 in + (try + let _, tfs = T.as_obj_sub "next" env.cons t1 in + let t = T.lookup_field "next" tfs in + let t1, t2 = T.as_mono_func_sub env.cons t in + if not (T.sub env.cons T.unit t1) then raise (Invalid_argument ""); + let t2' = T.as_opt_sub env.cons t2 in + let ve = check_pat_exhaustive env t2' pat in + check_exp (adjoin_vals env ve) T.unit exp2 + with Invalid_argument _ -> + local_error env exp1.at "expected iterable type, but expression has type\n %s" + (T.string_of_typ_expand env.cons t1) + ); + end; + T.unit + | LabelE (id, typ, exp1) -> + let t = check_typ env typ in + if not env.pre then check_exp (add_lab env id.it t) t exp1; + t + | BreakE (id, exp1) -> + (match T.Env.find_opt id.it env.labs with + | Some t -> + if not env.pre then check_exp env t exp1 + | None -> + let name = + match String.split_on_char ' ' id.it with + | ["continue"; name] -> name + | _ -> id.it + in local_error env id.at "unbound label %s" name + ); + T.Non + | RetE exp1 -> + if not env.pre then begin + match env.rets with + | Some T.Pre -> + local_error env exp.at "cannot infer return type" + | Some t -> + check_exp env t exp1 + | None -> + local_error env exp.at "misplaced return" + end; + T.Non + | AsyncE exp1 -> + let env' = + {env with labs = T.Env.empty; rets = Some T.Pre; async = true} in + let t = infer_exp env' exp1 in + if not (T.sub env.cons t T.Shared) then + error env exp1.at "async type has non-shared parameter type\n %s" + (T.string_of_typ_expand env.cons t); + T.Async t + | AwaitE exp1 -> + if not env.async then + error env exp.at "misplaced await"; + let t1 = infer_exp_promote env exp1 in + (try + T.as_async_sub env.cons t1 + with Invalid_argument _ -> + error env exp1.at "expected async type, but expression has type\n %s" + (T.string_of_typ_expand env.cons t1) + ) + | AssertE exp1 -> + if not env.pre then check_exp env T.bool exp1; + T.unit + | IsE (exp1, exp2) -> + (* TBR: restrict t1 to objects? *) + if not env.pre then begin + let _t1 = infer_exp env exp1 in + check_exp env T.Class exp2 + end; + T.bool + | AnnotE (exp1, typ) -> + let t = check_typ env typ in + if not env.pre then check_exp env t exp1; + t + | DecE dec -> + let t, scope = infer_block env [dec] exp.at in + (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> + error env exp.at "local class name %s is contained in inferred declaration type\n %s" + (Con.to_string c) (T.string_of_typ_expand env.cons t) + ) + (* DeclareE and DefineE should not occur in source code *) + | DeclareE (id, typ, exp1) -> + let env' = adjoin_vals env (T.Env.singleton id.it typ) in + infer_exp env' exp1 + | DefineE (id, mut, exp1) -> + begin + match T.Env.find_opt id.it env.vals with + | Some T.Pre -> + error env id.at "cannot infer type of forward variable %s" id.it + | Some t1 -> + if not env.pre then begin + try + let t2 = match mut.it with | Var -> T.as_mut t1 | Const -> t1 in + check_exp env t2 exp1 + with Invalid_argument _ -> + error env exp.at "expected mutable assignment target"; + end; + | None -> error env id.at "unbound variable %s" id.it + end; + T.unit + | NewObjE (sort, labids) -> + T.Obj(sort.it, List.map (fun (name,id) -> + {T.name = string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids) + +and check_exp env t exp = + assert (not env.pre); + assert (exp.note.note_typ = T.Pre); + assert (t <> T.Pre); + let t' = T.normalize env.cons t in + check_exp' env t' exp; + let e = A.infer_effect_exp exp in + exp.note <- {note_typ = t'; note_eff = e} + +and check_exp' env t exp = + match exp.it, t with + | PrimE s, T.Func _ -> + () + | LitE lit, _ -> + check_lit env t lit exp.at + | UnE (ot, op, exp1), t' when Operator.has_unop t' op -> + ot := t'; + check_exp env t' exp1 + | BinE (ot, exp1, op, exp2), t' when Operator.has_binop t' op -> + ot := t'; + check_exp env t' exp1; + check_exp env t' exp2 + | TupE exps, T.Tup ts when List.length exps = List.length ts -> + List.iter2 (check_exp env) ts exps + | OptE exp1, _ when T.is_opt t -> + check_exp env (T.as_opt t) exp1 + | ObjE (sort, id, fields), T.Obj (s, tfs) when s = sort.it -> + let env' = if sort.it = T.Actor then { env with async = false } else env in + ignore (check_obj env' s tfs id fields exp.at) + | ArrayE (mut, exps), T.Array t' -> + if (mut.it = Var) <> T.is_mut t' then + local_error env exp.at "%smutable array expression cannot produce expected type\n %s" + (if mut.it = Const then "im" else "") + (T.string_of_typ_expand env.cons (T.Array t')); + List.iter (check_exp env (T.as_immut t')) exps + | AsyncE exp1, T.Async t' -> + let env' = {env with labs = T.Env.empty; rets = Some t'; async = true} in + check_exp env' t' exp1 + | BlockE decs, _ -> + ignore (check_block env t decs exp.at) + | IfE (exp1, exp2, exp3), _ -> + check_exp env T.bool exp1; + check_exp env t exp2; + check_exp env t exp3 + | SwitchE (exp1, cases), _ -> + let t1 = infer_exp_promote env exp1 in + check_cases env t1 t cases; + if not (Coverage.check_cases env.cons cases t1) then + warn env exp.at "the cases in this switch do not cover all possible values"; + | _ -> + let t' = infer_exp env exp in + if not (T.sub env.cons t' t) then + local_error env exp.at "expression of type\n %s\ncannot produce expected type\n %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons t) + + +(* Cases *) + +and infer_cases env t_pat t cases : T.typ = + List.fold_left (infer_case env t_pat) t cases + +and infer_case env t_pat t {it = {pat; exp}; at; _} = + let ve = check_pat env t_pat pat in + let t' = recover_with T.Non (infer_exp (adjoin_vals env ve)) exp in + let t'' = T.lub env.cons t t' in + if + t'' = T.Any && + T.promote env.cons t <> T.Any && T.promote env.cons t' <> T.Any + then + warn env at "the switch has type %s because branches have inconsistent types,\nthis case produces type\n %s\nthe previous produce type\n %s" + (T.string_of_typ t'') + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons t'); + t'' + +and check_cases env t_pat t cases = + List.iter (check_case env t_pat t) cases + +and check_case env t_pat t {it = {pat; exp}; _} = + let ve = check_pat env t_pat pat in + recover (check_exp (adjoin_vals env ve) t) exp + + +(* Patterns *) + +and gather_pat env ve0 pat : val_env = + let rec go ve pat = + match pat.it with + | WildP | LitP _ | SignP _ -> + ve + | VarP id -> + if T.Env.mem id.it ve0 then + error env pat.at "duplicate binding for %s in block" id.it; + T.Env.add id.it T.Pre ve + | TupP pats -> + List.fold_left go ve pats + | AltP (pat1, pat2) -> + go ve pat1 + | OptP pat1 + | AnnotP (pat1, _) -> + go ve pat1 + in T.Env.adjoin ve0 (go T.Env.empty pat) + + + +and infer_pat_exhaustive env pat : T.typ * val_env = + let t, ve = infer_pat env pat in + if not env.pre then + if not (Coverage.check_pat env.cons pat t) then + warn env pat.at "this pattern does not cover all possible values"; + t, ve + +and infer_pat env pat : T.typ * val_env = + assert (pat.note = T.Pre); + let t, ve = infer_pat' env pat in + if not env.pre then + pat.note <- T.normalize env.cons t; + t, ve + +and infer_pat' env pat : T.typ * val_env = + match pat.it with + | WildP -> + error env pat.at "cannot infer type of wildcard" + | VarP _ -> + error env pat.at "cannot infer type of variable" + | LitP lit -> + T.Prim (infer_lit env lit pat.at), T.Env.empty + | SignP (op, lit) -> + let t1 = T.Prim (infer_lit env lit pat.at) in + (* Special case for subtyping *) + let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in + if not (Operator.has_unop t op) then + local_error env pat.at "operator is not defined for operand type\n %s" + (T.string_of_typ_expand env.cons t); + t, T.Env.empty + | TupP pats -> + let ts, ve = infer_pats pat.at env pats [] T.Env.empty in + T.Tup ts, ve + | OptP pat1 -> + let t1, ve = infer_pat env pat1 in + T.Opt t1, ve + | AltP (pat1, pat2) -> + let t1, ve1 = infer_pat env pat1 in + let t2, ve2 = infer_pat env pat2 in + let t = T.lub env.cons t1 t2 in + if ve1 <> T.Env.empty || ve2 <> T.Env.empty then + error env pat.at "variables are not allowed in pattern alternatives"; + t, T.Env.empty + | AnnotP (pat1, typ) -> + let t = check_typ env typ in + t, check_pat env t pat1 + +and infer_pats at env pats ts ve : T.typ list * val_env = + match pats with + | [] -> List.rev ts, ve + | pat::pats' -> + let t, ve1 = infer_pat env pat in + let ve' = disjoint_union env at "duplicate binding for %s in pattern" ve ve1 in + infer_pats at env pats' (t::ts) ve' + + +and check_pat_exhaustive env t pat : val_env = + let ve = check_pat env t pat in + if not env.pre then + if not (Coverage.check_pat env.cons pat t) then + warn env pat.at "this pattern does not cover all possible values"; + ve + +and check_pat env t pat : val_env = + assert (pat.note = T.Pre); + if t = T.Pre then snd (infer_pat env pat) else + let t' = T.normalize env.cons t in + let ve = check_pat' env t pat in + if not env.pre then pat.note <- t'; + ve + +and check_pat' env t pat : val_env = + assert (t <> T.Pre); + match pat.it with + | WildP -> + T.Env.empty + | VarP id -> + T.Env.singleton id.it t + | LitP lit -> + if not env.pre then check_lit env t lit pat.at; + T.Env.empty + | SignP (op, lit) -> + if not env.pre then begin + let t' = T.normalize env.cons t in + if not (Operator.has_unop t op) then + local_error env pat.at "operator cannot consume expected type\n %s" + (T.string_of_typ_expand env.cons t'); + check_lit env t' lit pat.at + end; + T.Env.empty + | TupP pats -> + (try + let ts = T.as_tup_sub (List.length pats) env.cons t in + check_pats env ts pats T.Env.empty pat.at + with Invalid_argument _ -> + error env pat.at "tuple pattern cannot consume expected type\n %s" + (T.string_of_typ_expand env.cons t) + ) + | OptP pat1 -> + (try + let t1 = T.as_opt t in + check_pat env t1 pat1 + with Invalid_argument _ -> + error env pat.at "option pattern cannot consume expected type\n %s" + (T.string_of_typ_expand env.cons t) + ) + | AltP (pat1, pat2) -> + let ve1 = check_pat env t pat1 in + let ve2 = check_pat env t pat2 in + if ve1 <> T.Env.empty || ve2 <> T.Env.empty then + error env pat.at "variables are not allowed in pattern alternatives"; + T.Env.empty + | _ -> + let t', ve = infer_pat env pat in + if not (T.sub env.cons t t') then + error env pat.at "pattern of type\n %s\ncannot consume expected type\n %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons t); + ve + +and check_pats env ts pats ve at : val_env = + match pats, ts with + | [], [] -> ve + | pat::pats', t::ts -> + let ve1 = check_pat env t pat in + let ve' = disjoint_union env at "duplicate binding for %s in pattern" ve ve1 in + check_pats env ts pats' ve' at + | [], ts -> + local_error env at "tuple pattern has %i fewer components than expected type" + (List.length ts); ve + | ts, [] -> + error env at "tuple pattern has %i more components than expected type" + (List.length ts) + + +(* Objects *) + +and infer_obj env s id fields : T.typ = + let pre_ve = gather_exp_fields env id.it fields in + let pre_env = adjoin_vals {env with pre = true} pre_ve in + let tfs, ve = infer_exp_fields pre_env s id.it T.Pre fields in + let t = T.Obj (s, tfs) in + if not env.pre then begin + let env' = adjoin_vals (add_val env id.it t) ve in + ignore (infer_exp_fields env' s id.it t fields) + end; + t + + +and check_obj env s tfs id fields at : T.typ = + let pre_ve = gather_exp_fields env id.it fields in + let pre_ve' = List.fold_left + (fun ve {T.name; typ = t} -> + if not (T.Env.mem name ve) then + error env at "%s expression without field %s cannot produce expected type\n %s" + (if s = T.Actor then "actor" else "object") name + (T.string_of_typ_expand env.cons t); + T.Env.add name t ve + ) pre_ve tfs + in + let pre_env = adjoin_vals {env with pre = true} pre_ve' in + let tfs', ve = infer_exp_fields pre_env s id.it T.Pre fields in + let t = T.Obj (s, tfs') in + let env' = adjoin_vals (add_val env id.it t) ve in + ignore (infer_exp_fields env' s id.it t fields); + t + + +and gather_exp_fields env id fields : val_env = + let ve0 = T.Env.singleton id T.Pre in + List.fold_left (gather_exp_field env) ve0 fields + +and gather_exp_field env ve field : val_env = + let {id; _} : exp_field' = field.it in + if T.Env.mem id.it ve then + error env id.at "duplicate field name %s in object" id.it; + T.Env.add id.it T.Pre ve + + +and infer_exp_fields env s id t fields : T.field list * val_env = + let env' = add_val env id t in + let tfs, ve = + List.fold_left (infer_exp_field env' s) ([], T.Env.empty) fields in + List.sort compare tfs, ve + +and is_func_exp exp = + match exp.it with + | DecE dec -> is_func_dec dec + | AnnotE (exp, _) -> is_func_exp exp + | _ -> Printf.printf "[1]%!"; false + +and is_func_dec dec = + match dec.it with + | FuncD _ -> true + | _ -> Printf.printf "[2]%!"; false + +and infer_exp_field env s (tfs, ve) field : T.field list * val_env = + let {id; name; exp; mut; priv} = field.it in + let t = + match T.Env.find id.it env.vals with + | T.Pre -> + infer_mut mut (infer_exp (adjoin_vals env ve) exp) + | t -> + (* When checking object in analysis mode *) + if not env.pre then begin + check_exp (adjoin_vals env ve) (T.as_immut t) exp; + if (mut.it = Var) <> T.is_mut t then + local_error env field.at + "%smutable field %s cannot produce expected %smutable field of type\n %s" + (if mut.it = Var then "" else "im") id.it + (if T.is_mut t then "" else "im") + (T.string_of_typ_expand env.cons (T.as_immut t)) + end; + t + in + if not env.pre then begin + if s = T.Actor && priv.it = Public && not (is_func_exp exp) then + error env field.at "public actor field is not a function"; + if s <> T.Object T.Local && priv.it = Public && not (T.sub env.cons t T.Shared) then + error env field.at "public shared object or actor field %s has non-shared type\n %s" + (string_of_name name.it) (T.string_of_typ_expand env.cons t) + end; + let ve' = T.Env.add id.it t ve in + let tfs' = + if priv.it = Private + then tfs + else {T.name = string_of_name name.it; typ = t} :: tfs + in tfs', ve' + + +(* Blocks and Declarations *) + +and infer_block env decs at : T.typ * scope = + let scope = infer_block_decs env decs in + let t = infer_block_exps (adjoin env scope) decs in + t, scope + +and infer_block_exps env decs : T.typ = + match decs with + | [] -> T.unit + | [dec] -> infer_dec env dec + | dec::decs' -> + if not env.pre then recover (check_dec env T.unit) dec; + recover_with T.Non (infer_block_exps env) decs' + +and infer_dec env dec : T.typ = + let t = + match dec.it with + | ExpD exp -> + infer_exp env exp + | LetD (_, exp) | VarD (_, exp) -> + if not env.pre then ignore (infer_exp env exp); + T.unit + | FuncD (sort, id, typbinds, pat, typ, exp) -> + let t = T.Env.find id.it env.vals in + if not env.pre then begin + let _cs, _ts, te, ce = check_typ_binds env typbinds in + let env' = adjoin_typs env te ce in + let _, ve = infer_pat_exhaustive env' pat in + let t2 = check_typ env' typ in + let env'' = + {env' with labs = T.Env.empty; rets = Some t2; async = false} in + check_exp (adjoin_vals env'' ve) t2 exp + end; + t + | ClassD (id, tid, typbinds, sort, pat, id', fields) -> + let t = T.Env.find id.it env.vals in + if not env.pre then begin + let _cs, _ts, te, ce = check_typ_binds env typbinds in + let env' = adjoin_typs env te ce in + let _, ve = infer_pat_exhaustive env' pat in + let env'' = + {env' with labs = T.Env.empty; rets = None; async = false} in + ignore (infer_obj (adjoin_vals env'' ve) sort.it id' fields) + end; + t + | TypD _ -> + T.unit + in + let eff = A.infer_effect_dec dec in + dec.note <- {note_typ = t; note_eff = eff}; + t + +and check_block env t decs at : scope = + let scope = infer_block_decs env decs in + check_block_exps (adjoin env scope) t decs at; + scope + +and check_block_exps env t decs at = + match decs with + | [] -> + if not (T.sub env.cons T.unit t) then + local_error env at "empty block cannot produce expected type\n %s" + (T.string_of_typ_expand env.cons t) + | [dec] -> + check_dec env t dec + | dec::decs' -> + recover (check_dec env T.unit) dec; + recover (check_block_exps env t decs') at + +and check_dec env t dec = + match dec.it with + | ExpD exp -> + check_exp env t exp; + dec.note <- exp.note; +(* TBR: push in external type annotation; + unfortunately, this isn't enough, because of the earlier recursive phases + | FuncD (id, [], pat, typ, exp) -> + (* TBR: special-case unit? *) + if T.eq env.cons t T.unit then + ignore (infer_dec env dec) + else + (match T.nonopt env.cons t with + | T.Func ([], t1, t2)-> + let ve = check_pat env t1 pat in + let t2' = check_typ env typ in + (* TBR: infer return type *) + if not (T.eq env.cons t2 t2') then + error dec.at "expected return type %s but found %s" + (T.string_of_typ t2) (T.string_of_typ t2'); + let env' = + {env with labs = T.Env.empty; rets = Some t2; async = false} in + check_exp (adjoin_vals env' ve) t2 exp + | _ -> + error exp.at "function expression cannot produce expected type %s" + (T.string_of_typ t) + ) + *) + | _ -> + let t' = infer_dec env dec in + (* TBR: special-case unit? *) + if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then + local_error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons t') + +(* +and print_ce = + Con.Env.iter (fun c k -> + Printf.printf " type %s %s\n" (Con.to_string c) (Type.string_of_kind k) + ) +and print_ve = + Type.Env.iter (fun x t -> + Printf.printf " %s : %s\n" x (Type.string_of_typ t) + ) +*) + + +and infer_block_decs env decs : scope = + let scope = gather_block_typdecs env decs in + let env' = adjoin {env with pre = true} scope in + let ce = infer_block_typdecs env' decs in + let env'' = adjoin env { scope with con_env = ce } in + let _ce' = infer_block_typdecs env'' decs in + (* TBR: assertion does not work for types with binders, due to stamping *) + (* assert (ce = ce'); *) + let pre_ve' = gather_block_valdecs env decs in + let ve = infer_block_valdecs (adjoin_vals env'' pre_ve') decs in + { scope with val_env = ve; con_env = ce } + + +(* Pass 1: collect type identifiers and their arity *) +and gather_block_typdecs env decs : scope = + List.fold_left (gather_dec_typdecs env) empty_scope decs + +and gather_dec_typdecs env scope dec : scope = + match dec.it with + | ExpD _ | LetD _ | VarD _ | FuncD _ -> scope + | TypD (id, binds, _) | ClassD (_, id, binds, _, _, _, _) -> + if T.Env.mem id.it scope.typ_env then + error env dec.at "duplicate definition for type %s in block" id.it; + let cs = + List.map (fun (bind : typ_bind) -> Con.fresh bind.it.var.it) binds in + let pre_tbs = List.map (fun c -> {T.var = Con.name c; bound = T.Pre}) cs in + let c = Con.fresh id.it in + let pre_k = T.Abs (pre_tbs, T.Pre) in + let ve' = + match dec.it with + | ClassD (conid, _, _ , _, _, _, _) -> + let t2 = T.Con (c, List.map (fun c' -> T.Con (c', [])) cs) in + T.Env.add conid.it (T.Func (T.Construct, T.Returns, pre_tbs, [T.Pre], [t2])) scope.val_env + | _ -> scope.val_env in + let te' = T.Env.add id.it c scope.typ_env in + let ce' = Con.Env.add c pre_k scope.con_env in + { val_env = ve'; typ_env = te'; con_env = ce' } + + + +(* Pass 2 and 3: infer type definitions *) +and infer_block_typdecs env decs : con_env = + let _env', ce = + List.fold_left (fun (env, ce) dec -> + let ce' = infer_dec_typdecs env dec in + adjoin_cons env ce', Con.Env.adjoin ce ce' + ) (env, Con.Env.empty) decs + in ce + +and infer_dec_typdecs env dec : con_env = + match dec.it with + | ExpD _ | LetD _ | VarD _ | FuncD _ -> + Con.Env.empty + | TypD (id, binds, typ) -> + let c = T.Env.find id.it env.typs in + let cs, ts, te, ce = check_typ_binds {env with pre = true} binds in + let env' = adjoin_typs env te ce in + let t = check_typ env' typ in + let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + Con.Env.singleton c (T.Def (tbs, T.close cs t)) + | ClassD (conid, id, binds, sort, pat, id', fields) -> + let c = T.Env.find id.it env.typs in + let cs, ts, te, ce = check_typ_binds {env with pre = true} binds in + let env' = adjoin_typs {env with pre = true} te ce in + let _, ve = infer_pat env' pat in + let t = infer_obj (adjoin_vals env' ve) sort.it id' fields in + let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + Con.Env.singleton c (T.Abs (tbs, T.close cs t)) + + +(* Pass 4: collect value identifiers *) +and gather_block_valdecs env decs : val_env = + List.fold_left (gather_dec_valdecs env) T.Env.empty decs + +and gather_dec_valdecs env ve dec : val_env = + match dec.it with + | ExpD _ | TypD _ -> + ve + | LetD (pat, _) -> + gather_pat env ve pat + | VarD (id, _) | FuncD (_, id, _, _, _, _) | ClassD (id, _ , _, _, _, _, _) -> + if T.Env.mem id.it ve then + error env dec.at "duplicate definition for %s in block" id.it; + T.Env.add id.it T.Pre ve + + +(* Pass 5: infer value types *) +and infer_block_valdecs env decs : val_env = + let _, ve = + List.fold_left (fun (env, ve) dec -> + let ve' = infer_dec_valdecs env dec in + adjoin_vals env ve', T.Env.adjoin ve ve' + ) (env, T.Env.empty) decs + in ve + +and infer_dec_valdecs env dec : val_env = + match dec.it with + | ExpD _ -> + T.Env.empty + | LetD (pat, exp) -> + let t = infer_exp {env with pre = true} exp in + let ve' = check_pat_exhaustive env t pat in + ve' + | VarD (id, exp) -> + let t = infer_exp {env with pre = true} exp in + T.Env.singleton id.it (T.Mut t) + | FuncD (sort, id, typbinds, pat, typ, exp) -> + let cs, ts, te, ce = check_typ_binds env typbinds in + let env' = adjoin_typs env te ce in + let t1, _ = infer_pat {env' with pre = true} pat in + let t2 = check_typ env' typ in + if not env.pre && sort.it = T.Sharable then begin + if not (T.sub env'.cons t1 T.Shared) then + error env pat.at "shared function has non-shared parameter type\n %s" + (T.string_of_typ_expand env'.cons t1); + begin match t2 with + | T.Tup [] -> () + | T.Async t2 -> + if not (T.sub env'.cons t2 T.Shared) then + error env typ.at "shared function has non-shared result type\n %s" + (T.string_of_typ_expand env'.cons t2); + if not (isAsyncE exp) then + error env dec.at "shared function with async type has non-async body" + | _ -> error env typ.at "shared function has non-async result type\n %s" + (T.string_of_typ_expand env'.cons t2) + end; + end; + let ts1 = match pat.it with + | TupP ps -> T.as_seq t1 + | _ -> [t1] + in + let ts2 = match typ.it with + | TupT _ -> T.as_seq t2 + | _ -> [t2] + in + + let c = match sort.it, typ.it with + | T.Sharable, (AsyncT _) -> T.Promises (* TBR: do we want this for T.Local too? *) + | _ -> T.Returns + in + let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + T.Env.singleton id.it + (T.Func (T.Call sort.it, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) + | TypD _ -> + T.Env.empty + | ClassD (conid, id, typbinds, sort, pat, id', fields) -> + let cs, ts, te, ce = check_typ_binds env typbinds in + let env' = adjoin_typs env te ce in + let c = T.Env.find id.it env.typs in + let t1, _ = infer_pat {env' with pre = true} pat in + let ts1 = match pat.it with + | TupP _ -> T.as_seq t1 + | _ -> [t1] in + let t2 = T.Con (c, List.map (fun c -> T.Con (c, [])) cs) in + let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + T.Env.singleton conid.it (T.Func (T.Construct, T.Returns, tbs, List.map (T.close cs) ts1, [T.close cs t2])) + + +(* Programs *) + +let check_prog scope prog : scope Diag.result = + Diag.with_message_store (fun msgs -> + let env = env_of_scope msgs scope in + recover_opt (check_block env T.unit prog.it) prog.at) + +let infer_prog scope prog : (T.typ * scope) Diag.result = + Diag.with_message_store (fun msgs -> + let env = env_of_scope msgs scope in + recover_opt (infer_block env prog.it) prog.at) + +****) + +let check_prog scope prog : scope Diag.result = assert false diff --git a/src/pipeline.ml b/src/pipeline.ml index 92a4627bab3..c009b3510dc 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -292,6 +292,7 @@ let compile_with check mode name : compile_result = let prog = tailcall_optimization true prog name in let scope' = Typing.adjoin_scope initial_stat_env scope in let prog = Desugar.prog scope'.Typing.con_env prog in + let _ = Check_ir.check_prog (Typing.adjoin_scope Typing.empty_scope scope) prog in phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ diff --git a/src/typing.ml b/src/typing.ml index dafe5976e16..ac5dc1b496f 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -1221,7 +1221,6 @@ and infer_dec_valdecs env dec : val_env = | TupT _ -> T.as_seq t2 | _ -> [t2] in - let c = match sort.it, typ.it with | T.Sharable, (AsyncT _) -> T.Promises (* TBR: do we want this for T.Local too? *) | _ -> T.Returns From 064ba0f575a9ddd7a41561d1dc6e45e656a33bed Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 10 Jan 2019 23:16:12 +0000 Subject: [PATCH 11/45] WIP: almost working check-ir --- src/arrange.ml | 7 +- src/arrange_ir.ml | 10 +- src/check_ir.ml | 468 +++++++++++++++++++-------------------------- src/desugar.ml | 27 ++- src/freevars_ir.ml | 2 +- src/ir.ml | 8 +- src/parser.mly | 11 +- src/pipeline.ml | 2 +- src/syntax.ml | 7 +- src/typing.ml | 6 +- 10 files changed, 247 insertions(+), 301 deletions(-) diff --git a/src/arrange.ml b/src/arrange.ml index 7375d89455b..28df9b0197f 100644 --- a/src/arrange.ml +++ b/src/arrange.ml @@ -150,6 +150,7 @@ and typ t = match t.it with | ParT t -> "ParT" $$ [typ t] and id i = Atom i.it +and con_id i = Atom i.it and name n = Atom (string_of_name n.it) @@ -168,8 +169,8 @@ and dec d = match d.it with exp e ] | TypD (i, tp, t) -> - "TypD" $$ [id i] @ List.map typ_bind tp @ [typ t] + "TypD" $$ [con_id i] @ List.map typ_bind tp @ [typ t] | ClassD (i, j, tp, s, p, i', efs) -> - "ClassD" $$ id i :: id j :: List.map typ_bind tp @ [obj_sort s; pat p; id i'] @ List.map exp_field efs + "ClassD" $$ id i :: con_id j :: List.map typ_bind tp @ [obj_sort s; pat p; id i'] @ List.map exp_field efs -and prog prog = "BlockE" $$ List.map dec prog.it +and prog prog = "BlockE" $$ List.map dec prog.it diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index b7298ba386d..44d8fb3a6ca 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -6,6 +6,7 @@ open Wasm.Sexpr (* for concision, we shadow the imported definition of [Array_type.typ] and pretty print types instead *) let typ t = Atom (Type.string_of_typ t) +let kind k = Atom (Type.string_of_kind k) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] @@ -66,8 +67,11 @@ and dec d = match d.it with | LetD (p, e) -> "LetD" $$ [pat p; exp e] | VarD (i, e) -> "VarD" $$ [id i; exp e] | FuncD (cc, i, tp, p, t, e) -> - "FuncD" $$ [call_conv cc; id i] @ List.map Arrange.typ_bind tp @ [pat p; typ t; exp e] - | TypD (i, tp, t) -> - "TypD" $$ [id i] @ List.map Arrange.typ_bind tp @ [typ t] + "FuncD" $$ [call_conv cc; id i] @ List.map typ_bind tp @ [pat p; typ t; exp e] + | TypD (c,k) -> + "TypD" $$ [con c; kind k] + +and typ_bind (tb : typ_bind) = + tb.it.Type.var $$ [typ tb.it.Type.bound] and prog prog = "BlockE" $$ List.map dec prog.it diff --git a/src/check_ir.ml b/src/check_ir.ml index 7549d5769cb..bed4c4a4d2f 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -1,12 +1,13 @@ open Source - module T = Type -module A = Effect +module E = Effect (* TODO: fix uses of List.sort compare etc on fields rather than field names *) (* TODO: annote DotE in checker for desugaring sans environments *) - +(* TODO: remove DecE from syntax, replace by BlockE [dec] *) +(* TODO: check constraint matching supports recursive bounds *) +(* TODO: remove T.pre, simplify env, desugar ClassD to TypD + FuncD, make note immutable and remove remaining updates *) (* Error bookkeeping *) (* Recovering from errors *) @@ -213,25 +214,6 @@ and check_typ_field env s typ_field : unit = error env no_region "shared object or actor field %s has non-shared type\n %s" name (T.string_of_typ_expand env.cons typ) -(* -and check_typ_binds env typ_binds : T.con list * T.typ list * typ_env * con_env = - let xs = List.map (fun typ_bind -> typ_bind.it.var.it) typ_binds in - let cs = List.map (fun x -> Con.fresh x) xs in - List.iter2 (fun typ_bind c -> typ_bind.note <- T.Con(c,[])) typ_binds cs; - let te = List.fold_left2 (fun te typ_bind c -> - let id = typ_bind.it.var in - if T.Env.mem id.it te then - error env id.at "duplicate type name %s in type parameter list" id.it; - T.Env.add id.it c te - ) T.Env.empty typ_binds cs in - let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in - let pre_env' = add_typs {env with pre = true} xs cs pre_ks in - let ts = List.map (fun typ_bind -> check_typ pre_env' typ_bind.it.bound) typ_binds in - let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in - let env' = add_typs env xs cs ks in - let _ = List.map (fun typ_bind -> check_typ env' typ_bind.it.bound) typ_binds in - cs, ts, te, Con.Env.from_list2 cs ks - *) and check_typ_binds env typ_binds : T.con list * con_env = let xs = List.map (fun typ_bind -> typ_bind.T.var) typ_binds in let cs = List.map (fun x -> Con.fresh x) xs in @@ -267,28 +249,14 @@ and check_typ_bounds env (tbs : T.bind list) typs at : unit = | _, [] -> error env at "too few type arguments" and check_inst_bounds env tbs typs at = - let tys = check_typ_bounds env tbs typs at in - tys - -(* Literals *) - -let check_lit_val env t of_string at s = - try of_string s with _ -> - error env at "literal out of range for type %s" - (T.string_of_typ (T.Prim t)) + check_typ_bounds env tbs typs at -let check_nat env = check_lit_val env T.Nat Value.Nat.of_string -let check_int env = check_lit_val env T.Int Value.Int.of_string -let check_word8 env = check_lit_val env T.Word8 Value.Word8.of_string_u -let check_word16 env = check_lit_val env T.Word16 Value.Word16.of_string_u -let check_word32 env = check_lit_val env T.Word32 Value.Word32.of_string_u -let check_word64 env = check_lit_val env T.Word64 Value.Word64.of_string_u -let check_float env = check_lit_val env T.Float Value.Float.of_string +(* Literals *) let infer_lit env lit at : T.prim = Syntax.( (* yuck *) - match !lit with + match lit with | NullLit -> T.Null | BoolLit _ -> T.Bool | NatLit _ -> T.Nat @@ -300,45 +268,22 @@ let infer_lit env lit at : T.prim = | FloatLit _ -> T.Float | CharLit _ -> T.Char | TextLit _ -> T.Text - | PreLit (s, T.Nat) -> - lit := NatLit (check_nat env at s); (* default *) - T.Nat - | PreLit (s, T.Int) -> - lit := IntLit (check_int env at s); (* default *) - T.Int - | PreLit (s, T.Float) -> - lit := FloatLit (check_float env at s); (* default *) - T.Float - | PreLit _ -> - assert false + | PreLit (s,p) -> + error env at "unresolved literal %s of type\n %s" s (T.string_of_prim p) ) let check_lit env t lit at = Syntax.( - match T.normalize env.cons t, !lit with + match T.normalize env.cons t, lit with | T.Opt _, NullLit -> () - | T.Prim T.Nat, PreLit (s, T.Nat) -> - lit := NatLit (check_nat env at s) - | T.Prim T.Int, PreLit (s, (T.Nat | T.Int)) -> - lit := IntLit (check_int env at s) - | T.Prim T.Word8, PreLit (s, (T.Nat | T.Int)) -> - lit := Word8Lit (check_word8 env at s) - | T.Prim T.Word16, PreLit (s, (T.Nat | T.Int)) -> - lit := Word16Lit (check_word16 env at s) - | T.Prim T.Word32, PreLit (s, (T.Nat | T.Int)) -> - lit := Word32Lit (check_word32 env at s) - | T.Prim T.Word64, PreLit (s, (T.Nat | T.Int)) -> - lit := Word64Lit (check_word64 env at s) - | T.Prim T.Float, PreLit (s, (T.Nat | T.Int | T.Float)) -> - lit := FloatLit (check_float env at s) | t, _ -> let t' = T.Prim (infer_lit env lit at) in if not (T.sub env.cons t' t) then - local_error env at "literal of type\n %s\ndoes not have expected type\n %s" + error env at "literal of type\n %s\ndoes not have expected type\n %s" (T.string_of_typ t') (T.string_of_typ_expand env.cons t) ) -(**** + open Ir (* Expressions *) @@ -352,26 +297,28 @@ let rec infer_exp env exp : T.typ = and infer_exp_promote env exp : T.typ = let t = infer_exp env exp in - let t' = T.promote env.cons t in - if t' = T.Pre then - error env exp.at "cannot infer type of expression while trying to infer surrounding class type,\nbecause its type is a forward reference to type\n %s" - (T.string_of_typ_expand env.cons t); - t' + T.promote env.cons t and infer_exp_mut env exp : T.typ = - assert (exp.note.note_typ = T.Pre); let t = infer_exp' env exp in - assert (t <> T.Pre); - if not env.pre then begin - let e = A.infer_effect_exp exp in - exp.note <- {note_typ = T.normalize env.cons t; note_eff = e} + (* TODO: enable me one infer_effect works on Ir nodes... + let e = E.infer_effect_exp exp in + assert (T.Triv < T.Await); + if not (e <= E.eff exp) then begin + error env exp.at "inferred effect not a subtype of expected effect" end; - t + *) + if not (Type.sub env.cons t (E.typ exp)) then begin + error env exp.at "inferred type %s not a subtype of expected type %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons (E.typ exp)); + end; + E.typ exp; -and infer_exp' env exp : T.typ = +and infer_exp' env (exp:Ir.exp) : T.typ = match exp.it with | PrimE _ -> - error env exp.at "cannot infer type of primitive" + exp.note.Syntax.note_typ (* error env exp.at "cannot infer type of primitive" *) | VarE id -> (match T.Env.find_opt id.it env.vals with | Some T.Pre -> @@ -385,25 +332,29 @@ and infer_exp' env exp : T.typ = let t1 = infer_exp_promote env exp1 in (* Special case for subtyping *) let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in - if not env.pre then begin - assert (!ot = Type.Pre); - if not (Operator.has_unop t op) then - error env exp.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons t); - ot := t; + begin + if not (Operator.has_unop t op) then + error env exp.at "operator is not defined for operand type\n %s" + (T.string_of_typ_expand env.cons t); + if not (T.eq env.cons ot t) then + error env exp.at "bad operator annotation, expecting %s, found %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons ot); end; t | BinE (ot, exp1, op, exp2) -> let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in - if not env.pre then begin - assert (!ot = Type.Pre); + begin if not (Operator.has_binop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) (T.string_of_typ_expand env.cons t2); - ot := t + if not (T.eq env.cons ot t) then + error env exp.at "bad operator annotation, expecting %s, found %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons ot); end; t | RelE (ot,exp1, op, exp2) -> @@ -411,12 +362,14 @@ and infer_exp' env exp : T.typ = let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in if not env.pre then begin - assert (!ot = Type.Pre); if not (Operator.has_relop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) (T.string_of_typ_expand env.cons t2); - ot := t; + if not (T.eq env.cons ot t) then + error env exp.at "bad operator annotation, expecting %s, found %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons ot); end; T.bool | TupE exps -> @@ -438,24 +391,36 @@ and infer_exp' env exp : T.typ = error env exp1.at "expected tuple type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) ) - | ObjE (sort, id, fields) -> - let env' = if sort.it = T.Actor then { env with async = false } else env in - infer_obj env' sort.it id fields - | DotE (exp1, {it = Name n;_}) -> + + | ActorE ( id, fields) -> + let env' = { env with async = false } in + infer_obj env' T.Actor id fields + | ActorDotE(exp1,{it = Syntax.Name n;_}) + | DotE (exp1, {it = Syntax.Name n;_}) -> let t1 = infer_exp_promote env exp1 in (try - let _, tfs = T.as_obj_sub n env.cons t1 in - match List.find_opt (fun {T.name; _} -> name = n) tfs with - | Some {T.typ = t; _} -> t - | None -> - error env exp1.at "field name %s does not exist in type\n %s" - n (T.string_of_typ_expand env.cons t1) - with Invalid_argument _ -> - error env exp1.at "expected object type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) + let sort, tfs = T.as_obj_sub n env.cons t1 in + begin + match exp.it with + | ActorDotE _ -> + if (sort <> T.Actor) then + error env exp.at "expected actor found object" + | DotE _ -> + if (sort == T.Actor) then + error env exp.at "expected object found actor" + | _ -> assert false + end; + match List.find_opt (fun {T.name; _} -> name = n) tfs with + | Some {T.typ = t; _} -> t + | None -> + error env exp1.at "field name %s does not exist in type\n %s" + n (T.string_of_typ_expand env.cons t1) + with Invalid_argument _ -> + error env exp1.at "expected object type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) ) | AssignE (exp1, exp2) -> - if not env.pre then begin + begin let t1 = infer_exp_mut env exp1 in try let t2 = T.as_mut t1 in @@ -467,12 +432,7 @@ and infer_exp' env exp : T.typ = | ArrayE (mut, exps) -> let ts = List.map (infer_exp env) exps in let t1 = List.fold_left (T.lub env.cons) T.Non ts in - if - t1 = T.Any && List.for_all (fun t -> T.promote env.cons t <> T.Any) ts - then - warn env exp.at "this array has type %s because elements have inconsistent types" - (T.string_of_typ (T.Array t1)); - T.Array (match mut.it with Const -> t1 | Var -> T.Mut t1) + T.Array (match mut.it with Syntax.Const -> t1 | Syntax.Var -> T.Mut t1) | IdxE (exp1, exp2) -> let t1 = infer_exp_promote env exp1 in (try @@ -483,13 +443,14 @@ and infer_exp' env exp : T.typ = error env exp1.at "expected array type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) ) - | CallE (exp1, insts, exp2) -> + | CallE (call_conv, exp1, insts, exp2) -> + (* TODO: check call_conv (assuming there's something to check) *) let t1 = infer_exp_promote env exp1 in (try let tbs, t2, t = T.as_func_sub (List.length insts) env.cons t1 in - let ts = check_inst_bounds env tbs insts exp.at in - if not env.pre then check_exp env (T.open_ ts t2) exp2; - T.open_ ts t + check_inst_bounds env tbs insts exp.at; + if not env.pre then check_exp env (T.open_ insts t2) exp2; + T.open_ insts t with Invalid_argument _ -> error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) @@ -501,41 +462,19 @@ and infer_exp' env exp : T.typ = (Con.to_string c) (T.string_of_typ_expand (Con.Env.adjoin env.cons scope.con_env) t) ) - | NotE exp1 -> - if not env.pre then check_exp env T.bool exp1; - T.bool - | AndE (exp1, exp2) -> - if not env.pre then begin - check_exp env T.bool exp1; - check_exp env T.bool exp2 - end; - T.bool - | OrE (exp1, exp2) -> - if not env.pre then begin - check_exp env T.bool exp1; - check_exp env T.bool exp2 - end; - T.bool | IfE (exp1, exp2, exp3) -> if not env.pre then check_exp env T.bool exp1; let t2 = infer_exp env exp2 in let t3 = infer_exp env exp3 in let t = T.lub env.cons t2 t3 in - if - t = T.Any && - T.promote env.cons t2 <> T.Any && T.promote env.cons t3 <> T.Any - then - warn env exp.at "this if has type %s because branches have inconsistent types,\ntrue produces\n %s\nfalse produces\n %s" - (T.string_of_typ t) - (T.string_of_typ_expand env.cons t2) - (T.string_of_typ_expand env.cons t3); t | SwitchE (exp1, cases) -> let t1 = infer_exp_promote env exp1 in let t = infer_cases env t1 T.Non cases in - if not env.pre then +(* if not env.pre then if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; + *) t | WhileE (exp1, exp2) -> if not env.pre then begin @@ -567,8 +506,8 @@ and infer_exp' env exp : T.typ = end; T.unit | LabelE (id, typ, exp1) -> - let t = check_typ env typ in - if not env.pre then check_exp (add_lab env id.it t) t exp1; + let t = check_typ env typ;typ in + check_exp (add_lab env id.it typ) t exp1; t | BreakE (id, exp1) -> (match T.Env.find_opt id.it env.labs with @@ -621,69 +560,66 @@ and infer_exp' env exp : T.typ = check_exp env T.Class exp2 end; T.bool - | AnnotE (exp1, typ) -> - let t = check_typ env typ in - if not env.pre then check_exp env t exp1; - t - | DecE dec -> - let t, scope = infer_block env [dec] exp.at in - (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> - error env exp.at "local class name %s is contained in inferred declaration type\n %s" - (Con.to_string c) (T.string_of_typ_expand env.cons t) - ) - (* DeclareE and DefineE should not occur in source code *) | DeclareE (id, typ, exp1) -> let env' = adjoin_vals env (T.Env.singleton id.it typ) in infer_exp env' exp1 | DefineE (id, mut, exp1) -> begin match T.Env.find_opt id.it env.vals with - | Some T.Pre -> - error env id.at "cannot infer type of forward variable %s" id.it - | Some t1 -> - if not env.pre then begin - try - let t2 = match mut.it with | Var -> T.as_mut t1 | Const -> t1 in - check_exp env t2 exp1 - with Invalid_argument _ -> - error env exp.at "expected mutable assignment target"; - end; + | Some t1 -> + begin + try + let t2 = match mut.it with | Syntax.Var -> T.as_mut t1 | Syntax.Const -> t1 in + check_exp env t2 exp1 + with Invalid_argument _ -> + error env exp.at "expected mutable assignment target"; + end; | None -> error env id.at "unbound variable %s" id.it end; T.unit | NewObjE (sort, labids) -> T.Obj(sort.it, List.map (fun (name,id) -> - {T.name = string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids) + {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids) and check_exp env t exp = - assert (not env.pre); - assert (exp.note.note_typ = T.Pre); - assert (t <> T.Pre); let t' = T.normalize env.cons t in check_exp' env t' exp; - let e = A.infer_effect_exp exp in - exp.note <- {note_typ = t'; note_eff = e} and check_exp' env t exp = +(* match exp.it, t with | PrimE s, T.Func _ -> () | LitE lit, _ -> check_lit env t lit exp.at - | UnE (ot, op, exp1), t' when Operator.has_unop t' op -> - ot := t'; + | UnE (ot, op, exp1), t' -> + if not (Operator.has_unop ot op) then + error env exp.at "no such unary operator for type"; + (T.string_of_typ_expand env.cons t'); + if not (Type.eq env.cons ot t') then + error env exp.at "bad unary operator annotation, expecting %s found %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons (E.typ exp)); check_exp env t' exp1 - | BinE (ot, exp1, op, exp2), t' when Operator.has_binop t' op -> - ot := t'; + | BinE (ot, exp1, op, exp2), t' -> + if not (Operator.has_binop ot op) then + error env exp.at "no such binary operator for type"; + (T.string_of_typ_expand env.cons t'); + if not (Type.eq env.cons ot t') then + error env exp.at "bad binary operator annotation, expecting %s found %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons (E.typ exp)); check_exp env t' exp1; check_exp env t' exp2 | TupE exps, T.Tup ts when List.length exps = List.length ts -> List.iter2 (check_exp env) ts exps | OptE exp1, _ when T.is_opt t -> check_exp env (T.as_opt t) exp1 +(* | ObjE (sort, id, fields), T.Obj (s, tfs) when s = sort.it -> let env' = if sort.it = T.Actor then { env with async = false } else env in ignore (check_obj env' s tfs id fields exp.at) + *) | ArrayE (mut, exps), T.Array t' -> if (mut.it = Var) <> T.is_mut t' then local_error env exp.at "%smutable array expression cannot produce expected type\n %s" @@ -705,6 +641,7 @@ and check_exp' env t exp = if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; | _ -> + *) let t' = infer_exp env exp in if not (T.sub env.cons t' t) then local_error env exp.at "expression of type\n %s\ncannot produce expected type\n %s" @@ -744,7 +681,8 @@ and check_case env t_pat t {it = {pat; exp}; _} = and gather_pat env ve0 pat : val_env = let rec go ve pat = match pat.it with - | WildP | LitP _ | SignP _ -> + | WildP + | LitP _ -> ve | VarP id -> if T.Env.mem id.it ve0 then @@ -754,8 +692,7 @@ and gather_pat env ve0 pat : val_env = List.fold_left go ve pats | AltP (pat1, pat2) -> go ve pat1 - | OptP pat1 - | AnnotP (pat1, _) -> + | OptP pat1 -> go ve pat1 in T.Env.adjoin ve0 (go T.Env.empty pat) @@ -763,13 +700,10 @@ and gather_pat env ve0 pat : val_env = and infer_pat_exhaustive env pat : T.typ * val_env = let t, ve = infer_pat env pat in - if not env.pre then - if not (Coverage.check_pat env.cons pat t) then - warn env pat.at "this pattern does not cover all possible values"; t, ve and infer_pat env pat : T.typ * val_env = - assert (pat.note = T.Pre); + assert (pat.note <> T.Pre); let t, ve = infer_pat' env pat in if not env.pre then pat.note <- T.normalize env.cons t; @@ -783,14 +717,6 @@ and infer_pat' env pat : T.typ * val_env = error env pat.at "cannot infer type of variable" | LitP lit -> T.Prim (infer_lit env lit pat.at), T.Env.empty - | SignP (op, lit) -> - let t1 = T.Prim (infer_lit env lit pat.at) in - (* Special case for subtyping *) - let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in - if not (Operator.has_unop t op) then - local_error env pat.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons t); - t, T.Env.empty | TupP pats -> let ts, ve = infer_pats pat.at env pats [] T.Env.empty in T.Tup ts, ve @@ -804,9 +730,6 @@ and infer_pat' env pat : T.typ * val_env = if ve1 <> T.Env.empty || ve2 <> T.Env.empty then error env pat.at "variables are not allowed in pattern alternatives"; t, T.Env.empty - | AnnotP (pat1, typ) -> - let t = check_typ env typ in - t, check_pat env t pat1 and infer_pats at env pats ts ve : T.typ list * val_env = match pats with @@ -818,14 +741,10 @@ and infer_pats at env pats ts ve : T.typ list * val_env = and check_pat_exhaustive env t pat : val_env = - let ve = check_pat env t pat in - if not env.pre then - if not (Coverage.check_pat env.cons pat t) then - warn env pat.at "this pattern does not cover all possible values"; - ve + check_pat env t pat and check_pat env t pat : val_env = - assert (pat.note = T.Pre); + assert (pat.note <> T.Pre); if t = T.Pre then snd (infer_pat env pat) else let t' = T.normalize env.cons t in let ve = check_pat' env t pat in @@ -842,15 +761,6 @@ and check_pat' env t pat : val_env = | LitP lit -> if not env.pre then check_lit env t lit pat.at; T.Env.empty - | SignP (op, lit) -> - if not env.pre then begin - let t' = T.normalize env.cons t in - if not (Operator.has_unop t op) then - local_error env pat.at "operator cannot consume expected type\n %s" - (T.string_of_typ_expand env.cons t'); - check_lit env t' lit pat.at - end; - T.Env.empty | TupP pats -> (try let ts = T.as_tup_sub (List.length pats) env.cons t in @@ -873,6 +783,7 @@ and check_pat' env t pat : val_env = if ve1 <> T.Env.empty || ve2 <> T.Env.empty then error env pat.at "variables are not allowed in pattern alternatives"; T.Env.empty +(* TBD | _ -> let t', ve = infer_pat env pat in if not (T.sub env.cons t t') then @@ -880,7 +791,8 @@ and check_pat' env t pat : val_env = (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons t); ve - + *) + and check_pats env ts pats ve at : val_env = match pats, ts with | [], [] -> ve @@ -948,8 +860,8 @@ and infer_exp_fields env s id t fields : T.field list * val_env = and is_func_exp exp = match exp.it with - | DecE dec -> is_func_dec dec - | AnnotE (exp, _) -> is_func_exp exp + (* | DecE dec -> is_func_dec dec *) + | BlockE [dec] -> is_func_dec dec | _ -> Printf.printf "[1]%!"; false and is_func_dec dec = @@ -967,27 +879,27 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = (* When checking object in analysis mode *) if not env.pre then begin check_exp (adjoin_vals env ve) (T.as_immut t) exp; - if (mut.it = Var) <> T.is_mut t then + if (mut.it = Syntax.Var) <> T.is_mut t then local_error env field.at "%smutable field %s cannot produce expected %smutable field of type\n %s" - (if mut.it = Var then "" else "im") id.it + (if mut .it = Syntax.Var then "" else "im") id.it (if T.is_mut t then "" else "im") (T.string_of_typ_expand env.cons (T.as_immut t)) end; t in if not env.pre then begin - if s = T.Actor && priv.it = Public && not (is_func_exp exp) then + if s = T.Actor && priv.it = Syntax.Public && not (is_func_exp exp) then error env field.at "public actor field is not a function"; - if s <> T.Object T.Local && priv.it = Public && not (T.sub env.cons t T.Shared) then + if s <> T.Object T.Local && priv.it = Syntax.Public && not (T.sub env.cons t T.Shared) then error env field.at "public shared object or actor field %s has non-shared type\n %s" - (string_of_name name.it) (T.string_of_typ_expand env.cons t) + (Syntax.string_of_name name.it) (T.string_of_typ_expand env.cons t) end; let ve' = T.Env.add id.it t ve in let tfs' = - if priv.it = Private + if priv.it = Syntax.Private then tfs - else {T.name = string_of_name name.it; typ = t} :: tfs + else {T.name = Syntax.string_of_name name.it; typ = t} :: tfs in tfs', ve' @@ -1006,6 +918,20 @@ and infer_block_exps env decs : T.typ = if not env.pre then recover (check_dec env T.unit) dec; recover_with T.Non (infer_block_exps env) decs' +and check_open_typ_binds env typ_binds = + let cs = List.map (fun tp -> match tp.note with + | T.Con(c,[]) -> c + | _ -> assert false (* TODO: remove me by tightening note to Con.t *) + + ) typ_binds in + let ks = List.map (fun tp -> T.Abs([],tp.it.T.bound)) typ_binds in + let ce = List.fold_right2 Con.Env.add cs ks Con.Env.empty in + let binds = T.close_binds cs (List.map (fun tb -> tb.it) typ_binds) in + let _,_ = check_typ_binds env binds in + cs,ce + + + and infer_dec env dec : T.typ = let t = match dec.it with @@ -1017,15 +943,16 @@ and infer_dec env dec : T.typ = | FuncD (sort, id, typbinds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in if not env.pre then begin - let _cs, _ts, te, ce = check_typ_binds env typbinds in - let env' = adjoin_typs env te ce in + let _cs,ce = check_open_typ_binds env typbinds in + let env' = adjoin_typs env ce in let _, ve = infer_pat_exhaustive env' pat in - let t2 = check_typ env' typ in + check_typ env' typ; let env'' = - {env' with labs = T.Env.empty; rets = Some t2; async = false} in - check_exp (adjoin_vals env'' ve) t2 exp + {env' with labs = T.Env.empty; rets = Some typ; async = false} in + check_exp (adjoin_vals env'' ve) typ exp end; t +(* | ClassD (id, tid, typbinds, sort, pat, id', fields) -> let t = T.Env.find id.it env.vals in if not env.pre then begin @@ -1037,12 +964,23 @@ and infer_dec env dec : T.typ = ignore (infer_obj (adjoin_vals env'' ve) sort.it id' fields) end; t +*) | TypD _ -> T.unit in - let eff = A.infer_effect_dec dec in - dec.note <- {note_typ = t; note_eff = eff}; - t + if not (Type.sub env.cons t (E.typ dec)) then begin + error env dec.at "inferred type %s not a subtype of expected type %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons (E.typ dec)); + end; + (* TODO: enable me one infer_effect works on Ir nodes... + let e = E.infer_effect_dec dec in + assert (T.Triv < T.Await); + if not (e <= E.eff dec) then begin + error env dec.at "inferred effect not a subtype of expected effect" + end; + *) + E.typ dec and check_block env t decs at : scope = let scope = infer_block_decs env decs in @@ -1129,23 +1067,11 @@ and gather_block_typdecs env decs : scope = and gather_dec_typdecs env scope dec : scope = match dec.it with | ExpD _ | LetD _ | VarD _ | FuncD _ -> scope - | TypD (id, binds, _) | ClassD (_, id, binds, _, _, _, _) -> - if T.Env.mem id.it scope.typ_env then - error env dec.at "duplicate definition for type %s in block" id.it; - let cs = - List.map (fun (bind : typ_bind) -> Con.fresh bind.it.var.it) binds in - let pre_tbs = List.map (fun c -> {T.var = Con.name c; bound = T.Pre}) cs in - let c = Con.fresh id.it in - let pre_k = T.Abs (pre_tbs, T.Pre) in - let ve' = - match dec.it with - | ClassD (conid, _, _ , _, _, _, _) -> - let t2 = T.Con (c, List.map (fun c' -> T.Con (c', [])) cs) in - T.Env.add conid.it (T.Func (T.Construct, T.Returns, pre_tbs, [T.Pre], [t2])) scope.val_env - | _ -> scope.val_env in - let te' = T.Env.add id.it c scope.typ_env in - let ce' = Con.Env.add c pre_k scope.con_env in - { val_env = ve'; typ_env = te'; con_env = ce' } + | TypD (c, k) -> + if Con.Env.mem c scope.con_env then + error env dec.at "duplicate definition for type %s in block" (Con.to_string c); + let ce' = Con.Env.add c k scope.con_env in + {scope with con_env = ce'} @@ -1162,22 +1088,16 @@ and infer_dec_typdecs env dec : con_env = match dec.it with | ExpD _ | LetD _ | VarD _ | FuncD _ -> Con.Env.empty - | TypD (id, binds, typ) -> - let c = T.Env.find id.it env.typs in - let cs, ts, te, ce = check_typ_binds {env with pre = true} binds in - let env' = adjoin_typs env te ce in - let t = check_typ env' typ in - let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in - Con.Env.singleton c (T.Def (tbs, T.close cs t)) - | ClassD (conid, id, binds, sort, pat, id', fields) -> - let c = T.Env.find id.it env.typs in - let cs, ts, te, ce = check_typ_binds {env with pre = true} binds in - let env' = adjoin_typs {env with pre = true} te ce in - let _, ve = infer_pat env' pat in - let t = infer_obj (adjoin_vals env' ve) sort.it id' fields in - let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in - Con.Env.singleton c (T.Abs (tbs, T.close cs t)) - + | TypD (c, k) -> + let (binds,typ) = + match k with + | T.Abs(binds,typ) + | T.Def(binds,typ) -> (binds,typ) + in + let cs,ce = check_typ_binds env binds in + let env' = adjoin_typs env ce in + check_typ env' typ; + Con.Env.singleton c k (* Pass 4: collect value identifiers *) and gather_block_valdecs env decs : val_env = @@ -1189,7 +1109,7 @@ and gather_dec_valdecs env ve dec : val_env = ve | LetD (pat, _) -> gather_pat env ve pat - | VarD (id, _) | FuncD (_, id, _, _, _, _) | ClassD (id, _ , _, _, _, _, _) -> + | VarD (id, _) | FuncD (_, id, _, _, _, _) -> if T.Env.mem id.it ve then error env dec.at "duplicate definition for %s in block" id.it; T.Env.add id.it T.Pre ve @@ -1215,12 +1135,14 @@ and infer_dec_valdecs env dec : val_env = | VarD (id, exp) -> let t = infer_exp {env with pre = true} exp in T.Env.singleton id.it (T.Mut t) - | FuncD (sort, id, typbinds, pat, typ, exp) -> - let cs, ts, te, ce = check_typ_binds env typbinds in - let env' = adjoin_typs env te ce in + | FuncD (call_conv, id, typbinds, pat, typ, exp) -> + let func_sort = call_conv.Value.sort in + let cs, ce = check_open_typ_binds env typbinds in + let env' = adjoin_typs env ce in let t1, _ = infer_pat {env' with pre = true} pat in - let t2 = check_typ env' typ in - if not env.pre && sort.it = T.Sharable then begin + check_typ env' typ; + let t2 = typ in + if not env.pre && func_sort = T.Call T.Sharable then begin if not (T.sub env'.cons t1 T.Shared) then error env pat.at "shared function has non-shared parameter type\n %s" (T.string_of_typ_expand env'.cons t1); @@ -1228,11 +1150,11 @@ and infer_dec_valdecs env dec : val_env = | T.Tup [] -> () | T.Async t2 -> if not (T.sub env'.cons t2 T.Shared) then - error env typ.at "shared function has non-shared result type\n %s" + error env no_region "shared function has non-shared result type\n %s" (T.string_of_typ_expand env'.cons t2); if not (isAsyncE exp) then error env dec.at "shared function with async type has non-async body" - | _ -> error env typ.at "shared function has non-async result type\n %s" + | _ -> error env no_region "shared function has non-async result type\n %s" (T.string_of_typ_expand env'.cons t2) end; end; @@ -1240,20 +1162,22 @@ and infer_dec_valdecs env dec : val_env = | TupP ps -> T.as_seq t1 | _ -> [t1] in - let ts2 = match typ.it with - | TupT _ -> T.as_seq t2 + let ts2 = match t2 with + | T.Tup _ -> T.as_seq t2 | _ -> [t2] in - let c = match sort.it, typ.it with - | T.Sharable, (AsyncT _) -> T.Promises (* TBR: do we want this for T.Local too? *) + let c = match func_sort, t2 with + | T.Call T.Sharable, (T.Async _) -> T.Promises (* TBR: do we want this for T.Local too? *) | _ -> T.Returns in + let ts = List.map (fun typbind -> typbind.it.T.bound) typbinds in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in T.Env.singleton id.it - (T.Func (T.Call sort.it, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) + (T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) | TypD _ -> T.Env.empty +(* | ClassD (conid, id, typbinds, sort, pat, id', fields) -> let cs, ts, te, ce = check_typ_binds env typbinds in let env' = adjoin_typs env te ce in @@ -1265,7 +1189,7 @@ and infer_dec_valdecs env dec : val_env = let t2 = T.Con (c, List.map (fun c -> T.Con (c, [])) cs) in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in T.Env.singleton conid.it (T.Func (T.Construct, T.Returns, tbs, List.map (T.close cs) ts1, [T.close cs t2])) - + *) (* Programs *) @@ -1278,7 +1202,3 @@ let infer_prog scope prog : (T.typ * scope) Diag.result = Diag.with_message_store (fun msgs -> let env = env_of_scope msgs scope in recover_opt (infer_block env prog.it) prog.at) - -****) - -let check_prog scope prog : scope Diag.result = assert false diff --git a/src/desugar.ml b/src/desugar.ml index 94e59a0ea07..7e97c124d37 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -133,27 +133,34 @@ let and exp_fields ce fs = List.map (exp_field ce) fs and exp_field ce f = phrase ce exp_field' f - and exp_field' cd (f : S.exp_field') = - S.{ I.name = f.name; I.id = f.id; I.exp = exp cd f.exp; I.mut = f.mut; I.priv = f.priv} + and exp_field' ce (f : S.exp_field') = + S.{ I.name = f.name; I.id = f.id; I.exp = exp ce f.exp; I.mut = f.mut; I.priv = f.priv} + + and typ_binds ce tbs = List.map (typ_bind ce) tbs + and typ_bind ce tb = + phrase' ce typ_bind' tb + and typ_bind' ce at n {S.var; S.bound} = {Type.var = var.it; Type.bound = bound.note} and decs ce ds = List.map (dec ce) ds and dec ce d = phrase' ce dec' d and dec' ce at n = function | S.ExpD e -> I.ExpD (exp ce e) | S.LetD (p, e) -> I.LetD (pat ce p, exp ce e) | S.VarD (i, e) -> I.VarD (i, exp ce e) - | S.FuncD (s, i, tp, p, ty, e) -> + | S.FuncD (s, i, tbs, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, tp, pat ce p, ty.note, exp ce e) - | S.TypD (i, ty, t) -> I.TypD (i, ty, t.note) - | S.ClassD (fun_id, typ_id, tp, s, p, self_id, es) -> + I.FuncD (cc, i, typ_binds ce tbs, pat ce p, ty.note, exp ce e) + | S.TypD (con_id, typ_bind, t) -> + let (c,k) = Lib.Option.value con_id.note in + I.TypD (c,k) + | S.ClassD (fun_id, typ_id, tbs, s, p, self_id, es) -> let cc = Value.call_conv_of_typ n.S.note_typ in let inst = List.map - (fun tp -> - match tp.note with + (fun tb -> + match tb.note with | Type.Pre -> assert false | t -> t) - tp in + tbs in let obj_typ = match n.S.note_typ with | T.Func(s,c,bds,dom,[rng]) -> @@ -161,7 +168,7 @@ let T.open_ inst rng | _ -> assert false in - I.FuncD (cc, fun_id, tp, pat ce p, obj_typ, (* TBR *) + I.FuncD (cc, fun_id, typ_binds ce tbs, pat ce p, obj_typ, (* TBR *) {it = obj ce at s (Some fun_id) self_id es obj_typ; at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}) diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index b44e43c1ee1..66e0c8e0ea5 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -123,7 +123,7 @@ and dec d = match d.it with (M.empty, S.singleton i.it) +++ exp e | FuncD (cc, i, tp, p, t, e) -> (M.empty, S.singleton i.it) +++ under_lambda (exp e /// pat p) - | TypD (i, tp, t) -> (M.empty, S.empty) + | TypD (c,k) -> (M.empty, S.empty) (* The variables captured by a function. May include the function itself! *) and captured p e = diff --git a/src/ir.ml b/src/ir.ml index 7effc1fbeae..1d29bee958c 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -1,7 +1,11 @@ (* Patterns *) +(* TODO: replace Syntax.typ_bind *) + type 'a phrase = ('a,Syntax.typ_note) Source.annotated_phrase +type typ_bind = (Type.bind, Type.typ) Source.annotated_phrase + type pat = (pat',Type.typ) Source.annotated_phrase and pat' = | WildP (* wildcard *) @@ -62,8 +66,8 @@ and dec' = | ExpD of exp (* plain expression *) | LetD of pat * exp (* immutable *) | VarD of Syntax.id * exp (* mutable *) - | FuncD of Value.call_conv * Syntax.id * Syntax.typ_bind list * pat * Type.typ * exp (* function *) - | TypD of Syntax.id * Syntax.typ_bind list * Type.typ (* type *) + | FuncD of Value.call_conv * Syntax.id * typ_bind list * pat * Type.typ * exp (* function *) + | TypD of Type.con * Type.kind (* type *) (* Program *) diff --git a/src/parser.mly b/src/parser.mly index 6d22700158f..938359b40fe 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -22,6 +22,7 @@ let at (startpos, endpos) = positions_to_region startpos endpos let (@?) it at = {it; at; note = empty_typ_note} let (@!) it at = {it; at; note = Type.Pre} +let (@=) it at = {it; at; note = None} let dup_var x = VarE (x.it @@ x.at) @? x.at @@ -155,6 +156,9 @@ seplist1(X, SEP) : %inline id : | id=ID { id @@ at $sloc } +%inline con_id : + | id=ID { id @= at $sloc } + %inline id_opt : | id=ID { fun _ _ -> id @@ at $sloc } @@ -536,7 +540,7 @@ dec_var : dec_nonvar : | s=shared_opt FUNC xf=id_opt fd=func_dec { (fd s (xf "func" $sloc)).it @? at $sloc } - | TYPE x=id tps=typ_params_opt EQ t=typ + | TYPE x=con_id tps=typ_params_opt EQ t=typ { TypD(x, tps, t) @? at $sloc } | s=obj_sort_opt CLASS xf=id_opt tps=typ_params_opt p=pat_nullary xefs=class_body { let x, efs = xefs in @@ -545,8 +549,9 @@ dec_nonvar : then efs else List.map share_expfield efs in - let tid = xf "class" $sloc in - ClassD(xf "class" $sloc, tid, tps, s, p, x, efs') @? at $sloc } + let id = xf "class" $sloc in + let con_id = id.it @= at $sloc in + ClassD(id, con_id, tps, s, p, x, efs') @? at $sloc } dec : | d=dec_var diff --git a/src/pipeline.ml b/src/pipeline.ml index c009b3510dc..e7c3b1764ff 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -292,7 +292,7 @@ let compile_with check mode name : compile_result = let prog = tailcall_optimization true prog name in let scope' = Typing.adjoin_scope initial_stat_env scope in let prog = Desugar.prog scope'.Typing.con_env prog in - let _ = Check_ir.check_prog (Typing.adjoin_scope Typing.empty_scope scope) prog in + let _ = Check_ir.check_prog (Typing.adjoin_scope Typing.empty_scope scope) prog in phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ diff --git a/src/syntax.ml b/src/syntax.ml index be07497cffa..f529c6efe81 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -7,7 +7,8 @@ let empty_typ_note = {note_typ = Type.Pre; note_eff = Type.Triv} (* Identifiers *) type id = string Source.phrase - +type con_id = (string, (Type.con * Type.kind) option) Source.annotated_phrase + (* Names (not alpha-convertible), used for field and class names *) type name = name' Source.phrase and name' = Name of string @@ -185,8 +186,8 @@ and dec' = | LetD of pat * exp (* immutable *) | VarD of id * exp (* mutable *) | FuncD of sharing * id * typ_bind list * pat * typ * exp (* function *) - | TypD of id * typ_bind list * typ (* type *) - | ClassD of id (*term id*) * id (*type id*) * typ_bind list * obj_sort * pat * id * exp_field list (* class *) + | TypD of con_id * typ_bind list * typ (* type *) + | ClassD of id (*term id*) * con_id (*type id*) * typ_bind list * obj_sort * pat * id * exp_field list (* class *) (* Program *) diff --git a/src/typing.ml b/src/typing.ml index ac5dc1b496f..4e5a7b6d247 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -1145,7 +1145,9 @@ and infer_dec_typdecs env dec : con_env = let env' = adjoin_typs env te ce in let t = check_typ env' typ in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in - Con.Env.singleton c (T.Def (tbs, T.close cs t)) + let k = T.Def (tbs, T.close cs t) in + id.note <- Some (c,k); + Con.Env.singleton c k | ClassD (conid, id, binds, sort, pat, id', fields) -> let c = T.Env.find id.it env.typs in let cs, ts, te, ce = check_typ_binds {env with pre = true} binds in @@ -1153,6 +1155,8 @@ and infer_dec_typdecs env dec : con_env = let _, ve = infer_pat env' pat in let t = infer_obj (adjoin_vals env' ve) sort.it id' fields in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + let k = T.Abs (tbs, T.close cs t) in + id.note <- Some (c,k); Con.Env.singleton c (T.Abs (tbs, T.close cs t)) From 6ac59b1b518ec612b66fd214114a75f74cb370c0 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Fri, 11 Jan 2019 18:44:12 +0000 Subject: [PATCH 12/45] desugar ClassD into TypD and FuncD; fix intial env in call oo check IR --- src/check_ir.ml | 46 ++++++++++++++++++++++++---------------------- src/desugar.ml | 19 +++++++++++++++---- src/env.ml | 1 + src/pipeline.ml | 4 +++- 4 files changed, 43 insertions(+), 27 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index bed4c4a4d2f..3283053e6ce 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -301,17 +301,19 @@ and infer_exp_promote env exp : T.typ = and infer_exp_mut env exp : T.typ = let t = infer_exp' env exp in - (* TODO: enable me one infer_effect works on Ir nodes... - let e = E.infer_effect_exp exp in - assert (T.Triv < T.Await); - if not (e <= E.eff exp) then begin - error env exp.at "inferred effect not a subtype of expected effect" - end; - *) - if not (Type.sub env.cons t (E.typ exp)) then begin - error env exp.at "inferred type %s not a subtype of expected type %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ exp)); + if not env.pre then begin + (* TODO: enable me one infer_effect works on Ir nodes... + let e = E.infer_effect_exp exp in + assert (T.Triv < T.Await); + if not (e <= E.eff exp) then begin + error env exp.at "inferred effect not a subtype of expected effect" + end; + *) + if not (Type.sub env.cons t (E.typ exp)) then begin + error env exp.at "inferred type %s not a subtype of expected type %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons (E.typ exp)); + end end; E.typ exp; @@ -332,21 +334,21 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = infer_exp_promote env exp1 in (* Special case for subtyping *) let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in - begin - if not (Operator.has_unop t op) then - error env exp.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons t); - if not (T.eq env.cons ot t) then - error env exp.at "bad operator annotation, expecting %s, found %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons ot); + if not env.pre then begin + if not (Operator.has_unop t op) then + error env exp.at "operator is not defined for operand type\n %s" + (T.string_of_typ_expand env.cons t); + if not (T.eq env.cons ot t) then + error env exp.at "bad operator annotation, expecting %s, found %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons ot); end; t | BinE (ot, exp1, op, exp2) -> let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in - begin + if not env.pre then begin if not (Operator.has_binop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) @@ -420,7 +422,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ_expand env.cons t1) ) | AssignE (exp1, exp2) -> - begin + if not env.pre then begin let t1 = infer_exp_mut env exp1 in try let t2 = T.as_mut t1 in @@ -507,7 +509,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.unit | LabelE (id, typ, exp1) -> let t = check_typ env typ;typ in - check_exp (add_lab env id.it typ) t exp1; + if not env.pre then check_exp (add_lab env id.it typ) t exp1; t | BreakE (id, exp1) -> (match T.Env.find_opt id.it env.labs with diff --git a/src/desugar.ml b/src/desugar.ml index 7e97c124d37..82cfc57f9a0 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -74,7 +74,7 @@ let | S.AssertE e -> I.AssertE (exp ce e) | S.IsE (e1, e2) -> I.IsE (exp ce e1, exp ce e2) | S.AnnotE (e, _) -> exp' ce at note e.it - | S.DecE d -> I.BlockE [dec ce d] + | S.DecE d -> I.BlockE (decs ce [d]) | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp ce e) | S.DefineE (i, m, e) -> I.DefineE (i, m, exp ce e) | S.NewObjE (s, fs) -> I.NewObjE (s, fs) @@ -141,9 +141,20 @@ let and typ_bind ce tb = phrase' ce typ_bind' tb and typ_bind' ce at n {S.var; S.bound} = {Type.var = var.it; Type.bound = bound.note} - and decs ce ds = List.map (dec ce) ds - and dec ce d = phrase' ce dec' d - and dec' ce at n = function + and decs ce ds = + match ds with + | [] -> [] + | d::ds -> + match d.it with + | S.ClassD(_,con_id,_,_,_,_,_) -> + let (c,k) = match con_id.note with Some p -> p | _ -> assert false in + let typD = {it = I.TypD (c,k); + at = d.at; + note = {S.note_typ = T.unit; S.note_eff = T.Triv}} + in + typD::(phrase' ce dec' d)::(decs ce ds) + | _ -> (phrase' ce dec' d)::(decs ce ds) + and dec' ce at n d = match d with | S.ExpD e -> I.ExpD (exp ce e) | S.LetD (p, e) -> I.LetD (pat ce p, exp ce e) | S.VarD (i, e) -> I.VarD (i, exp ce e) diff --git a/src/env.ml b/src/env.ml index 4b602b806aa..8d269c2033d 100644 --- a/src/env.ml +++ b/src/env.ml @@ -22,4 +22,5 @@ struct let adjoin env1 env2 = union (fun _ x1 x2 -> Some x2) env1 env2 let disjoint_union env1 env2 = union (fun k _ _ -> raise (Clash k)) env1 env2 let disjoint_add k x env = disjoint_union env (singleton k x) + end diff --git a/src/pipeline.ml b/src/pipeline.ml index e7c3b1764ff..b0cd008080e 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -292,7 +292,9 @@ let compile_with check mode name : compile_result = let prog = tailcall_optimization true prog name in let scope' = Typing.adjoin_scope initial_stat_env scope in let prog = Desugar.prog scope'.Typing.con_env prog in - let _ = Check_ir.check_prog (Typing.adjoin_scope Typing.empty_scope scope) prog in + match Check_ir.check_prog initial_stat_env prog with + | Error msgs -> Diag.print_messages msgs; assert (false) + | Ok _ -> (); phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ From 38c3849a60a18f86f55ce9e64ac693e102e14a14 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Sat, 12 Jan 2019 00:02:57 +0000 Subject: [PATCH 13/45] ironing out bugs --- src/async.ml | 2 +- src/check_ir.ml | 56 +++++++++++++++++++++++++++++++++---------------- src/pipeline.ml | 2 +- 3 files changed, 40 insertions(+), 20 deletions(-) diff --git a/src/async.ml b/src/async.ml index 13e775e0d33..bd32c3ed2a3 100644 --- a/src/async.ml +++ b/src/async.ml @@ -74,7 +74,7 @@ let new_async t1 = let letP p e = {it = LetD(p,e); at = no_region; - note = e.note} + note = {e.note with note_typ = T.unit}} let new_nary_async_reply t1 = let (unary_async,unary_fullfill),call_new_async = new_async t1 in diff --git a/src/check_ir.ml b/src/check_ir.ml index 3283053e6ce..27b7bf45130 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -93,7 +93,7 @@ let add_typ c x con k = } *) -let add_typs c xs cs ks = +let add_typs c cs ks = { c with (* typs = List.fold_right2 T.Env.add xs cs c.typs; *) cons = List.fold_right2 Con.Env.add cs ks c.cons; @@ -214,6 +214,7 @@ and check_typ_field env s typ_field : unit = error env no_region "shared object or actor field %s has non-shared type\n %s" name (T.string_of_typ_expand env.cons typ) +(* and check_typ_binds env typ_binds : T.con list * con_env = let xs = List.map (fun typ_bind -> typ_bind.T.var) typ_binds in let cs = List.map (fun x -> Con.fresh x) xs in @@ -232,7 +233,21 @@ and check_typ_binds env typ_binds : T.con list * con_env = let env' = add_typs env xs cs ks in let _ = List.map (fun typ_bind -> check_typ env' typ_bind.T.bound) typ_binds in cs, Con.Env.from_list2 cs ks - + *) +and check_typ_binds env typ_binds : T.con list * con_env = + let ts,ce = Type.open_binds env.cons typ_binds in + let cs = List.map (function T.Con(c,[]) -> c | _ -> assert false) ts in + let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in + let _pre_env' = add_typs {env with pre = true} cs pre_ks in + let bds = List.map (fun typ_bind -> let t = T.open_ ts typ_bind.T.bound in + (* check_typ pre_env' t; *) + t) typ_binds in + let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in + let env' = add_typs env cs ks in + let _ = List.map (fun bd -> check_typ env' bd) bds in + cs, Con.Env.from_list2 cs ks + + and check_typ_bounds env (tbs : T.bind list) typs at : unit = match tbs, typs with | tb::tbs', typ::typs' -> @@ -309,7 +324,7 @@ and infer_exp_mut env exp : T.typ = error env exp.at "inferred effect not a subtype of expected effect" end; *) - if not (Type.sub env.cons t (E.typ exp)) then begin + if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then begin (*TBR*) error env exp.at "inferred type %s not a subtype of expected type %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ exp)); @@ -580,9 +595,11 @@ and infer_exp' env (exp:Ir.exp) : T.typ = end; T.unit | NewObjE (sort, labids) -> - T.Obj(sort.it, List.map (fun (name,id) -> - {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids) - + T.Non +(* TOFO: compare with + T.Obj(sort.it, List.sort compare (List.map (fun (name,id) -> + {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) + *) and check_exp env t exp = let t' = T.normalize env.cons t in check_exp' env t' exp; @@ -714,9 +731,11 @@ and infer_pat env pat : T.typ * val_env = and infer_pat' env pat : T.typ * val_env = match pat.it with | WildP -> - error env pat.at "cannot infer type of wildcard" - | VarP _ -> - error env pat.at "cannot infer type of variable" + (pat.note, T.Env.empty) + (* error env pat.at "cannot infer type of wildcard" *) + | VarP id -> + (pat.note, T.Env.singleton id.it pat.note) + (* error env pat.at "cannot infer type of variable" *) | LitP lit -> T.Prim (infer_lit env lit pat.at), T.Env.empty | TupP pats -> @@ -971,7 +990,7 @@ and infer_dec env dec : T.typ = T.unit in if not (Type.sub env.cons t (E.typ dec)) then begin - error env dec.at "inferred type %s not a subtype of expected type %s" + error env dec.at "inferred dec type %s not a subtype of expected type %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ dec)); end; @@ -1005,7 +1024,7 @@ and check_dec env t dec = match dec.it with | ExpD exp -> check_exp env t exp; - dec.note <- exp.note; + (*TODO dec.note <- exp.note; *) (* TBR: push in external type annotation; unfortunately, this isn't enough, because of the earlier recursive phases | FuncD (id, [], pat, typ, exp) -> @@ -1097,8 +1116,9 @@ and infer_dec_typdecs env dec : con_env = | T.Def(binds,typ) -> (binds,typ) in let cs,ce = check_typ_binds env binds in + let ts = List.map (fun c -> T.Con(c,[])) cs in let env' = adjoin_typs env ce in - check_typ env' typ; + check_typ env' (T.open_ ts typ); Con.Env.singleton c k (* Pass 4: collect value identifiers *) @@ -1160,13 +1180,13 @@ and infer_dec_valdecs env dec : val_env = (T.string_of_typ_expand env'.cons t2) end; end; - let ts1 = match pat.it with - | TupP ps -> T.as_seq t1 - | _ -> [t1] + let ts1 = match call_conv.Value.n_args with + | 1 -> [t1] + | _ -> T.as_seq t1 in - let ts2 = match t2 with - | T.Tup _ -> T.as_seq t2 - | _ -> [t2] + let ts2 = match call_conv.Value.n_res with + | 1 -> [t2] + | _ -> T.as_seq t2 in let c = match func_sort, t2 with diff --git a/src/pipeline.ml b/src/pipeline.ml index b0cd008080e..0904b301ecb 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -294,7 +294,7 @@ let compile_with check mode name : compile_result = let prog = Desugar.prog scope'.Typing.con_env prog in match Check_ir.check_prog initial_stat_env prog with | Error msgs -> Diag.print_messages msgs; assert (false) - | Ok _ -> (); + | Ok (_,msgs) -> Diag.print_messages msgs; phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ From cbc74edd7969d231cddd789968f60ab4fc1d5e94 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 14 Jan 2019 13:38:55 +0000 Subject: [PATCH 14/45] fix async lowering to also lower (new) type and kind annotations on TypD, ClassD and syntactic types --- src/async.ml | 96 ++++++++++++++++++++++++++++--------------------- src/check_ir.ml | 4 +-- src/syntax.ml | 2 +- 3 files changed, 59 insertions(+), 43 deletions(-) diff --git a/src/async.ml b/src/async.ml index bd32c3ed2a3..fafe943f0ed 100644 --- a/src/async.ml +++ b/src/async.ml @@ -194,12 +194,24 @@ let rec t_typ (t:T.typ) = and t_bind {var; bound} = {var; bound = t_typ bound} +and t_kind k = match k with + | T.Abs(tbs,t) -> + T.Abs(List.map t_bind tbs, t_typ t) + | T.Def(tbs,t) -> + T.Def(List.map t_bind tbs, t_typ t) + and t_operator_type ot = (* We recreate the reference here. That is ok, because it we run after type inference. Once we move async past desugaring, it will be a pure value anyways. *) ref (t_typ !ot) +and t_con_id conid = + { it = conid.it; + at = conid.at; + note = Lib.Option.map (fun (c,k) -> (c,t_kind k)) conid.note + } + and t_field {name; typ} = {name; typ = t_typ typ} let rec t_exp (exp:Syntax.exp) = @@ -236,7 +248,7 @@ and t_exp' (exp:Syntax.exp) = | ArrayE (mut, exps) -> ArrayE (mut, List.map t_exp exps) | IdxE (exp1, exp2) -> - IdxE (t_exp exp1, t_exp exp2) + IdxE (t_exp exp1, t_exp exp2) | CallE ({it=PrimE "@await";_}, typs, exp2) -> begin match exp2.it with @@ -244,42 +256,42 @@ and t_exp' (exp:Syntax.exp) = | _ -> assert false end | CallE ({it=PrimE "@async";_}, typs, exp2) -> - let t1, contT = match typ exp2 with - | Func(_,_, - [], - [Func(_,_,[],ts1,[]) as contT], - []) -> (* TBR, why isn't this []? *) - (t_typ (T.seq ts1),t_typ contT) - | t -> assert false in - let k = fresh_id contT in - let v1 = fresh_id t1 in - let post = fresh_id (T.Func(T.Call T.Sharable,T.Returns,[],[],[])) in - let u = fresh_id T.unit in - let ((nary_async,nary_reply),def) = new_nary_async_reply t1 in - (blockE [letP (tupP [varP nary_async; varP nary_reply]) def; - funcD k v1 (nary_reply -*- v1); - funcD post u (t_exp exp2 -*- k); - expD (post -*- tupE[]); - expD nary_async]) - .it + let t1, contT = match typ exp2 with + | Func(_,_, + [], + [Func(_,_,[],ts1,[]) as contT], + []) -> (* TBR, why isn't this []? *) + (t_typ (T.seq ts1),t_typ contT) + | t -> assert false in + let k = fresh_id contT in + let v1 = fresh_id t1 in + let post = fresh_id (T.Func(T.Call T.Sharable,T.Returns,[],[],[])) in + let u = fresh_id T.unit in + let ((nary_async,nary_reply),def) = new_nary_async_reply t1 in + (blockE [letP (tupP [varP nary_async; varP nary_reply]) def; + funcD k v1 (nary_reply -*- v1); + funcD post u (t_exp exp2 -*- k); + expD (post -*- tupE[]); + expD nary_async]) + .it | CallE (exp1, typs, exp2) when isAwaitableFunc exp1 -> - let ts1,t2 = - match typ exp1 with - | T.Func (T.Call T.Sharable,T.Promises,tbs,ts1,[T.Async t2]) -> - ts1, t_typ t2 - | _ -> assert(false) - in - let exp1' = t_exp exp1 in - let exp2' = t_exp exp2 in - let typs = List.map t_typT typs in - let ((nary_async,nary_reply),def) = new_nary_async_reply t2 in - let _ = letEta in - (blockE (letP (tupP [varP nary_async; varP nary_reply]) def:: - letEta exp1' (fun v1 -> - letSeq ts1 exp2' (fun vs -> - [expD (callE v1 typs (seqE (vs@[nary_reply])) T.unit); - expD nary_async])))) - .it + let ts1,t2 = + match typ exp1 with + | T.Func (T.Call T.Sharable,T.Promises,tbs,ts1,[T.Async t2]) -> + List.map t_typ ts1, t_typ t2 + | _ -> assert(false) + in + let exp1' = t_exp exp1 in + let exp2' = t_exp exp2 in + let typs = List.map t_typT typs in + let ((nary_async,nary_reply),def) = new_nary_async_reply t2 in + let _ = letEta in + (blockE (letP (tupP [varP nary_async; varP nary_reply]) def:: + letEta exp1' (fun v1 -> + letSeq ts1 exp2' (fun vs -> + [expD (callE v1 typs (seqE (vs@[nary_reply])) T.unit); + expD nary_async])))) + .it | CallE (exp1, typs, exp2) -> CallE(t_exp exp1, List.map t_typT typs, t_exp exp2) | BlockE decs -> @@ -337,7 +349,8 @@ and t_dec dec = and t_dec' dec' = match dec' with | ExpD exp -> ExpD (t_exp exp) - | TypD _ -> dec' + | TypD (conid, typbinds, typ) -> + TypD (t_con_id conid, t_typbinds typbinds, t_typT typ) | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) | VarD (id,exp) -> VarD (id,t_exp exp) | FuncD (s, id, typbinds, pat, typT, exp) -> @@ -375,9 +388,9 @@ and t_dec' dec' = | _ -> assert false end end - | ClassD (id, lab, typbinds, sort, pat, id', fields) -> + | ClassD (id, conid, typbinds, sort, pat, id', fields) -> let fields' = t_fields fields in - ClassD (id, lab, t_typbinds typbinds, sort, t_pat pat, id', fields') + ClassD (id, t_con_id conid, t_typbinds typbinds, sort, t_pat pat, id', fields') and t_decs decs = List.map t_dec decs @@ -415,7 +428,10 @@ and t_asyncT t = unitT) and t_typT t = - { t with it = t_typT' t.it } + { it = t_typT' t.it; + at = t.at; + note = t_typ t.note; + } and t_typT' t = match t with diff --git a/src/check_ir.ml b/src/check_ir.ml index 27b7bf45130..507abf20f1b 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -71,8 +71,8 @@ let env_of_scope msgs scope = (* More error bookkeeping *) -let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "type"; text } -let type_warning at text : Diag.message = Diag.{ sev = Diag.Warning; at; cat = "type"; text } +let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "IR type"; text } +let type_warning at text : Diag.message = Diag.{ sev = Diag.Warning; at; cat = "IR type"; text } let local_error env at fmt = Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_error at s)) fmt diff --git a/src/syntax.ml b/src/syntax.ml index f529c6efe81..dfbf732c092 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -8,7 +8,7 @@ let empty_typ_note = {note_typ = Type.Pre; note_eff = Type.Triv} type id = string Source.phrase type con_id = (string, (Type.con * Type.kind) option) Source.annotated_phrase - + (* Names (not alpha-convertible), used for field and class names *) type name = name' Source.phrase and name' = Name of string From cda0233c73402ce457ca8f7d738d5c91b5d7fe76 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 14 Jan 2019 13:48:02 +0000 Subject: [PATCH 15/45] rename typbind to typ_bind, conid to con_id --- src/async.ml | 16 ++++++++-------- src/check_ir.ml | 18 +++++++++--------- src/typing.ml | 16 ++++++++-------- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/async.ml b/src/async.ml index fafe943f0ed..36db08d9ccd 100644 --- a/src/async.ml +++ b/src/async.ml @@ -206,10 +206,10 @@ and t_operator_type ot = it will be a pure value anyways. *) ref (t_typ !ot) -and t_con_id conid = - { it = conid.it; - at = conid.at; - note = Lib.Option.map (fun (c,k) -> (c,t_kind k)) conid.note +and t_con_id con_id = + { it = con_id.it; + at = con_id.at; + note = Lib.Option.map (fun (c,k) -> (c,t_kind k)) con_id.note } and t_field {name; typ} = @@ -349,8 +349,8 @@ and t_dec dec = and t_dec' dec' = match dec' with | ExpD exp -> ExpD (t_exp exp) - | TypD (conid, typbinds, typ) -> - TypD (t_con_id conid, t_typbinds typbinds, t_typT typ) + | TypD (con_id, typbinds, typ) -> + TypD (t_con_id con_id, t_typbinds typbinds, t_typT typ) | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) | VarD (id,exp) -> VarD (id,t_exp exp) | FuncD (s, id, typbinds, pat, typT, exp) -> @@ -388,9 +388,9 @@ and t_dec' dec' = | _ -> assert false end end - | ClassD (id, conid, typbinds, sort, pat, id', fields) -> + | ClassD (id, con_id, typbinds, sort, pat, id', fields) -> let fields' = t_fields fields in - ClassD (id, t_con_id conid, t_typbinds typbinds, sort, t_pat pat, id', fields') + ClassD (id, t_con_id con_id, t_typbinds typbinds, sort, t_pat pat, id', fields') and t_decs decs = List.map t_dec decs diff --git a/src/check_ir.ml b/src/check_ir.ml index 507abf20f1b..254fc06b52c 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -961,10 +961,10 @@ and infer_dec env dec : T.typ = | LetD (_, exp) | VarD (_, exp) -> if not env.pre then ignore (infer_exp env exp); T.unit - | FuncD (sort, id, typbinds, pat, typ, exp) -> + | FuncD (sort, id, typ_binds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in if not env.pre then begin - let _cs,ce = check_open_typ_binds env typbinds in + let _cs,ce = check_open_typ_binds env typ_binds in let env' = adjoin_typs env ce in let _, ve = infer_pat_exhaustive env' pat in check_typ env' typ; @@ -974,10 +974,10 @@ and infer_dec env dec : T.typ = end; t (* - | ClassD (id, tid, typbinds, sort, pat, id', fields) -> + | ClassD (id, tid, typ_binds, sort, pat, id', fields) -> let t = T.Env.find id.it env.vals in if not env.pre then begin - let _cs, _ts, te, ce = check_typ_binds env typbinds in + let _cs, _ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let _, ve = infer_pat_exhaustive env' pat in let env'' = @@ -1157,9 +1157,9 @@ and infer_dec_valdecs env dec : val_env = | VarD (id, exp) -> let t = infer_exp {env with pre = true} exp in T.Env.singleton id.it (T.Mut t) - | FuncD (call_conv, id, typbinds, pat, typ, exp) -> + | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> let func_sort = call_conv.Value.sort in - let cs, ce = check_open_typ_binds env typbinds in + let cs, ce = check_open_typ_binds env typ_binds in let env' = adjoin_typs env ce in let t1, _ = infer_pat {env' with pre = true} pat in check_typ env' typ; @@ -1193,15 +1193,15 @@ and infer_dec_valdecs env dec : val_env = | T.Call T.Sharable, (T.Async _) -> T.Promises (* TBR: do we want this for T.Local too? *) | _ -> T.Returns in - let ts = List.map (fun typbind -> typbind.it.T.bound) typbinds in + let ts = List.map (fun typbind -> typbind.it.T.bound) typ_binds in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in T.Env.singleton id.it (T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) | TypD _ -> T.Env.empty (* - | ClassD (conid, id, typbinds, sort, pat, id', fields) -> - let cs, ts, te, ce = check_typ_binds env typbinds in + | ClassD (conid, id, typ_binds, sort, pat, id', fields) -> + let cs, ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let c = T.Env.find id.it env.typs in let t1, _ = infer_pat {env' with pre = true} pat in diff --git a/src/typing.ml b/src/typing.ml index 4e5a7b6d247..f48ec73f2a3 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -991,10 +991,10 @@ and infer_dec env dec : T.typ = | LetD (_, exp) | VarD (_, exp) -> if not env.pre then ignore (infer_exp env exp); T.unit - | FuncD (sort, id, typbinds, pat, typ, exp) -> + | FuncD (sort, id, typ_binds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in if not env.pre then begin - let _cs, _ts, te, ce = check_typ_binds env typbinds in + let _cs, _ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let _, ve = infer_pat_exhaustive env' pat in let t2 = check_typ env' typ in @@ -1003,10 +1003,10 @@ and infer_dec env dec : T.typ = check_exp (adjoin_vals env'' ve) t2 exp end; t - | ClassD (id, tid, typbinds, sort, pat, id', fields) -> + | ClassD (id, tid, typ_binds, sort, pat, id', fields) -> let t = T.Env.find id.it env.vals in if not env.pre then begin - let _cs, _ts, te, ce = check_typ_binds env typbinds in + let _cs, _ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let _, ve = infer_pat_exhaustive env' pat in let env'' = @@ -1196,8 +1196,8 @@ and infer_dec_valdecs env dec : val_env = | VarD (id, exp) -> let t = infer_exp {env with pre = true} exp in T.Env.singleton id.it (T.Mut t) - | FuncD (sort, id, typbinds, pat, typ, exp) -> - let cs, ts, te, ce = check_typ_binds env typbinds in + | FuncD (sort, id, typ_binds, pat, typ, exp) -> + let cs, ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let t1, _ = infer_pat {env' with pre = true} pat in let t2 = check_typ env' typ in @@ -1234,8 +1234,8 @@ and infer_dec_valdecs env dec : val_env = (T.Func (T.Call sort.it, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) | TypD _ -> T.Env.empty - | ClassD (conid, id, typbinds, sort, pat, id', fields) -> - let cs, ts, te, ce = check_typ_binds env typbinds in + | ClassD (conid, id, typ_binds, sort, pat, id', fields) -> + let cs, ts, te, ce = check_typ_binds env typ_binds in let env' = adjoin_typs env te ce in let c = T.Env.find id.it env.typs in let t1, _ = infer_pat {env' with pre = true} pat in From efcecd12dfca749bb33ecb4795c37c76d489388a Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 15 Jan 2019 12:51:34 +0000 Subject: [PATCH 16/45] check IR.ActorE and NewObj properly --- src/arrange_ir.ml | 6 +++--- src/check_ir.ml | 46 ++++++++++++++++++++++++++++++++++++---------- src/compile.ml | 4 ++-- src/desugar.ml | 8 +++++--- src/freevars_ir.ml | 4 ++-- src/ir.ml | 19 ++++++++++++------- 6 files changed, 60 insertions(+), 27 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 44d8fb3a6ca..3a2dcedbb99 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -16,7 +16,7 @@ let rec exp e = match e.it with | RelE (t, e1, ro, e2)-> "RelE" $$ [typ t; exp e1; Arrange.relop ro; exp e2] | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] - | ActorE (i, efs) -> "ActorE" $$ [id i] @ List.map exp_field efs + | ActorE (i, efs, t) -> "ActorE" $$ [id i] @ List.map exp_field efs @ [typ t] | DotE (e, n) -> "DotE" $$ [exp e; name n] | ActorDotE (e, n) -> "ActorDotE" $$ [exp e; name n] | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] @@ -41,9 +41,9 @@ let rec exp e = match e.it with | PrimE p -> "PrimE" $$ [Atom p] | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1] | DefineE (i, m, e1) -> "DefineE" $$ [id i; Arrange.mut m; exp e1] - | NewObjE (s, nameids)-> "NewObjE" $$ (Arrange.obj_sort s :: + | NewObjE (s, nameids, t)-> "NewObjE" $$ (Arrange.obj_sort s :: List.fold_left (fun flds (n,i) -> - (name n)::(id i):: flds) [] nameids) + (name n)::(id i):: flds) [typ t] nameids) and pat p = match p.it with | WildP -> Atom "WildP" diff --git a/src/check_ir.ml b/src/check_ir.ml index 254fc06b52c..b0d86aa7ca9 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -82,6 +82,18 @@ let warn env at fmt = Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_warning at s)) fmt +let unfold_obj env t = + match t with + | T.Obj (_,_) -> t + | T.Con (c,ts) -> + begin + match Con.Env.find_opt c env.cons with + | Some T.Abs (tbs, (T.Obj(_,_) as t2)) -> + T.open_ ts t2 + | _ -> error env no_region "bad annotation %s (wrong kind)" (T.string_of_typ t) + end + | _ -> error env no_region "bad annotation %s (wrong form)" (T.string_of_typ t) + let add_lab c x t = {c with labs = T.Env.add x t c.labs} let add_val c x t = {c with vals = T.Env.add x t c.vals} (* @@ -325,9 +337,10 @@ and infer_exp_mut env exp : T.typ = end; *) if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then begin (*TBR*) - error env exp.at "inferred type %s not a subtype of expected type %s" + error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ exp)); + (T.string_of_typ_expand env.cons (E.typ exp)) + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) end end; E.typ exp; @@ -409,9 +422,16 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ_expand env.cons t1) ) - | ActorE ( id, fields) -> + | ActorE ( id, fields, t) -> let env' = { env with async = false } in - infer_obj env' T.Actor id fields + let t1 = infer_obj env' T.Actor id fields in + let t2 = unfold_obj env t in + if T.sub env.cons t1 t2 then + t + else + error env no_region "expecting actor of type %s, but expression produces $s" + (T.string_of_typ_expand env.cons t2) + (T.string_of_typ_expand env.cons t1) | ActorDotE(exp1,{it = Syntax.Name n;_}) | DotE (exp1, {it = Syntax.Name n;_}) -> let t1 = infer_exp_promote env exp1 in @@ -594,12 +614,18 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | None -> error env id.at "unbound variable %s" id.it end; T.unit - | NewObjE (sort, labids) -> - T.Non -(* TOFO: compare with - T.Obj(sort.it, List.sort compare (List.map (fun (name,id) -> - {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) - *) + | NewObjE (sort, labids, t) -> + let t1 = + T.Obj(sort.it, List.sort compare (List.map (fun (name,id) -> + {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in + let t2 = unfold_obj env t in + if T.sub env.cons t1 t2 then + t + else + error env no_region "expecting actor of type %s, but expression produces $s" + (T.string_of_typ_expand env.cons t2) + (T.string_of_typ_expand env.cons t1) + and check_exp env t exp = let t' = T.normalize env.cons t in check_exp' env t' exp; diff --git a/src/compile.ml b/src/compile.ml index 976ce19bccc..3d4b1e7e4fb 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3259,7 +3259,7 @@ and compile_exp (env : E.t) exp = Array.load_n (Int32.of_int n) | ArrayE (m, es) -> StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) - | ActorE (name, fs) -> + | ActorE (name, fs, _) -> StackRep.UnboxedReference, let captured = Freevars_ir.exp exp in let prelude_names = find_prelude_names env in @@ -3350,7 +3350,7 @@ and compile_exp (env : E.t) exp = StackRep.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it - | NewObjE ({ it = Type.Object _ (*sharing*); _}, fs) -> + | NewObjE ({ it = Type.Object _ (*sharing*); _}, fs, _) -> StackRep.Vanilla, let fs' = List.map (fun (name, id) -> (name, fun env -> Var.get_val_ptr env id.it)) diff --git a/src/desugar.ml b/src/desugar.ml index 82cfc57f9a0..72430c13f96 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -77,7 +77,7 @@ let | S.DecE d -> I.BlockE (decs ce [d]) | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp ce e) | S.DefineE (i, m, e) -> I.DefineE (i, m, exp ce e) - | S.NewObjE (s, fs) -> I.NewObjE (s, fs) + | S.NewObjE (s, fs) -> I.NewObjE (s, fs, note.S.note_typ) and field_to_dec ce (f : S.exp_field) : Ir.dec = match f.it.S.mut.it with @@ -103,7 +103,7 @@ let and obj ce at s class_id self_id es obj_typ = match s.it with | Type.Object _ -> build_obj ce at None self_id es obj_typ - | Type.Actor -> I.ActorE (self_id, exp_fields ce es) + | Type.Actor -> I.ActorE (self_id, exp_fields ce es, obj_typ) and build_obj ce at class_id self_id es obj_typ = I.BlockE ( @@ -115,7 +115,9 @@ let }, {it = I.NewObjE (Type.Object Type.Local @@ at, - List.concat (List.map field_to_obj_entry es)); + List.concat (List.map field_to_obj_entry es), + obj_typ + ); at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}} ); diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index 66e0c8e0ea5..6689a5338e1 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -67,7 +67,7 @@ let rec exp e : f = match e.it with | RelE (_, e1, ro, e2)-> exps [e1; e2] | TupE es -> exps es | ProjE (e, i) -> exp e - | ActorE (i, efs) -> close (exp_fields efs) // i.it + | ActorE (i, efs, _) -> close (exp_fields efs) // i.it | DotE (e, i) -> exp e | ActorDotE (e, i) -> exp e | AssignE (e1, e2) -> exps [e1; e2] @@ -91,7 +91,7 @@ let rec exp e : f = match e.it with | OptE e -> exp e | DeclareE (i, t, e) -> exp e // i.it | DefineE (i, m, e) -> id i ++ exp e - | NewObjE (_,ids) -> unions id (List.map (fun (lab,id) -> id) ids) + | NewObjE (_, ids, _) -> unions id (List.map (fun (lab,id) -> id) ids) and exps es : f = unions exp es diff --git a/src/ir.ml b/src/ir.ml index 1d29bee958c..07979a252ca 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -22,26 +22,30 @@ and exp' = | PrimE of string (* primitive *) | VarE of Syntax.id (* variable *) | LitE of Syntax.lit (* literal *) - | UnE of Type.typ * Syntax.unop * exp (* unary operator *) - | BinE of Type.typ * exp * Syntax.binop * exp (* binary operator *) - | RelE of Type.typ * exp * Syntax.relop * exp (* relational operator *) + | UnE of Type.typ * Syntax.unop * exp (* unary operator *) + | BinE of (* binary operator *) + Type.typ * exp * Syntax.binop * exp + | RelE of (* relational operator *) + Type.typ * exp * Syntax.relop * exp | TupE of exp list (* tuple *) | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) - | ActorE of Syntax.id * exp_field list (* actor *) + | ActorE of (* actor *) + Syntax.id * exp_field list * Type.typ | DotE of exp * Syntax.name (* object projection *) | ActorDotE of exp * Syntax.name (* actor field access *) | AssignE of exp * exp (* assignment *) | ArrayE of Syntax.mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) - | CallE of Value. call_conv * exp * Type.typ list * exp (* function call *) + | CallE of (* function call *) + Value. call_conv * exp * Type.typ list * exp | BlockE of dec list (* block *) | IfE of exp * exp * exp (* conditional *) | SwitchE of exp * case list (* switch *) | WhileE of exp * exp (* while-do loop *) | LoopE of exp * exp option (* do-while loop *) | ForE of pat * exp * exp (* iteration *) - | LabelE of Syntax.id * Type.typ * exp (* label *) + | LabelE of Syntax.id * Type.typ * exp (* label *) | BreakE of Syntax.id * exp (* break *) | RetE of exp (* return *) | AsyncE of exp (* async *) @@ -50,7 +54,8 @@ and exp' = | IsE of exp * exp (* instance-of *) | DeclareE of Syntax.id * Type.typ * exp (* local promise (internal) *) | DefineE of Syntax.id * Syntax.mut * exp (* promise fulfillment (internal) *) - | NewObjE of Syntax.obj_sort * (Syntax.name * Syntax.id) list (* make an object, preserving mutable identity (internal) *) + | NewObjE of (* make an object, preserving mutable identity (internal) *) + Syntax.obj_sort * (Syntax.name * Syntax.id) list * Type.typ and exp_field = exp_field' Source.phrase and exp_field' = {name : Syntax.name; id : Syntax.id; exp : exp; mut : Syntax.mut; priv : Syntax.priv} From 190303bd37b4f75a10a65f65e1c8e4faf089f408 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 21 Jan 2019 13:57:01 +0000 Subject: [PATCH 17/45] add element type annotation to Ir.ArrayE and fix broken annotations introduced by tailcail.ml --- src/arrange_ir.ml | 2 +- src/check_ir.ml | 21 +++++++++++---------- src/compile.ml | 2 +- src/desugar.ml | 17 +++++++++++++++-- src/freevars_ir.ml | 2 +- src/ir.ml | 2 +- src/pipeline.ml | 2 +- src/syntaxops.ml | 2 +- src/tailcall.ml | 10 +++++++--- src/type.ml | 22 +++++++++++----------- 10 files changed, 50 insertions(+), 32 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 3a2dcedbb99..b35a65736ea 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -20,7 +20,7 @@ let rec exp e = match e.it with | DotE (e, n) -> "DotE" $$ [exp e; name n] | ActorDotE (e, n) -> "ActorDotE" $$ [exp e; name n] | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] - | ArrayE (m, es) -> "ArrayE" $$ [Arrange.mut m] @ List.map exp es + | ArrayE (m, t, es) -> "ArrayE" $$ [Arrange.mut m; typ t] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] | CallE (cc, e1, ts, e2) -> "CallE" $$ [call_conv cc; exp e1] @ List.map typ ts @ [exp e2] | BlockE ds -> "BlockE" $$ List.map dec ds diff --git a/src/check_ir.ml b/src/check_ir.ml index b0d86aa7ca9..e94c00991bd 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -82,7 +82,7 @@ let warn env at fmt = Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_warning at s)) fmt -let unfold_obj env t = +let unfold_obj env t at = match t with | T.Obj (_,_) -> t | T.Con (c,ts) -> @@ -90,9 +90,9 @@ let unfold_obj env t = match Con.Env.find_opt c env.cons with | Some T.Abs (tbs, (T.Obj(_,_) as t2)) -> T.open_ ts t2 - | _ -> error env no_region "bad annotation %s (wrong kind)" (T.string_of_typ t) + | _ -> error env at "bad annotation %s (wrong kind)" (T.string_of_typ t) end - | _ -> error env no_region "bad annotation %s (wrong form)" (T.string_of_typ t) + | _ -> error env at "bad annotation %s (wrong form)" (T.string_of_typ t) let add_lab c x t = {c with labs = T.Env.add x t c.labs} let add_val c x t = {c with vals = T.Env.add x t c.vals} @@ -425,11 +425,11 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | ActorE ( id, fields, t) -> let env' = { env with async = false } in let t1 = infer_obj env' T.Actor id fields in - let t2 = unfold_obj env t in + let t2 = unfold_obj env t exp.at in if T.sub env.cons t1 t2 then t else - error env no_region "expecting actor of type %s, but expression produces $s" + error env no_region "expecting actor of type %s, but expression produces %s" (T.string_of_typ_expand env.cons t2) (T.string_of_typ_expand env.cons t1) | ActorDotE(exp1,{it = Syntax.Name n;_}) @@ -466,9 +466,9 @@ and infer_exp' env (exp:Ir.exp) : T.typ = error env exp.at "expected mutable assignment target"; end; T.unit - | ArrayE (mut, exps) -> + | ArrayE (mut, t, exps) -> let ts = List.map (infer_exp env) exps in - let t1 = List.fold_left (T.lub env.cons) T.Non ts in + let t1 = List.fold_left (T.lub env.cons) t ts in T.Array (match mut.it with Syntax.Const -> t1 | Syntax.Var -> T.Mut t1) | IdxE (exp1, exp2) -> let t1 = infer_exp_promote env exp1 in @@ -618,11 +618,11 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = T.Obj(sort.it, List.sort compare (List.map (fun (name,id) -> {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in - let t2 = unfold_obj env t in + let t2 = unfold_obj env t exp.at in if T.sub env.cons t1 t2 then t else - error env no_region "expecting actor of type %s, but expression produces $s" + error env no_region "expecting object of type %s, but expression produces %s" (T.string_of_typ_expand env.cons t2) (T.string_of_typ_expand env.cons t1) @@ -689,7 +689,8 @@ and check_exp' env t exp = *) let t' = infer_exp env exp in if not (T.sub env.cons t' t) then - local_error env exp.at "expression of type\n %s\ncannot produce expected type\n %s" + local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons t) diff --git a/src/compile.ml b/src/compile.ml index 3d4b1e7e4fb..5f1d15bfc69 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3257,7 +3257,7 @@ and compile_exp (env : E.t) exp = StackRep.Vanilla, compile_exp_vanilla env e1 ^^ (* offset to tuple (an array) *) Array.load_n (Int32.of_int n) - | ArrayE (m, es) -> + | ArrayE (m, t, es) -> StackRep.Vanilla, Array.lit env (List.map (compile_exp_vanilla env) es) | ActorE (name, fs, _) -> StackRep.UnboxedReference, diff --git a/src/desugar.ml b/src/desugar.ml index 72430c13f96..4bd5c82c382 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -41,7 +41,18 @@ let | S.TupE es -> I.TupE (exps ce es) | S.ProjE (e, i) -> I.ProjE (exp ce e, i) | S.OptE e -> I.OptE (exp ce e) - | S.ObjE (s, i, es) -> obj ce at s None i es note.S.note_typ + | S.ObjE (s, i, es) -> + let public_es = List.filter (fun e -> e.it.S.priv.it == Syntax.Public) es in + let obj_typ = + T.Obj(s.it, + List.sort compare + (List.map (fun {it = {Syntax.name;exp;mut;priv;_};_} -> + let t = exp.note.S.note_typ in + let t = if mut.it = Syntax.Var then Type.Mut t else t in + {Type.name = S.string_of_name name.it; + Type.typ = t}) public_es)) + in + obj ce at s None i es obj_typ | S.DotE (e, n) -> begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) @@ -50,7 +61,9 @@ let | _ -> raise (Invalid_argument ("non-object in dot operator")) end | S.AssignE (e1, e2) -> I.AssignE (exp ce e1, exp ce e2) - | S.ArrayE (m, es) -> I.ArrayE (m, exps ce es) + | S.ArrayE (m, es) -> + let t = Type.as_array note.S.note_typ in + I.ArrayE (m, Type.as_immut t, exps ce es) | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index 6689a5338e1..2de8e22a094 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -71,7 +71,7 @@ let rec exp e : f = match e.it with | DotE (e, i) -> exp e | ActorDotE (e, i) -> exp e | AssignE (e1, e2) -> exps [e1; e2] - | ArrayE (m, es) -> exps es + | ArrayE (m, t, es) -> exps es | IdxE (e1, e2) -> exps [e1; e2] | CallE (_, e1, ts, e2) -> exps [e1; e2] | BlockE ds -> close (decs ds) diff --git a/src/ir.ml b/src/ir.ml index 07979a252ca..cdd9774ed33 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -35,7 +35,7 @@ and exp' = | DotE of exp * Syntax.name (* object projection *) | ActorDotE of exp * Syntax.name (* actor field access *) | AssignE of exp * exp (* assignment *) - | ArrayE of Syntax.mut * exp list (* array *) + | ArrayE of Syntax.mut * Type.typ * exp list (* array *) | IdxE of exp * exp (* array indexing *) | CallE of (* function call *) Value. call_conv * exp * Type.typ list * exp diff --git a/src/pipeline.ml b/src/pipeline.ml index 0904b301ecb..913eca1e83d 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -289,7 +289,7 @@ let compile_with check mode name : compile_result = let prelude = Desugar.prog initial_stat_env.Typing.con_env prelude in let prog = await_lowering true prog name in let prog = async_lowering true prog name in - let prog = tailcall_optimization true prog name in + let prog = tailcall_optimization true prog name in let scope' = Typing.adjoin_scope initial_stat_env scope in let prog = Desugar.prog scope'.Typing.con_env prog in match Check_ir.check_prog initial_stat_env prog with diff --git a/src/syntaxops.ml b/src/syntaxops.ml index d8b87becbfb..dce11abb388 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -216,7 +216,7 @@ let loopE exp1 exp2Opt = (match exp2Opt with | Some exp2 -> eff exp2 | None -> Type.Triv); - note_typ = Type.unit} + note_typ = Type.Non} } diff --git a/src/tailcall.ml b/src/tailcall.ml index 5648541fcc7..5765bffae61 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -218,18 +218,22 @@ and dec' env d = in let env3 = pat env2 p in (* shadow id if necessary *) let exp0' = tailexp env3 exp0 in + let cs = List.map (fun tb -> tb.note) tbs in if !tail_called then let ids = match typ d with - | Func(_,_,_,dom,_) -> List.map fresh_id dom + | Func(_,_,_,dom,_) -> List.map (fun t -> fresh_id (open_ cs t)) dom | _ -> assert false in let args = seqP (List.map varP ids) in + let l_typ = + {it = Syntax.TupT []; at = no_region; note = Type.unit} + in let body = blockE [ varD (id_of_exp temp) (seqE ids); expD (loopE - (labelE l typT + (labelE l l_typ (blockE [letP p temp; - expD (retE exp0' unit)])) None) + expD (retE exp0' Type.unit)])) None) ] in FuncD (s, id, tbs, args, typT, body) else diff --git a/src/type.ml b/src/type.ml index 27d7f9f5b20..483068dd5c2 100644 --- a/src/type.ml +++ b/src/type.ml @@ -57,7 +57,7 @@ let seq ts = let as_seq t = match t with | Tup ts -> ts - | t -> [t] + | t -> [t] (* Short-hands *) @@ -389,7 +389,7 @@ let rec rel_typ env rel eq t1 t2 = t1 == t2 || S.mem (t1, t2) !rel || begin rel := S.add (t1, t2) !rel; match t1, t2 with - | Any, Any -> + | Any, Any -> true | _, Any when rel != eq -> true @@ -453,8 +453,8 @@ let rec rel_typ env rel eq t1 t2 = rel_list rel_typ env rel eq ts1 (List.map (fun _ -> Shared) ts1) | Func (s1, c1, tbs1, t11, t12), Func (s2, c2, tbs2, t21, t22) -> (* TODO: not all classes should be sharable *) - c1 = c2 && - (s1 = s2 || rel != eq && s1 = Construct) && + c1 = c2 && + (s1 = s2 || rel != eq && s1 = Construct) && (match rel_binds env rel eq tbs1 tbs2 with | Some (ts, env') -> rel_list rel_typ env' rel eq (List.map (open_ ts) t21) (List.map (open_ ts) t11) && @@ -599,7 +599,7 @@ let rec string_of_typ_nullary vs = function | Shared -> "Shared" | Class -> "Class" | Prim p -> string_of_prim p - | Var (s, i) -> string_of_var (List.nth vs i) + | Var (s, i) -> (try string_of_var (List.nth vs i) with _ -> assert false) | Con (c, []) -> string_of_con vs c | Con (c, ts) -> sprintf "%s<%s>" (string_of_con vs c) @@ -622,25 +622,25 @@ and string_of_dom vs ts = | [Tup _] -> sprintf "(%s)" dom | _ -> dom - + and string_of_cod c vs ts = let cod = string_of_typ' vs (seq ts) in match ts with | [Tup _] -> sprintf "(%s)" cod - | [Async _] -> + | [Async _] -> (match c with | Returns -> sprintf "(%s)" cod | Promises -> sprintf "%s" cod ) | _ -> cod - + and string_of_typ' vs t = match t with | Func (s, c, [], ts1, ts2) -> sprintf "%s%s -> %s" (string_of_func_sort s) - (string_of_dom vs ts1) - (string_of_cod c vs ts2) + (string_of_dom vs ts1) + (string_of_cod c vs ts2) | Func (s, c, tbs, ts1, ts2) -> let vs' = names_of_binds vs tbs in sprintf "%s%s%s -> %s" @@ -712,4 +712,4 @@ let rec string_of_typ_expand env t = (* Environments *) -module Env = Env.Make(String) +module Env = Env.Make(String) From 137a4b628177329b758b504f37a54036e3229475 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 21 Jan 2019 17:06:41 +0000 Subject: [PATCH 18/45] annoted blocks with type after avoidance to enable checking of ir --- src/arrange.ml | 4 ++-- src/arrange_ir.ml | 2 +- src/async.ml | 8 ++++---- src/awaitopt.ml | 12 ++++++------ src/check_ir.ml | 19 +++++++++++-------- src/compile.ml | 4 ++-- src/desugar.ml | 7 ++++--- src/effect.ml | 4 ++-- src/freevars.ml | 4 ++-- src/freevars_ir.ml | 4 ++-- src/interpret.ml | 4 ++-- src/ir.ml | 2 +- src/parser.mly | 14 +++++++------- src/rename.ml | 6 +++--- src/syntax.ml | 8 ++++---- src/syntaxops.ml | 4 ++-- src/tailcall.ml | 6 +++--- src/typing.ml | 34 ++++++++++++++++++++-------------- 18 files changed, 78 insertions(+), 68 deletions(-) diff --git a/src/arrange.ml b/src/arrange.ml index 28df9b0197f..faf22a5360e 100644 --- a/src/arrange.ml +++ b/src/arrange.ml @@ -18,7 +18,7 @@ let rec exp e = match e.it with | ArrayE (m, es) -> "ArrayE" $$ [mut m] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] | CallE (e1, ts, e2) -> "CallE" $$ [exp e1] @ List.map typ ts @ [exp e2] - | BlockE ds -> "BlockE" $$ List.map dec ds + | BlockE (ds, ot) -> "BlockE" $$ List.map dec ds @ [operator_type (!ot)] | NotE e -> "NotE" $$ [exp e] | AndE (e1, e2) -> "AndE" $$ [exp e1; exp e2] | OrE (e1, e2) -> "OrE" $$ [exp e1; exp e2] @@ -36,7 +36,7 @@ let rec exp e = match e.it with | AssertE e -> "AssertE" $$ [exp e] | IsE (e1, e2) -> "IsE" $$ [exp e1; exp e2] | AnnotE (e, t) -> "AnnotE" $$ [exp e; typ t] - | DecE d -> "DecE" $$ [dec d] + | DecE (d, ot) -> "DecE" $$ [dec d ; operator_type !ot] | OptE e -> "OptE" $$ [exp e] | PrimE p -> "PrimE" $$ [Atom p] | DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1] diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index b35a65736ea..e298878e5d0 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -23,7 +23,7 @@ let rec exp e = match e.it with | ArrayE (m, t, es) -> "ArrayE" $$ [Arrange.mut m; typ t] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] | CallE (cc, e1, ts, e2) -> "CallE" $$ [call_conv cc; exp e1] @ List.map typ ts @ [exp e2] - | BlockE ds -> "BlockE" $$ List.map dec ds + | BlockE (ds, t) -> "BlockE" $$ List.map dec ds @ [typ t] | IfE (e1, e2, e3) -> "IfE" $$ [exp e1; exp e2; exp e3] | SwitchE (e, cs) -> "SwitchE" $$ [exp e] @ List.map case cs | WhileE (e1, e2) -> "WhileE" $$ [exp e1; exp e2] diff --git a/src/async.ml b/src/async.ml index 36db08d9ccd..4c268e902e9 100644 --- a/src/async.ml +++ b/src/async.ml @@ -294,8 +294,8 @@ and t_exp' (exp:Syntax.exp) = .it | CallE (exp1, typs, exp2) -> CallE(t_exp exp1, List.map t_typT typs, t_exp exp2) - | BlockE decs -> - BlockE (t_decs decs) + | BlockE (decs, ot) -> + BlockE (t_decs decs, ref (t_typ (!ot))) | NotE exp1 -> NotE (t_exp exp1) | AndE (exp1, exp2) -> @@ -331,8 +331,8 @@ and t_exp' (exp:Syntax.exp) = IsE (t_exp exp1, t_exp exp2) | AnnotE (exp1, typ) -> AnnotE (t_exp exp1, t_typT typ) - | DecE dec -> - DecE (t_dec dec) + | DecE (dec, ot) -> + DecE (t_dec dec, ref (t_typ (!ot))) | DeclareE (id, typ, exp1) -> DeclareE (id, t_typ typ, t_exp exp1) | DefineE (id, mut ,exp1) -> diff --git a/src/awaitopt.ml b/src/awaitopt.ml index 86bef5367f3..f1cd3715579 100644 --- a/src/awaitopt.ml +++ b/src/awaitopt.ml @@ -92,8 +92,8 @@ and t_exp' context exp' = IdxE (t_exp context exp1, t_exp context exp2) | CallE (exp1, typs, exp2) -> CallE (t_exp context exp1, typs, t_exp context exp2) - | BlockE decs -> - BlockE (t_decs context decs) + | BlockE (decs, ot) -> + BlockE (t_decs context decs, ref (!ot)) | NotE exp1 -> NotE (t_exp context exp1) | AndE (exp1, exp2) -> @@ -146,8 +146,8 @@ and t_exp' context exp' = IsE (t_exp context exp1, t_exp context exp2) | AnnotE (exp1, typ) -> AnnotE (t_exp context exp1,typ) - | DecE dec -> - DecE (t_dec context dec) + | DecE (dec,ot) -> + DecE (t_dec context dec, ref (!ot)) | DeclareE (id, typ, exp1) -> DeclareE (id, typ, t_exp context exp1) | DefineE (id, mut ,exp1) -> @@ -417,7 +417,7 @@ and c_exp' context exp k = binary context k (fun v1 v2 -> e (IdxE (v1, v2))) exp1 exp2 | CallE (exp1, typs, exp2) -> binary context k (fun v1 v2 -> e (CallE (v1, typs, v2))) exp1 exp2 - | BlockE decs -> + | BlockE (decs,t) -> c_block context decs k | NotE exp1 -> unary context k (fun v1 -> e (NotE v1)) exp1 @@ -498,7 +498,7 @@ and c_exp' context exp k = | AnnotE (exp1, typ) -> (* TBR just erase the annotation instead? *) unary context k (fun v1 -> e (AnnotE (v1,typ))) exp1 - | DecE dec -> + | DecE (dec, _) -> c_dec context dec k | DeclareE (id, typ, exp1) -> unary context k (fun v1 -> e (DeclareE (id, typ, v1))) exp1 diff --git a/src/check_ir.ml b/src/check_ir.ml index e94c00991bd..e9622a20fd8 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -492,13 +492,16 @@ and infer_exp' env (exp:Ir.exp) : T.typ = error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) ) - | BlockE decs -> - let t, scope = infer_block env decs exp.at in - (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> - error env exp.at "local class type %s is contained in inferred block type\n %s" - (Con.to_string c) - (T.string_of_typ_expand (Con.Env.adjoin env.cons scope.con_env) t) - ) + | BlockE (decs, t) -> + let t1, scope = infer_block env decs exp.at in + (* let _t2 = try T.avoid env.cons scope.con_env t1 with T.Unavoidable c -> assert false in *) + let env' = adjoin env scope in + check_typ env t; + if not (T.eq env.cons t T.unit || T.eq env'.cons t1 t) then + error env exp.at "expected block type\n %s, found declaration with inequivalent type\n %s" + (T.string_of_typ t) + (T.string_of_typ t1); + t | IfE (exp1, exp2, exp3) -> if not env.pre then check_exp env T.bool exp1; let t2 = infer_exp env exp2 in @@ -909,7 +912,7 @@ and infer_exp_fields env s id t fields : T.field list * val_env = and is_func_exp exp = match exp.it with (* | DecE dec -> is_func_dec dec *) - | BlockE [dec] -> is_func_dec dec + | BlockE ([dec],_)-> is_func_dec dec | _ -> Printf.printf "[1]%!"; false and is_func_dec dec = diff --git a/src/compile.ml b/src/compile.ml index 5f1d15bfc69..035f860a625 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -3202,7 +3202,7 @@ and compile_exp (env : E.t) exp = G.i (Compare (Wasm.Values.I32 I32Op.Eq)) ) ] - | BlockE decs -> + | BlockE (decs,_) -> compile_decs env decs | LabelE (name, _ty, e) -> (* The value here can come from many places -- the expression, @@ -3654,7 +3654,7 @@ and compile_private_actor_field pre_env (f : Ir.exp_field) = and compile_public_actor_field pre_env (f : Ir.exp_field) = let (cc, name, _, pat, _rt, exp) = let find_func exp = match exp.it with - | BlockE [{it = FuncD (cc, name, ty_args, pat, rt, exp); _ }] -> + | BlockE ([{it = FuncD (cc, name, ty_args, pat, rt, exp); _ }],_) -> (cc, name, ty_args, pat, rt, exp) | _ -> assert false (* "public actor field not a function" *) in find_func f.it.exp in diff --git a/src/desugar.ml b/src/desugar.ml index 4bd5c82c382..ac5690ee9c2 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -69,7 +69,7 @@ let let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in let inst = List.map (fun t -> t.Source.note) inst in I.CallE (cc, exp ce e1, inst, exp ce e2) - | S.BlockE ds -> I.BlockE (decs ce ds) + | S.BlockE (ds, ot) -> I.BlockE (decs ce ds, !ot) | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) | S.AndE (e1, e2) -> I.IfE (exp ce e1, exp ce e2, false_lit) | S.OrE (e1, e2) -> I.IfE (exp ce e1, true_lit, exp ce e2) @@ -87,7 +87,7 @@ let | S.AssertE e -> I.AssertE (exp ce e) | S.IsE (e1, e2) -> I.IsE (exp ce e1, exp ce e2) | S.AnnotE (e, _) -> exp' ce at note e.it - | S.DecE d -> I.BlockE (decs ce [d]) + | S.DecE (d, ot) -> I.BlockE (decs ce [d], !ot) | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp ce e) | S.DefineE (i, m, e) -> I.DefineE (i, m, exp ce e) | S.NewObjE (s, fs) -> I.NewObjE (s, fs, note.S.note_typ) @@ -144,7 +144,8 @@ let at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}; - ]) + ], + obj_typ) and exp_fields ce fs = List.map (exp_field ce) fs and exp_field ce f = phrase ce exp_field' f diff --git a/src/effect.ml b/src/effect.ml index d8a8c1fcdad..84b3be3699e 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -53,7 +53,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | ArrayE (_, exps) -> let es = List.map effect_exp exps in List.fold_left max_eff Type.Triv es - | BlockE decs -> + | BlockE (decs,_) -> let es = List.map effect_dec decs in List.fold_left max_eff Type.Triv es | ObjE (_, _, efs) -> @@ -71,7 +71,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = T.Triv | AwaitE exp1 -> T.Await - | DecE d -> + | DecE (d, _) -> effect_dec d | DeclareE (_, _, exp1) -> effect_exp exp1 diff --git a/src/freevars.ml b/src/freevars.ml index b8a19adb741..201dfbd29b5 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -47,7 +47,7 @@ let rec exp e : f = match e.it with | ArrayE (m, es) -> exps es | IdxE (e1, e2) -> exps [e1; e2] | CallE (e1, ts, e2) -> exps [e1; e2] - | BlockE ds -> close (decs ds) + | BlockE (ds, _) -> close (decs ds) | NotE e -> exp e | AndE (e1, e2) -> exps [e1; e2] | OrE (e1, e2) -> exps [e1; e2] @@ -65,7 +65,7 @@ let rec exp e : f = match e.it with | AssertE e -> exp e | IsE (e, t) -> exp e | AnnotE (e, t) -> exp e - | DecE d -> close (dec d) + | DecE (d, _ot) -> close (dec d) | OptE e -> exp e | DeclareE (i, t, e) -> exp e // i.it | DefineE (i, m, e) -> (id i) ++ exp e diff --git a/src/freevars_ir.ml b/src/freevars_ir.ml index 2de8e22a094..d11a9e6b6df 100644 --- a/src/freevars_ir.ml +++ b/src/freevars_ir.ml @@ -71,10 +71,10 @@ let rec exp e : f = match e.it with | DotE (e, i) -> exp e | ActorDotE (e, i) -> exp e | AssignE (e1, e2) -> exps [e1; e2] - | ArrayE (m, t, es) -> exps es + | ArrayE (m, t, es) -> exps es | IdxE (e1, e2) -> exps [e1; e2] | CallE (_, e1, ts, e2) -> exps [e1; e2] - | BlockE ds -> close (decs ds) + | BlockE (ds, _) -> close (decs ds) | IfE (e1, e2, e3) -> exps [e1; e2; e3] | SwitchE (e, cs) -> exp e ++ cases cs | WhileE (e1, e2) -> exps [e1; e2] diff --git a/src/interpret.ml b/src/interpret.ml index f8e3df70a79..2fd5c915cec 100644 --- a/src/interpret.ml +++ b/src/interpret.ml @@ -330,7 +330,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = *) ) ) - | BlockE decs -> + | BlockE (decs, _)-> interpret_block env decs None k | NotE exp1 -> interpret_exp env exp1 (fun v1 -> k (V.Bool (not (V.as_bool v1)))) @@ -431,7 +431,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = ) | AnnotE (exp1, _typ) -> interpret_exp env exp1 k - | DecE dec -> + | DecE (dec, _) -> interpret_block env [dec] None k | DeclareE (id, typ, exp1) -> let env = adjoin_vals env (declare_id id) in diff --git a/src/ir.ml b/src/ir.ml index cdd9774ed33..2b30b4481d4 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -39,7 +39,7 @@ and exp' = | IdxE of exp * exp (* array indexing *) | CallE of (* function call *) Value. call_conv * exp * Type.typ list * exp - | BlockE of dec list (* block *) + | BlockE of dec list * Type.typ (* block *) | IfE of exp * exp * exp (* conditional *) | SwitchE of exp * case list (* switch *) | WhileE of exp * exp (* while-do loop *) diff --git a/src/parser.mly b/src/parser.mly index 938359b40fe..b2255c963b7 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -50,7 +50,7 @@ let assign_op lhs rhs_f at = let e = AssignE (lhs', rhs_f rhs') @? at in match ds with | [] -> e - | ds -> BlockE (ds @ [ExpD e @? e.at]) @? at + | ds -> BlockE (ds @ [ExpD e @? e.at], ref Type.Pre) @? at let share_typ t = match t.it with @@ -73,8 +73,8 @@ let share_exp e = match e.it with | ObjE ({it = Type.Object Type.Local; _} as s, x, efs) -> ObjE ({s with it = Type.Object Type.Sharable}, x, efs) @? e.at - | DecE d -> - DecE (share_dec d) @? e.at + | DecE (d, ot) -> + DecE (share_dec d, ot) @? e.at | _ -> e let share_expfield (ef : exp_field) = @@ -326,7 +326,7 @@ lit : exp_block : | LCURLY ds=seplist(dec, semicolon) RCURLY - { BlockE(ds) @? at $sloc } + { BlockE(ds, ref Type.Pre) @? at $sloc } exp_nullary : | e=exp_block @@ -440,7 +440,7 @@ exp_nonvar : | e=exp_nondec { e } | d=dec_nonvar - { DecE(d) @? at $sloc } + { DecE(d, ref Type.Pre) @? at $sloc } (* TODO(andreas): hack, remove *) | s=obj_sort xf=id_opt EQ? efs=obj_body { let anon = if s.it = Type.Actor then "actor" else "object" in @@ -454,7 +454,7 @@ exp : | e=exp_nonvar { e } | d=dec_var - { DecE(d) @? at $sloc } + { DecE(d, ref Type.Pre) @? at $sloc } case : @@ -473,7 +473,7 @@ exp_field : {name = {x with it = Name x.it}; id = x; mut = m; priv = p; exp = e} @@ at $sloc } | priv=private_opt s=shared_opt x=id fd=func_dec { let d = fd s x in - let e = DecE(d) @? d.at in + let e = DecE(d, ref Type.Pre) @? d.at in {name = {x with it = Name x.it}; id = x; mut = Const @@ no_region; priv; exp = e} @@ at $sloc } (* Patterns *) diff --git a/src/rename.ml b/src/rename.ml index 4127dda9182..564218da645 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -39,7 +39,7 @@ and exp' rho e = match e with | ArrayE (m, es) -> ArrayE (m, exps rho es) | IdxE (e1, e2) -> IdxE (exp rho e1, exp rho e2) | CallE (e1, ts, e2) -> CallE (exp rho e1, ts, exp rho e2) - | BlockE ds -> BlockE (decs rho ds) + | BlockE (ds, ot) -> BlockE (decs rho ds, ot) | NotE e -> NotE (exp rho e) | AndE (e1, e2) -> AndE (exp rho e1, exp rho e2) | OrE (e1, e2) -> OrE (exp rho e1, exp rho e2) @@ -59,8 +59,8 @@ and exp' rho e = match e with | AssertE e -> AssertE (exp rho e) | IsE (e, t) -> IsE (exp rho e, t) | AnnotE (e, t) -> AnnotE (exp rho e, t) - | DecE d -> let mk_d, rho' = dec rho d in - DecE ({mk_d with it = mk_d.it rho'}) + | DecE (d,ot) -> let mk_d, rho' = dec rho d in + DecE ({mk_d with it = mk_d.it rho'}, ref (!ot)) | OptE e -> OptE (exp rho e) | DeclareE (i, t, e) -> let i',rho' = id_bind rho i in DeclareE (i', t, exp rho' e) diff --git a/src/syntax.ml b/src/syntax.ml index dfbf732c092..a59e8a1034c 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -123,7 +123,7 @@ and pat_field' = {id : id; pat : pat} type priv = priv' Source.phrase and priv' = Public | Private -(* Filled in for overloaded operators during type checking. Initially Type.Pre. *) +(* Filled in for overloaded operators and blocks during type checking. Initially Type.Pre. *) type op_type = Type.typ ref type exp = (exp', typ_note) Source.annotated_phrase @@ -142,8 +142,8 @@ and exp' = | AssignE of exp * exp (* assignment *) | ArrayE of mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) - | CallE of exp * typ list * exp (* function call *) - | BlockE of dec list (* block *) + | CallE of exp * typ list * exp (* function call *) + | BlockE of dec list * op_type (* block (with type after avoidance)*) | NotE of exp (* negation *) | AndE of exp * exp (* conjunction *) | OrE of exp * exp (* disjunction *) @@ -160,7 +160,7 @@ and exp' = | AssertE of exp (* assertion *) | IsE of exp * exp (* instance-of *) | AnnotE of exp * typ (* type annotation *) - | DecE of dec (* declaration *) + | DecE of dec * Type.typ ref (* declaration *) | DeclareE of id * Type.typ * exp (* local promise (internal) *) | DefineE of id * mut * exp (* promise fulfillment (internal) *) | NewObjE of obj_sort * (name * id) list (* make an object, preserving mutable identity (internal) *) diff --git a/src/syntaxops.ml b/src/syntaxops.ml index dce11abb388..0b05564a0c4 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -93,7 +93,7 @@ let projE e n = } | _ -> failwith "projE" -let decE exp = {exp with it = DecE exp} +let decE dec = {dec with it = DecE (dec,ref dec.note.note_typ)} let rec typ_decs decs = match decs with @@ -105,7 +105,7 @@ let blockE decs = let es = List.map eff decs in let typ = typ_decs decs in let e = List.fold_left max_eff Type.Triv es in - { it = BlockE decs; + { it = BlockE (decs, ref typ); at = no_region; note = {note_typ = typ; note_eff = e} diff --git a/src/tailcall.ml b/src/tailcall.ml index 5765bffae61..051d389076b 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -100,7 +100,7 @@ and exp' env e = match e.it with expD (breakE label (tupE []) (typ e))]).it | _,_-> CallE(exp env e1, insts, exp env e2) end - | BlockE ds -> BlockE (decs env ds) + | BlockE (ds,ot) -> BlockE (decs env ds, ref (!ot)) | NotE e -> NotE (exp env e) | AndE (e1, e2) -> AndE (exp env e1, tailexp env e2) | OrE (e1, e2) -> OrE (exp env e1, tailexp env e2) @@ -121,8 +121,8 @@ and exp' env e = match e.it with | AssertE e -> AssertE (exp env e) | IsE (e, t) -> IsE (exp env e, t) | AnnotE (e, t) -> AnnotE (exp env e, t) - | DecE d -> let mk_d, env1 = dec env d in - DecE ({mk_d with it = mk_d.it env1}) + | DecE (d, ot) -> let mk_d, env1 = dec env d in + DecE ({mk_d with it = mk_d.it env1},ref (!ot)) | OptE e -> OptE (exp env e) | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) diff --git a/src/typing.ml b/src/typing.ml index f48ec73f2a3..198a18a4012 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -471,13 +471,15 @@ and infer_exp' env exp : T.typ = error env exp1.at "expected function type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) ) - | BlockE decs -> + | BlockE (decs,ot) -> let t, scope = infer_block env decs exp.at in - (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> - error env exp.at "local class type %s is contained in inferred block type\n %s" - (Con.to_string c) - (T.string_of_typ_expand (Con.Env.adjoin env.cons scope.con_env) t) - ) + let t' = try T.avoid env.cons scope.con_env t with T.Unavoidable c -> + error env exp.at "local class type %s is contained in inferred block type\n %s" + (Con.to_string c) + (T.string_of_typ_expand (Con.Env.adjoin env.cons scope.con_env) t) + in + ot := t'; + t' | NotE exp1 -> if not env.pre then check_exp env T.bool exp1; T.bool @@ -602,12 +604,15 @@ and infer_exp' env exp : T.typ = let t = check_typ env typ in if not env.pre then check_exp env t exp1; t - | DecE dec -> + | DecE (dec,ot) -> let t, scope = infer_block env [dec] exp.at in - (try T.avoid env.cons scope.con_env t with T.Unavoidable c -> - error env exp.at "local class name %s is contained in inferred declaration type\n %s" - (Con.to_string c) (T.string_of_typ_expand env.cons t) - ) + let t' = + try T.avoid env.cons scope.con_env t with T.Unavoidable c -> + error env exp.at "local class name %s is contained in inferred declaration type\n %s" + (Con.to_string c) (T.string_of_typ_expand env.cons t) + in + ot := t'; + t' (* DeclareE and DefineE should not occur in source code *) | DeclareE (id, typ, exp1) -> let env' = adjoin_vals env (T.Env.singleton id.it typ) in @@ -670,8 +675,9 @@ and check_exp' env t exp = | AsyncE exp1, T.Async t' -> let env' = {env with labs = T.Env.empty; rets = Some t'; async = true} in check_exp env' t' exp1 - | BlockE decs, _ -> - ignore (check_block env t decs exp.at) + | BlockE (decs, ot),_ -> + ignore (check_block env t decs exp.at); + ot := t | IfE (exp1, exp2, exp3), _ -> check_exp env T.bool exp1; check_exp env t exp2; @@ -925,7 +931,7 @@ and infer_exp_fields env s id t fields : T.field list * val_env = and is_func_exp exp = match exp.it with - | DecE dec -> is_func_dec dec + | DecE (dec, _) -> is_func_dec dec | AnnotE (exp, _) -> is_func_exp exp | _ -> Printf.printf "[1]%!"; false From 62fd1c84963f3a2362b22883af962dd5779e432d Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Mon, 21 Jan 2019 17:09:26 +0000 Subject: [PATCH 19/45] updated tests to reflect new type annotations --- .../ok/counter-class.wasm.stderr.ok | 9 +++++- test/run/ok/account.wasm.stderr.ok | 20 ++++++++++++ test/run/ok/bank-example.wasm.stderr.ok | 31 +++++++++++++++++++ 3 files changed, 59 insertions(+), 1 deletion(-) diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 0ec08be44e2..04999878853 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -12,8 +12,10 @@ non-closed actor: (ActorE (BlockE (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) + () ) ) + shared () -> () ) Const Public @@ -37,8 +39,9 @@ non-closed actor: (ActorE $lambda (VarP $0) () - (CallE ( 1 -> 0) (VarE $0) (BlockE (ExpD (VarE c)))) + (CallE ( 1 -> 0) (VarE $0) (BlockE (ExpD (VarE c)) Int)) ) + (Int -> ()) -> () ) (BlockE (FuncD @@ -48,13 +51,17 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) ) + Int -> () ) ) ) + () ) ) + shared (shared Int -> ()) -> () ) Const Public ) + Counter ) diff --git a/test/run/ok/account.wasm.stderr.ok b/test/run/ok/account.wasm.stderr.ok index 80de697a794..a89c7973bc2 100644 --- a/test/run/ok/account.wasm.stderr.ok +++ b/test/run/ok/account.wasm.stderr.ok @@ -25,9 +25,11 @@ non-closed actor: (ActorE (VarE $0) (BlockE (ExpD (RetE (CallE ( 1 -> 0) (VarE $0) (VarE balance)))) + Int ) ) ) + (Int -> ()) -> () ) (BlockE (FuncD @@ -37,11 +39,14 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $8) (VarE $9)) ) + Int -> () ) ) ) + () ) ) + shared (shared Int -> ()) -> () ) Const Public @@ -83,9 +88,11 @@ non-closed actor: (ActorE ) ) ) + Account ) ) ) + (Account -> ()) -> () ) (BlockE (FuncD @@ -95,11 +102,14 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $10) (VarE $11)) ) + Account -> () ) ) ) + () ) ) + shared (Int, shared Account -> ()) -> () ) Const Public @@ -123,8 +133,10 @@ non-closed actor: (ActorE (TupE (VarE amount) (VarE Account)) ) ) + () ) ) + shared (like Account) -> () ) Const Public @@ -145,8 +157,10 @@ non-closed actor: (ActorE (BinE Int (VarE balance) AddOp (VarE amount)) ) ) + () ) ) + shared (Int, Class) -> () ) Const Public @@ -182,9 +196,11 @@ non-closed actor: (ActorE ) ) ) + Bool ) ) ) + (Bool -> ()) -> () ) (BlockE (FuncD @@ -194,13 +210,17 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $12) (VarE $13)) ) + Bool -> () ) ) ) + () ) ) + shared (like Account, shared Bool -> ()) -> () ) Const Public ) + Account ) diff --git a/test/run/ok/bank-example.wasm.stderr.ok b/test/run/ok/bank-example.wasm.stderr.ok index b561c7dbe90..9279fc5c297 100644 --- a/test/run/ok/bank-example.wasm.stderr.ok +++ b/test/run/ok/bank-example.wasm.stderr.ok @@ -31,9 +31,11 @@ non-closed actor: (ActorE (VarE $0) (BlockE (ExpD (RetE (CallE ( 1 -> 0) (VarE $0) (VarE issuer)))) + Issuer ) ) ) + (Issuer -> ()) -> () ) (BlockE (FuncD @@ -43,11 +45,14 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $32) (VarE $33)) ) + Issuer -> () ) ) ) + () ) ) + shared (shared Issuer -> ()) -> () ) Const Public @@ -76,9 +81,11 @@ non-closed actor: (ActorE (VarE $1) (BlockE (ExpD (RetE (CallE ( 1 -> 0) (VarE $1) (VarE reserve)))) + Account ) ) ) + (Account -> ()) -> () ) (BlockE (FuncD @@ -88,15 +95,19 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $34) (VarE $35)) ) + Account -> () ) ) ) + () ) ) + shared (shared Account -> ()) -> () ) Const Public ) + Bank ) non-closed actor: (ActorE self @@ -125,9 +136,11 @@ non-closed actor: (ActorE (VarE $3) (BlockE (ExpD (RetE (CallE ( 1 -> 0) (VarE $3) (VarE balance)))) + Int ) ) ) + (Int -> ()) -> () ) (BlockE (FuncD @@ -137,11 +150,14 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $38) (VarE $39)) ) + Int -> () ) ) ) + () ) ) + shared (shared Int -> ()) -> () ) Const Public @@ -183,9 +199,11 @@ non-closed actor: (ActorE ) ) ) + Account ) ) ) + (Account -> ()) -> () ) (BlockE (FuncD @@ -195,11 +213,14 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $40) (VarE $41)) ) + Account -> () ) ) ) + () ) ) + shared (Int, shared Account -> ()) -> () ) Const Public @@ -223,8 +244,10 @@ non-closed actor: (ActorE (TupE (VarE amount) (VarE Account)) ) ) + () ) ) + shared (like Account) -> () ) Const Public @@ -245,8 +268,10 @@ non-closed actor: (ActorE (BinE Int (VarE balance) AddOp (VarE amount)) ) ) + () ) ) + shared (Int, Class) -> () ) Const Public @@ -282,9 +307,11 @@ non-closed actor: (ActorE ) ) ) + Bool ) ) ) + (Bool -> ()) -> () ) (BlockE (FuncD @@ -294,13 +321,17 @@ non-closed actor: (ActorE () (CallE (shared 1 -> 0) (VarE $42) (VarE $43)) ) + Bool -> () ) ) ) + () ) ) + shared (like Account, shared Bool -> ()) -> () ) Const Public ) + Account ) From 79535db5bd4a1337da1abc4ee7a5fb35502b38bd Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 22 Jan 2019 10:36:45 +0000 Subject: [PATCH 20/45] remove typ_env from IR scope; replace note_typ assigment with type equivalence check; cleanup code --- src/arrange_type.ml | 2 +- src/check_ir.ml | 178 ++++++-------------------------------------- 2 files changed, 23 insertions(+), 157 deletions(-) diff --git a/src/arrange_type.ml b/src/arrange_type.ml index 86622214469..312eec3be4c 100644 --- a/src/arrange_type.ml +++ b/src/arrange_type.ml @@ -1,5 +1,5 @@ open Source -open Type +open Type open Wasm.Sexpr let ($$) head inner = Node (head, inner) diff --git a/src/check_ir.ml b/src/check_ir.ml index e9622a20fd8..b160683c1c2 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -21,24 +21,20 @@ let recover f y = recover_with () f y (* Scope (the external interface) *) type val_env = T.typ T.Env.t -type typ_env = T.con T.Env.t type con_env = T.con_env -type scope = Typing.scope = +type scope = { val_env : val_env; - typ_env : typ_env; (* TODO: delete me *) con_env : con_env; } let empty_scope : scope = { val_env = T.Env.empty; - typ_env = T.Env.empty; con_env = Con.Env.empty } let adjoin_scope scope1 scope2 = { val_env = T.Env.adjoin scope1.val_env scope2.val_env; - typ_env = T.Env.adjoin scope1.typ_env scope2.typ_env; (* TODO: delete me *) con_env = Con.Env.adjoin scope1.con_env scope2.con_env; } @@ -49,7 +45,6 @@ type ret_env = T.typ option type env = { vals : val_env; - typs : typ_env; (* TODO: remove me *) cons : con_env; labs : lab_env; rets : ret_env; @@ -59,9 +54,8 @@ type env = } let env_of_scope msgs scope = - { vals = scope.val_env; - typs = scope.typ_env; - cons = scope.con_env; + { vals = scope.Typing.val_env; + cons = scope.Typing.con_env; labs = T.Env.empty; rets = None; async = false; @@ -96,25 +90,15 @@ let unfold_obj env t at = let add_lab c x t = {c with labs = T.Env.add x t c.labs} let add_val c x t = {c with vals = T.Env.add x t c.vals} -(* -let add_con c con k = {c with cons = Con.Env.add con k c.cons} -let add_typ c x con k = - { c with - typs = T.Env.add x con c.typs; - cons = Con.Env.add con k c.cons; - } -*) let add_typs c cs ks = { c with - (* typs = List.fold_right2 T.Env.add xs cs c.typs; *) cons = List.fold_right2 Con.Env.add cs ks c.cons; } let adjoin c scope = { c with vals = T.Env.adjoin c.vals scope.val_env; - (* typs = T.Env.adjoin c.typs scope.typ_env; *) cons = Con.Env.adjoin c.cons scope.con_env; } @@ -122,7 +106,6 @@ let adjoin_vals c ve = {c with vals = T.Env.adjoin c.vals ve} let adjoin_cons c ce = {c with cons = Con.Env.adjoin c.cons ce} let adjoin_typs c ce = { c with - (* typs = T.Env.adjoin c.typs te; *) cons = Con.Env.adjoin c.cons ce; } @@ -215,7 +198,7 @@ let rec check_typ env typ : unit = (* T.Obj (sort.it, List.sort compare fs) *) (* IS THAT EVEN CORRECT? *) | T.Mut typ -> check_typ env typ - + and check_typ_field env s typ_field : unit = let {T.name; T.typ} = typ_field in check_typ env typ; @@ -226,26 +209,6 @@ and check_typ_field env s typ_field : unit = error env no_region "shared object or actor field %s has non-shared type\n %s" name (T.string_of_typ_expand env.cons typ) -(* -and check_typ_binds env typ_binds : T.con list * con_env = - let xs = List.map (fun typ_bind -> typ_bind.T.var) typ_binds in - let cs = List.map (fun x -> Con.fresh x) xs in - let _ (* te *) = List.fold_left2 (fun te typ_bind c -> - let id = typ_bind.T.var in - if T.Env.mem id te then - error env no_region "duplicate type name %s in type parameter list" id; - T.Env.add id c te - ) T.Env.empty typ_binds cs in - let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in - let pre_env' = add_typs {env with pre = true} xs cs pre_ks in - let ts = List.map (fun typ_bind -> let t = typ_bind.T.bound in - check_typ pre_env' t; - t) typ_binds in - let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in - let env' = add_typs env xs cs ks in - let _ = List.map (fun typ_bind -> check_typ env' typ_bind.T.bound) typ_binds in - cs, Con.Env.from_list2 cs ks - *) and check_typ_binds env typ_binds : T.con list * con_env = let ts,ce = Type.open_binds env.cons typ_binds in let cs = List.map (function T.Con(c,[]) -> c | _ -> assert false) ts in @@ -258,8 +221,7 @@ and check_typ_binds env typ_binds : T.con list * con_env = let env' = add_typs env cs ks in let _ = List.map (fun bd -> check_typ env' bd) bds in cs, Con.Env.from_list2 cs ks - - + and check_typ_bounds env (tbs : T.bind list) typs at : unit = match tbs, typs with | tb::tbs', typ::typs' -> @@ -270,7 +232,7 @@ and check_typ_bounds env (tbs : T.bind list) typs at : unit = (T.string_of_typ_expand env.cons typ) (T.string_of_typ_expand env.cons tb.T.bound) end; - check_typ_bounds env tbs' typs' at + check_typ_bounds env tbs' typs' at | [], [] -> () | [], _ -> local_error env at "too many type arguments" | _, [] -> error env at "too few type arguments" @@ -634,62 +596,6 @@ and check_exp env t exp = check_exp' env t' exp; and check_exp' env t exp = -(* - match exp.it, t with - | PrimE s, T.Func _ -> - () - | LitE lit, _ -> - check_lit env t lit exp.at - | UnE (ot, op, exp1), t' -> - if not (Operator.has_unop ot op) then - error env exp.at "no such unary operator for type"; - (T.string_of_typ_expand env.cons t'); - if not (Type.eq env.cons ot t') then - error env exp.at "bad unary operator annotation, expecting %s found %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons (E.typ exp)); - check_exp env t' exp1 - | BinE (ot, exp1, op, exp2), t' -> - if not (Operator.has_binop ot op) then - error env exp.at "no such binary operator for type"; - (T.string_of_typ_expand env.cons t'); - if not (Type.eq env.cons ot t') then - error env exp.at "bad binary operator annotation, expecting %s found %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons (E.typ exp)); - check_exp env t' exp1; - check_exp env t' exp2 - | TupE exps, T.Tup ts when List.length exps = List.length ts -> - List.iter2 (check_exp env) ts exps - | OptE exp1, _ when T.is_opt t -> - check_exp env (T.as_opt t) exp1 -(* - | ObjE (sort, id, fields), T.Obj (s, tfs) when s = sort.it -> - let env' = if sort.it = T.Actor then { env with async = false } else env in - ignore (check_obj env' s tfs id fields exp.at) - *) - | ArrayE (mut, exps), T.Array t' -> - if (mut.it = Var) <> T.is_mut t' then - local_error env exp.at "%smutable array expression cannot produce expected type\n %s" - (if mut.it = Const then "im" else "") - (T.string_of_typ_expand env.cons (T.Array t')); - List.iter (check_exp env (T.as_immut t')) exps - | AsyncE exp1, T.Async t' -> - let env' = {env with labs = T.Env.empty; rets = Some t'; async = true} in - check_exp env' t' exp1 - | BlockE decs, _ -> - ignore (check_block env t decs exp.at) - | IfE (exp1, exp2, exp3), _ -> - check_exp env T.bool exp1; - check_exp env t exp2; - check_exp env t exp3 - | SwitchE (exp1, cases), _ -> - let t1 = infer_exp_promote env exp1 in - check_cases env t1 t cases; - if not (Coverage.check_cases env.cons cases t1) then - warn env exp.at "the cases in this switch do not cover all possible values"; - | _ -> - *) let t' = infer_exp env exp in if not (T.sub env.cons t' t) then local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" @@ -755,7 +661,10 @@ and infer_pat env pat : T.typ * val_env = assert (pat.note <> T.Pre); let t, ve = infer_pat' env pat in if not env.pre then - pat.note <- T.normalize env.cons t; + if not (T.eq env.cons t pat.note) then + local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons pat.note); t, ve and infer_pat' env pat : T.typ * val_env = @@ -799,7 +708,11 @@ and check_pat env t pat : val_env = if t = T.Pre then snd (infer_pat env pat) else let t' = T.normalize env.cons t in let ve = check_pat' env t pat in - if not env.pre then pat.note <- t'; + if not env.pre then + if not (T.eq env.cons t' pat.note) then + local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons pat.note); ve and check_pat' env t pat : val_env = @@ -834,16 +747,7 @@ and check_pat' env t pat : val_env = if ve1 <> T.Env.empty || ve2 <> T.Env.empty then error env pat.at "variables are not allowed in pattern alternatives"; T.Env.empty -(* TBD - | _ -> - let t', ve = infer_pat env pat in - if not (T.sub env.cons t t') then - error env pat.at "pattern of type\n %s\ncannot consume expected type\n %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons t); - ve - *) - + and check_pats env ts pats ve at : val_env = match pats, ts with | [], [] -> ve @@ -911,8 +815,7 @@ and infer_exp_fields env s id t fields : T.field list * val_env = and is_func_exp exp = match exp.it with - (* | DecE dec -> is_func_dec dec *) - | BlockE ([dec],_)-> is_func_dec dec + | BlockE ([dec],_)-> is_func_dec dec | _ -> Printf.printf "[1]%!"; false and is_func_dec dec = @@ -981,8 +884,6 @@ and check_open_typ_binds env typ_binds = let _,_ = check_typ_binds env binds in cs,ce - - and infer_dec env dec : T.typ = let t = match dec.it with @@ -1003,19 +904,6 @@ and infer_dec env dec : T.typ = check_exp (adjoin_vals env'' ve) typ exp end; t -(* - | ClassD (id, tid, typ_binds, sort, pat, id', fields) -> - let t = T.Env.find id.it env.vals in - if not env.pre then begin - let _cs, _ts, te, ce = check_typ_binds env typ_binds in - let env' = adjoin_typs env te ce in - let _, ve = infer_pat_exhaustive env' pat in - let env'' = - {env' with labs = T.Env.empty; rets = None; async = false} in - ignore (infer_obj (adjoin_vals env'' ve) sort.it id' fields) - end; - t -*) | TypD _ -> T.unit in @@ -1054,7 +942,10 @@ and check_dec env t dec = match dec.it with | ExpD exp -> check_exp env t exp; - (*TODO dec.note <- exp.note; *) + if not (T.eq env.cons exp.note.Syntax.note_typ dec.note.Syntax.note_typ) then + local_error env dec.at "unequal type of expression \n %s\n in declaration \n %s" + (T.string_of_typ_expand env.cons exp.note.Syntax.note_typ) + (T.string_of_typ_expand env.cons dec.note.Syntax.note_typ) (* TBR: push in external type annotation; unfortunately, this isn't enough, because of the earlier recursive phases | FuncD (id, [], pat, typ, exp) -> @@ -1085,18 +976,6 @@ and check_dec env t dec = local_error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons t') - -(* -and print_ce = - Con.Env.iter (fun c k -> - Printf.printf " type %s %s\n" (Con.to_string c) (Type.string_of_kind k) - ) -and print_ve = - Type.Env.iter (fun x t -> - Printf.printf " %s : %s\n" x (Type.string_of_typ t) - ) -*) - and infer_block_decs env decs : scope = let scope = gather_block_typdecs env decs in @@ -1108,7 +987,7 @@ and infer_block_decs env decs : scope = (* assert (ce = ce'); *) let pre_ve' = gather_block_valdecs env decs in let ve = infer_block_valdecs (adjoin_vals env'' pre_ve') decs in - { scope with val_env = ve; con_env = ce } + { val_env = ve; con_env = ce } (* Pass 1: collect type identifiers and their arity *) @@ -1229,19 +1108,6 @@ and infer_dec_valdecs env dec : val_env = (T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) | TypD _ -> T.Env.empty -(* - | ClassD (conid, id, typ_binds, sort, pat, id', fields) -> - let cs, ts, te, ce = check_typ_binds env typ_binds in - let env' = adjoin_typs env te ce in - let c = T.Env.find id.it env.typs in - let t1, _ = infer_pat {env' with pre = true} pat in - let ts1 = match pat.it with - | TupP _ -> T.as_seq t1 - | _ -> [t1] in - let t2 = T.Con (c, List.map (fun c -> T.Con (c, [])) cs) in - let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in - T.Env.singleton conid.it (T.Func (T.Construct, T.Returns, tbs, List.map (T.close cs) ts1, [T.close cs t2])) - *) (* Programs *) From cc70ebe3a790c9f971d4b90d00f62c77ec440d2c Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 22 Jan 2019 11:39:17 +0000 Subject: [PATCH 21/45] annotate DotE with obj_sort to simplify desugaring (in next commit) --- src/arrange.ml | 8 +++++--- src/async.ml | 4 ++-- src/awaitopt.ml | 8 ++++---- src/check_ir.ml | 30 ++++++++++++++++-------------- src/desugar.ml | 10 ++++------ src/effect.ml | 2 +- src/freevars.ml | 2 +- src/interpret.ml | 2 +- src/parser.mly | 7 ++++--- src/rename.ml | 2 +- src/syntax.ml | 2 +- src/syntaxops.ml | 2 +- src/tailcall.ml | 2 +- src/typing.ml | 5 +++-- 14 files changed, 45 insertions(+), 41 deletions(-) diff --git a/src/arrange.ml b/src/arrange.ml index faf22a5360e..02d48394995 100644 --- a/src/arrange.ml +++ b/src/arrange.ml @@ -13,7 +13,7 @@ let rec exp e = match e.it with | TupE es -> "TupE" $$ List.map exp es | ProjE (e, i) -> "ProjE" $$ [exp e; Atom (string_of_int i)] | ObjE (s, i, efs) -> "ObjE" $$ [obj_sort s; id i] @ List.map exp_field efs - | DotE (e, n) -> "DotE" $$ [exp e; name n] + | DotE (e, sr, n) -> "DotE" $$ [exp e; obj_sort' !sr; name n] | AssignE (e1, e2) -> "AssignE" $$ [exp e1; exp e2] | ArrayE (m, es) -> "ArrayE" $$ [mut m] @ List.map exp es | IdxE (e1, e2) -> "IdxE" $$ [exp e1; exp e2] @@ -109,11 +109,13 @@ and sharing sh = match sh with and control c = match c with | Type.Returns -> "Returns" | Type.Promises -> "Promises" - -and obj_sort s = match s.it with + +and obj_sort' s = match s with | Type.Object sh -> Atom ("Object " ^ sharing sh) | Type.Actor -> Atom "Actor" +and obj_sort s = obj_sort' s.it + and func_sort s = match s.it with | Type.Call sh -> Atom ("Call " ^ sharing sh) | Type.Construct -> Atom "Construct" diff --git a/src/async.ml b/src/async.ml index 4c268e902e9..5ef8fdae3f7 100644 --- a/src/async.ml +++ b/src/async.ml @@ -241,8 +241,8 @@ and t_exp' (exp:Syntax.exp) = | ObjE (sort, id, fields) -> let fields' = t_fields fields in ObjE (sort, id, fields') - | DotE (exp1, id) -> - DotE (t_exp exp1, id) + | DotE (exp1, sr, id) -> + DotE (t_exp exp1, ref !sr, id) | AssignE (exp1, exp2) -> AssignE (t_exp exp1, t_exp exp2) | ArrayE (mut, exps) -> diff --git a/src/awaitopt.ml b/src/awaitopt.ml index f1cd3715579..f6b5e96c6aa 100644 --- a/src/awaitopt.ml +++ b/src/awaitopt.ml @@ -82,8 +82,8 @@ and t_exp' context exp' = | ObjE (sort, id, fields) -> let fields' = t_fields context fields in ObjE (sort, id, fields') - | DotE (exp1, id) -> - DotE (t_exp context exp1, id) + | DotE (exp1, sr, id) -> + DotE (t_exp context exp1, ref (!sr), id) | AssignE (exp1, exp2) -> AssignE (t_exp context exp1, t_exp context exp2) | ArrayE (mut, exps) -> @@ -407,8 +407,8 @@ and c_exp' context exp k = unary context k (fun v1 -> e (ProjE (v1, n))) exp1 | ObjE (sort, id, fields) -> c_obj context exp sort id fields k - | DotE (exp1, id) -> - unary context k (fun v1 -> e (DotE (v1, id))) exp1 + | DotE (exp1, sr, id) -> + unary context k (fun v1 -> e (DotE (v1, ref (!sr), id))) exp1 | AssignE (exp1, exp2) -> binary context k (fun v1 v2 -> e (AssignE (v1, v2))) exp1 exp2 | ArrayE (mut, exps) -> diff --git a/src/check_ir.ml b/src/check_ir.ml index b160683c1c2..b58cb940d75 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -3,11 +3,13 @@ module T = Type module E = Effect (* TODO: fix uses of List.sort compare etc on fields rather than field names *) -(* TODO: annote DotE in checker for desugaring sans environments *) -(* TODO: remove DecE from syntax, replace by BlockE [dec] *) -(* TODO: check constraint matching supports recursive bounds *) +(* TODO: annotate DotE in checker for desugaring sans environments *) +(* TODO: remove DecE from syntax, replace by BlockE [dec] *) +(* TODO: check constraint matching supports recursive bounds *) + +(* TODO: remove T.pre, desugar ClassD to TypD + FuncD, + make note immutable and remove remaining updates *) -(* TODO: remove T.pre, simplify env, desugar ClassD to TypD + FuncD, make note immutable and remove remaining updates *) (* Error bookkeeping *) (* Recovering from errors *) @@ -23,7 +25,7 @@ let recover f y = recover_with () f y type val_env = T.typ T.Env.t type con_env = T.con_env -type scope = +type scope = { val_env : val_env; con_env : con_env; } @@ -286,16 +288,16 @@ let rec infer_exp env exp : T.typ = and infer_exp_promote env exp : T.typ = let t = infer_exp env exp in - T.promote env.cons t + T.promote env.cons t and infer_exp_mut env exp : T.typ = let t = infer_exp' env exp in - if not env.pre then begin + if not env.pre then begin (* TODO: enable me one infer_effect works on Ir nodes... - let e = E.infer_effect_exp exp in + let e = E.infer_effect_exp exp in assert (T.Triv < T.Await); if not (e <= E.eff exp) then begin - error env exp.at "inferred effect not a subtype of expected effect" + error env exp.at "inferred effect not a subtype of expected effect" end; *) if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then begin (*TBR*) @@ -457,7 +459,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | BlockE (decs, t) -> let t1, scope = infer_block env decs exp.at in (* let _t2 = try T.avoid env.cons scope.con_env t1 with T.Unavoidable c -> assert false in *) - let env' = adjoin env scope in + let env' = adjoin env scope in check_typ env t; if not (T.eq env.cons t T.unit || T.eq env'.cons t1 t) then error env exp.at "expected block type\n %s, found declaration with inequivalent type\n %s" @@ -913,10 +915,10 @@ and infer_dec env dec : T.typ = (T.string_of_typ_expand env.cons (E.typ dec)); end; (* TODO: enable me one infer_effect works on Ir nodes... - let e = E.infer_effect_dec dec in + let e = E.infer_effect_dec dec in assert (T.Triv < T.Await); if not (e <= E.eff dec) then begin - error env dec.at "inferred effect not a subtype of expected effect" + error env dec.at "inferred effect not a subtype of expected effect" end; *) E.typ dec @@ -1027,7 +1029,7 @@ and infer_dec_typdecs env dec : con_env = let cs,ce = check_typ_binds env binds in let ts = List.map (fun c -> T.Con(c,[])) cs in let env' = adjoin_typs env ce in - check_typ env' (T.open_ ts typ); + check_typ env' (T.open_ ts typ); Con.Env.singleton c k (* Pass 4: collect value identifiers *) @@ -1061,7 +1063,7 @@ and infer_dec_valdecs env dec : val_env = T.Env.empty | LetD (pat, exp) -> let t = infer_exp {env with pre = true} exp in - let ve' = check_pat_exhaustive env t pat in + let ve' = check_pat_exhaustive env t pat in ve' | VarD (id, exp) -> let t = infer_exp {env with pre = true} exp in diff --git a/src/desugar.ml b/src/desugar.ml index ac5690ee9c2..fba61ecfe5d 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -53,12 +53,10 @@ let Type.typ = t}) public_es)) in obj ce at s None i es obj_typ - | S.DotE (e, n) -> - begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with - | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) - | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp ce e, n) - | Type.Con _ -> raise (Invalid_argument ("Con in promoted type")) - | _ -> raise (Invalid_argument ("non-object in dot operator")) + | S.DotE (e, sr, n) -> + begin match (!sr) with + | Type.Actor -> I.ActorDotE (exp ce e, n) + | _ -> I.DotE (exp ce e, n) end | S.AssignE (e1, e2) -> I.AssignE (exp ce e1, exp ce e2) | S.ArrayE (m, es) -> diff --git a/src/effect.ml b/src/effect.ml index 84b3be3699e..a7eee96ddd9 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -26,7 +26,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | UnE (_, _, exp1) | ProjE (exp1, _) | OptE exp1 - | DotE (exp1, _) + | DotE (exp1, _, _) | NotE exp1 | AssertE exp1 | LabelE (_, _, exp1) diff --git a/src/freevars.ml b/src/freevars.ml index 201dfbd29b5..7e1d3ac32ba 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -42,7 +42,7 @@ let rec exp e : f = match e.it with | TupE es -> exps es | ProjE (e, i) -> exp e | ObjE (s, i, efs) -> close (exp_fields efs) // i.it - | DotE (e, i) -> exp e + | DotE (e, _, i) -> exp e | AssignE (e1, e2) -> exps [e1; e2] | ArrayE (m, es) -> exps es | IdxE (e1, e2) -> exps [e1; e2] diff --git a/src/interpret.ml b/src/interpret.ml index 2fd5c915cec..4ea5a353488 100644 --- a/src/interpret.ml +++ b/src/interpret.ml @@ -289,7 +289,7 @@ and interpret_exp_mut env exp (k : V.value V.cont) = interpret_exp env exp1 (fun v1 -> k (List.nth (V.as_tup v1) n)) | ObjE (sort, id, fields) -> interpret_obj env sort id None fields k - | DotE (exp1, {it = Name n;_}) -> + | DotE (exp1, _, {it = Name n;_}) -> interpret_exp env exp1 (fun v1 -> let _, fs = V.as_obj v1 in k (try find n fs with _ -> assert false) diff --git a/src/parser.mly b/src/parser.mly index b2255c963b7..7e38fde5b9f 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -24,6 +24,7 @@ let (@?) it at = {it; at; note = empty_typ_note} let (@!) it at = {it; at; note = Type.Pre} let (@=) it at = {it; at; note = None} +let dummy_obj_sort() = ref (Type.Object Type.Local) let dup_var x = VarE (x.it @@ x.at) @? x.at let name_exp e = @@ -37,9 +38,9 @@ let assign_op lhs rhs_f at = let ds, lhs', rhs' = match lhs.it with | VarE x -> [], lhs, dup_var x - | DotE (e1, x) -> + | DotE (e1, _, x) -> let ds, ex11, ex12 = name_exp e1 in - ds, DotE (ex11, x) @? lhs.at, DotE (ex12, x.it @@ x.at) @? lhs.at + ds, DotE (ex11, dummy_obj_sort(), x) @? lhs.at, DotE (ex12, dummy_obj_sort(), x.it @@ x.at) @? lhs.at | IdxE (e1, e2) -> let ds1, ex11, ex12 = name_exp e1 in let ds2, ex21, ex22 = name_exp e2 in @@ -354,7 +355,7 @@ exp_post : | e=exp_post DOT s=NAT { ProjE (e, int_of_string s) @? at $sloc } | e=exp_post DOT x=id - { DotE(e, {x with it = Name x.it}) @? at $sloc } + { DotE(e, dummy_obj_sort(), {x with it = Name x.it}) @? at $sloc } | e1=exp_post tso=typ_args? e2=exp_nullary { let typ_args = Lib.Option.get tso [] in CallE(e1, typ_args, e2) @? at $sloc } diff --git a/src/rename.ml b/src/rename.ml index 564218da645..4b9038857f3 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -34,7 +34,7 @@ and exp' rho e = match e with | TupE es -> TupE (List.map (exp rho) es) | ProjE (e, i) -> ProjE (exp rho e, i) | ObjE (s, i, efs) -> ObjE (s, i, exp_fields rho efs) - | DotE (e, i) -> DotE (exp rho e, i) + | DotE (e, sr, i) -> DotE (exp rho e, ref (!sr), i) | AssignE (e1, e2) -> AssignE (exp rho e1, exp rho e2) | ArrayE (m, es) -> ArrayE (m, exps rho es) | IdxE (e1, e2) -> IdxE (exp rho e1, exp rho e2) diff --git a/src/syntax.ml b/src/syntax.ml index a59e8a1034c..75a4132cfbe 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -138,7 +138,7 @@ and exp' = | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) | ObjE of obj_sort * id * exp_field list (* object *) - | DotE of exp * name (* object projection *) + | DotE of exp * Type.obj_sort ref * name (* object projection *) | AssignE of exp * exp (* assignment *) | ArrayE of mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) diff --git a/src/syntaxops.ml b/src/syntaxops.ml index 0b05564a0c4..91f3df0400c 100644 --- a/src/syntaxops.ml +++ b/src/syntaxops.ml @@ -149,7 +149,7 @@ let ifE exp1 exp2 exp3 typ = } let dotE exp name typ = - { it = DotE (exp,name); + { it = DotE (exp,ref (T.Object T.Local), name); at = no_region; note = {note_typ = typ; note_eff = eff exp} diff --git a/src/tailcall.ml b/src/tailcall.ml index 051d389076b..b76971c38de 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -85,7 +85,7 @@ and exp' env e = match e.it with | TupE es -> TupE (List.map (exp env) es) | ProjE (e, i) -> ProjE (exp env e, i) | ObjE (s, i, efs) -> ObjE (s, i, exp_fields env efs) - | DotE (e, i) -> DotE (exp env e, i) + | DotE (e, sr, i) -> DotE (exp env e, ref (!sr), i) | AssignE (e1, e2) -> AssignE (exp env e1, exp env e2) | ArrayE (m,es) -> ArrayE (m,(exps env es)) | IdxE (e1, e2) -> IdxE (exp env e1, exp env e2) diff --git a/src/typing.ml b/src/typing.ml index 198a18a4012..e16b9274aa2 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -418,10 +418,11 @@ and infer_exp' env exp : T.typ = | ObjE (sort, id, fields) -> let env' = if sort.it = T.Actor then { env with async = false } else env in infer_obj env' sort.it id fields - | DotE (exp1, {it = Name n;_}) -> + | DotE (exp1, sr, {it = Name n;_}) -> let t1 = infer_exp_promote env exp1 in (try - let _, tfs = T.as_obj_sub n env.cons t1 in + let s, tfs = T.as_obj_sub n env.cons t1 in + sr := s; match List.find_opt (fun {T.name; _} -> name = n) tfs with | Some {T.typ = t; _} -> t | None -> From d64ff0b77c3de670ac600783a98a9b8126d28bd7 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 22 Jan 2019 11:42:32 +0000 Subject: [PATCH 22/45] remove con_env from desugar.ml, now that DotE is sort annotated --- src/desugar.ml | 152 ++++++++++++++++++++++++------------------------ src/desugar.mli | 2 +- src/pipeline.ml | 5 +- 3 files changed, 79 insertions(+), 80 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index fba61ecfe5d..c2dfe8b6693 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -22,25 +22,25 @@ let apply_sign op l = Syntax.(match op, l with | _, _ -> raise (Invalid_argument "Invalid signed pattern") ) -let phrase ce f x = {x with it = f ce x.it} -let phrase' ce f x = {x with it = f ce x.at x.note x.it} +let phrase f x = {x with it = f x.it} +let phrase' f x = {x with it = f x.at x.note x.it} let - rec exps ce es = List.map (exp ce) es - and exp ce e = phrase' ce exp' e - and exp' ce at note = function + rec exps es = List.map (exp) es + and exp e = phrase' exp' e + and exp' at note = function | S.PrimE p -> I.PrimE p | S.VarE i -> I.VarE i | S.LitE l -> I.LitE !l | S.UnE (ot, o, e) -> - I.UnE (!ot, o, exp ce e) + I.UnE (!ot, o, exp e) | S.BinE (ot, e1, o, e2) -> - I.BinE (!ot, exp ce e1, o, exp ce e2) + I.BinE (!ot, exp e1, o, exp e2) | S.RelE (ot, e1, o, e2) -> - I.RelE (!ot, exp ce e1, o, exp ce e2) - | S.TupE es -> I.TupE (exps ce es) - | S.ProjE (e, i) -> I.ProjE (exp ce e, i) - | S.OptE e -> I.OptE (exp ce e) + I.RelE (!ot, exp e1, o, exp e2) + | S.TupE es -> I.TupE (exps es) + | S.ProjE (e, i) -> I.ProjE (exp e, i) + | S.OptE e -> I.OptE (exp e) | S.ObjE (s, i, es) -> let public_es = List.filter (fun e -> e.it.S.priv.it == Syntax.Public) es in let obj_typ = @@ -52,56 +52,56 @@ let {Type.name = S.string_of_name name.it; Type.typ = t}) public_es)) in - obj ce at s None i es obj_typ + obj at s None i es obj_typ | S.DotE (e, sr, n) -> begin match (!sr) with - | Type.Actor -> I.ActorDotE (exp ce e, n) - | _ -> I.DotE (exp ce e, n) + | Type.Actor -> I.ActorDotE (exp e, n) + | _ -> I.DotE (exp e, n) end - | S.AssignE (e1, e2) -> I.AssignE (exp ce e1, exp ce e2) + | S.AssignE (e1, e2) -> I.AssignE (exp e1, exp e2) | S.ArrayE (m, es) -> let t = Type.as_array note.S.note_typ in - I.ArrayE (m, Type.as_immut t, exps ce es) - | S.IdxE (e1, e2) -> I.IdxE (exp ce e1, exp ce e2) + I.ArrayE (m, Type.as_immut t, exps es) + | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) | S.CallE (e1, inst, e2) -> let cc = Value.call_conv_of_typ e1.Source.note.S.note_typ in let inst = List.map (fun t -> t.Source.note) inst in - I.CallE (cc, exp ce e1, inst, exp ce e2) - | S.BlockE (ds, ot) -> I.BlockE (decs ce ds, !ot) - | S.NotE e -> I.IfE (exp ce e, false_lit, true_lit) - | S.AndE (e1, e2) -> I.IfE (exp ce e1, exp ce e2, false_lit) - | S.OrE (e1, e2) -> I.IfE (exp ce e1, true_lit, exp ce e2) - | S.IfE (e1, e2, e3) -> I.IfE (exp ce e1, exp ce e2, exp ce e3) - | S.SwitchE (e1, cs) -> I.SwitchE (exp ce e1, cases ce cs) - | S.WhileE (e1, e2) -> I.WhileE (exp ce e1, exp ce e2) - | S.LoopE (e1, None) -> I.LoopE (exp ce e1, None) - | S.LoopE (e1, Some e2) -> I.LoopE (exp ce e1, Some (exp ce e2)) - | S.ForE (p, e1, e2) -> I.ForE (pat ce p, exp ce e1, exp ce e2) - | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp ce e) - | S.BreakE (l, e) -> I.BreakE (l, exp ce e) - | S.RetE e -> I.RetE (exp ce e) - | S.AsyncE e -> I.AsyncE (exp ce e) - | S.AwaitE e -> I.AwaitE (exp ce e) - | S.AssertE e -> I.AssertE (exp ce e) - | S.IsE (e1, e2) -> I.IsE (exp ce e1, exp ce e2) - | S.AnnotE (e, _) -> exp' ce at note e.it - | S.DecE (d, ot) -> I.BlockE (decs ce [d], !ot) - | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp ce e) - | S.DefineE (i, m, e) -> I.DefineE (i, m, exp ce e) + I.CallE (cc, exp e1, inst, exp e2) + | S.BlockE (ds, ot) -> I.BlockE (decs ds, !ot) + | S.NotE e -> I.IfE (exp e, false_lit, true_lit) + | S.AndE (e1, e2) -> I.IfE (exp e1, exp e2, false_lit) + | S.OrE (e1, e2) -> I.IfE (exp e1, true_lit, exp e2) + | S.IfE (e1, e2, e3) -> I.IfE (exp e1, exp e2, exp e3) + | S.SwitchE (e1, cs) -> I.SwitchE (exp e1, cases cs) + | S.WhileE (e1, e2) -> I.WhileE (exp e1, exp e2) + | S.LoopE (e1, None) -> I.LoopE (exp e1, None) + | S.LoopE (e1, Some e2) -> I.LoopE (exp e1, Some (exp e2)) + | S.ForE (p, e1, e2) -> I.ForE (pat p, exp e1, exp e2) + | S.LabelE (l, t, e) -> I.LabelE (l, t.Source.note, exp e) + | S.BreakE (l, e) -> I.BreakE (l, exp e) + | S.RetE e -> I.RetE (exp e) + | S.AsyncE e -> I.AsyncE (exp e) + | S.AwaitE e -> I.AwaitE (exp e) + | S.AssertE e -> I.AssertE (exp e) + | S.IsE (e1, e2) -> I.IsE (exp e1, exp e2) + | S.AnnotE (e, _) -> exp' at note e.it + | S.DecE (d, ot) -> I.BlockE (decs [d], !ot) + | S.DeclareE (i, t, e) -> I.DeclareE (i, t, exp e) + | S.DefineE (i, m, e) -> I.DefineE (i, m, exp e) | S.NewObjE (s, fs) -> I.NewObjE (s, fs, note.S.note_typ) - and field_to_dec ce (f : S.exp_field) : Ir.dec = + and field_to_dec (f : S.exp_field) : Ir.dec = match f.it.S.mut.it with | S.Const -> {it = I.LetD ({it = I.VarP f.it.S.id; at = no_region; note = f.it.S.exp.note.S.note_typ }, - exp ce f.it.S.exp); + exp f.it.S.exp); at = f.at; note = { f.it.S.exp.note with S.note_typ = T.unit} } | S.Var -> - {it = I.VarD (f.it.S.id, exp ce f.it.S.exp); + {it = I.VarD (f.it.S.id, exp f.it.S.exp); at = f.at; note = { f.it.S.exp.note with S.note_typ = T.unit} } @@ -111,14 +111,14 @@ let | S.Private -> [] | S.Public -> [ (f.it.S.name, f.it.S.id) ] - and obj ce at s class_id self_id es obj_typ = + and obj at s class_id self_id es obj_typ = match s.it with - | Type.Object _ -> build_obj ce at None self_id es obj_typ - | Type.Actor -> I.ActorE (self_id, exp_fields ce es, obj_typ) + | Type.Object _ -> build_obj at None self_id es obj_typ + | Type.Actor -> I.ActorE (self_id, exp_fields es, obj_typ) - and build_obj ce at class_id self_id es obj_typ = + and build_obj at class_id self_id es obj_typ = I.BlockE ( - List.map (field_to_dec ce) es @ + List.map (field_to_dec) es @ [ {it = I.LetD ( {it = I.VarP self_id; at = at; @@ -145,17 +145,17 @@ let ], obj_typ) - and exp_fields ce fs = List.map (exp_field ce) fs - and exp_field ce f = phrase ce exp_field' f - and exp_field' ce (f : S.exp_field') = - S.{ I.name = f.name; I.id = f.id; I.exp = exp ce f.exp; I.mut = f.mut; I.priv = f.priv} + and exp_fields fs = List.map (exp_field) fs + and exp_field f = phrase exp_field' f + and exp_field' (f : S.exp_field') = + S.{ I.name = f.name; I.id = f.id; I.exp = exp f.exp; I.mut = f.mut; I.priv = f.priv} - and typ_binds ce tbs = List.map (typ_bind ce) tbs - and typ_bind ce tb = - phrase' ce typ_bind' tb - and typ_bind' ce at n {S.var; S.bound} = {Type.var = var.it; Type.bound = bound.note} - and decs ce ds = + and typ_binds tbs = List.map (typ_bind) tbs + and typ_bind tb = + phrase' typ_bind' tb + and typ_bind' at n {S.var; S.bound} = {Type.var = var.it; Type.bound = bound.note} + and decs ds = match ds with | [] -> [] | d::ds -> @@ -166,15 +166,15 @@ let at = d.at; note = {S.note_typ = T.unit; S.note_eff = T.Triv}} in - typD::(phrase' ce dec' d)::(decs ce ds) - | _ -> (phrase' ce dec' d)::(decs ce ds) - and dec' ce at n d = match d with - | S.ExpD e -> I.ExpD (exp ce e) - | S.LetD (p, e) -> I.LetD (pat ce p, exp ce e) - | S.VarD (i, e) -> I.VarD (i, exp ce e) + typD::(phrase' dec' d)::(decs ds) + | _ -> (phrase' dec' d)::(decs ds) + and dec' at n d = match d with + | S.ExpD e -> I.ExpD (exp e) + | S.LetD (p, e) -> I.LetD (pat p, exp e) + | S.VarD (i, e) -> I.VarD (i, exp e) | S.FuncD (s, i, tbs, p, ty, e) -> let cc = Value.call_conv_of_typ n.S.note_typ in - I.FuncD (cc, i, typ_binds ce tbs, pat ce p, ty.note, exp ce e) + I.FuncD (cc, i, typ_binds tbs, pat p, ty.note, exp e) | S.TypD (con_id, typ_bind, t) -> let (c,k) = Lib.Option.value con_id.note in I.TypD (c,k) @@ -193,26 +193,26 @@ let T.open_ inst rng | _ -> assert false in - I.FuncD (cc, fun_id, typ_binds ce tbs, pat ce p, obj_typ, (* TBR *) - {it = obj ce at s (Some fun_id) self_id es obj_typ; + I.FuncD (cc, fun_id, typ_binds tbs, pat p, obj_typ, (* TBR *) + {it = obj at s (Some fun_id) self_id es obj_typ; at = at; note = {S.note_typ = obj_typ; S.note_eff = T.Triv}}) - and cases ce cs = List.map (case ce) cs - and case ce c = phrase ce case' c - and case' ce c = S.{ I.pat = pat ce c.pat; I.exp = exp ce c.exp} + and cases cs = List.map (case) cs + and case c = phrase case' c + and case' c = S.{ I.pat = pat c.pat; I.exp = exp c.exp} - and pats ce ps = List.map (pat ce) ps - and pat ce p = phrase ce pat' p - and pat' ce = function + and pats ps = List.map (pat) ps + and pat p = phrase pat' p + and pat' = function | S.VarP v -> I.VarP v | S.WildP -> I.WildP | S.LitP l -> I.LitP !l | S.SignP (o, l) -> I.LitP (apply_sign o !l) - | S.TupP ps -> I.TupP (pats ce ps) - | S.OptP p -> I.OptP (pat ce p) - | S.AltP (p1, p2) -> I.AltP (pat ce p1, pat ce p2) - | S.AnnotP (p, _) -> pat' ce p.it + | S.TupP ps -> I.TupP (pats ps) + | S.OptP p -> I.OptP (pat p) + | S.AltP (p1, p2) -> I.AltP (pat p1, pat p2) + | S.AnnotP (p, _) -> pat' p.it - and prog ce p = phrase ce decs p + and prog p = phrase decs p diff --git a/src/desugar.mli b/src/desugar.mli index e5b8ac30616..a2ec063ac2d 100644 --- a/src/desugar.mli +++ b/src/desugar.mli @@ -1 +1 @@ -val prog : Typing.con_env -> Syntax.prog -> Ir.prog +val prog : Syntax.prog -> Ir.prog diff --git a/src/pipeline.ml b/src/pipeline.ml index 913eca1e83d..2ab65064019 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -286,12 +286,11 @@ let compile_with check mode name : compile_result = | Error msgs -> Error msgs | Ok ((prog, _t, scope), msgs) -> Diag.print_messages msgs; - let prelude = Desugar.prog initial_stat_env.Typing.con_env prelude in + let prelude = Desugar.prog prelude in let prog = await_lowering true prog name in let prog = async_lowering true prog name in let prog = tailcall_optimization true prog name in - let scope' = Typing.adjoin_scope initial_stat_env scope in - let prog = Desugar.prog scope'.Typing.con_env prog in + let prog = Desugar.prog prog in match Check_ir.check_prog initial_stat_env prog with | Error msgs -> Diag.print_messages msgs; assert (false) | Ok (_,msgs) -> Diag.print_messages msgs; From 7408f0fceda455464e4e25d1f3898d6ad4037798 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Tue, 22 Jan 2019 12:11:14 +0000 Subject: [PATCH 23/45] use Type.compare_field, not lexicographic compare, for ordering fields in record types --- src/check_ir.ml | 20 ++++++++++++++------ src/desugar.ml | 2 +- src/pipeline.ml | 11 +++++++++-- src/type.ml | 10 +++++++--- src/type.mli | 6 +++++- src/typing.ml | 4 ++-- 6 files changed, 38 insertions(+), 15 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index b58cb940d75..e0c406e89c0 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -3,7 +3,7 @@ module T = Type module E = Effect (* TODO: fix uses of List.sort compare etc on fields rather than field names *) -(* TODO: annotate DotE in checker for desugaring sans environments *) + (* TODO: remove DecE from syntax, replace by BlockE [dec] *) (* TODO: check constraint matching supports recursive bounds *) @@ -194,10 +194,18 @@ let rec check_typ env typ : unit = | T.Like typ -> check_typ env typ | T.Obj (sort, fields) -> + let rec sorted fields = + match fields with + | [] + | [_] -> true + | f1::((f2::_) as fields') -> + T.compare_field f1 f2 < 0 && sorted fields' + in check_ids env (List.map (fun (field : T.field) -> field.T.name) fields); - List.iter (check_typ_field env sort) fields - (* TODO: check fields are sorted, c.f. typecheck:ml: *) - (* T.Obj (sort.it, List.sort compare fs) *) (* IS THAT EVEN CORRECT? *) + List.iter (check_typ_field env sort) fields; + if not (sorted fields) then + error env no_region "object type's fields are not sorted\n %s" + (T.string_of_typ_expand env.cons typ); | T.Mut typ -> check_typ env typ @@ -583,7 +591,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.unit | NewObjE (sort, labids, t) -> let t1 = - T.Obj(sort.it, List.sort compare (List.map (fun (name,id) -> + T.Obj(sort.it, List.sort T.compare_field (List.map (fun (name,id) -> {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in let t2 = unfold_obj env t exp.at in if T.sub env.cons t1 t2 then @@ -813,7 +821,7 @@ and infer_exp_fields env s id t fields : T.field list * val_env = let env' = add_val env id t in let tfs, ve = List.fold_left (infer_exp_field env' s) ([], T.Env.empty) fields in - List.sort compare tfs, ve + List.sort T.compare_field tfs, ve and is_func_exp exp = match exp.it with diff --git a/src/desugar.ml b/src/desugar.ml index c2dfe8b6693..14a0f4d6ff6 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -45,7 +45,7 @@ let let public_es = List.filter (fun e -> e.it.S.priv.it == Syntax.Public) es in let obj_typ = T.Obj(s.it, - List.sort compare + List.sort T.compare_field (List.map (fun {it = {Syntax.name;exp;mut;priv;_};_} -> let t = exp.note.S.note_typ in let t = if mut.it = Syntax.Var then Type.Mut t else t in diff --git a/src/pipeline.ml b/src/pipeline.ml index 2ab65064019..25512304cdc 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -244,7 +244,14 @@ let output_scope (senv, _) t v sscope dscope = let is_exp dec = match dec.Source.it with Syntax.ExpD _ -> true | _ -> false let run_with interpret output ((senv, denv) as env) name : run_result = - let result = interpret env name in + let result = interpret env name in (* + begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with + | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) + | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp ce e, n) + | Type.Con _ -> raise (Invalid_argument ("Con in promoted type")) + | _ -> raise (Invalid_argument ("non-object in dot operator")) + end *) + let env' = match result with | None -> @@ -289,7 +296,7 @@ let compile_with check mode name : compile_result = let prelude = Desugar.prog prelude in let prog = await_lowering true prog name in let prog = async_lowering true prog name in - let prog = tailcall_optimization true prog name in + let prog = tailcall_optimization true prog name in let prog = Desugar.prog prog in match Check_ir.check_prog initial_stat_env prog with | Error msgs -> Diag.print_messages msgs; assert (false) diff --git a/src/type.ml b/src/type.ml index 483068dd5c2..227dcf01971 100644 --- a/src/type.ml +++ b/src/type.ml @@ -43,6 +43,10 @@ and typ = and bind = {var : string; bound : typ} and field = {name : string; typ : typ} +(* field ordering *) + +let compare_field {name=n;_} {name=m;_} = compare n m + type kind = | Def of bind list * typ | Abs of bind list * typ @@ -94,8 +98,8 @@ let array_obj t = let mut t = immut t @ [ {name = "set"; typ = Func (Call Local, Returns, [], [Prim Nat; t], [])} ] in match t with - | Mut t' -> Obj (Object Local, List.sort compare (mut t')) - | t -> Obj (Object Local, List.sort compare (immut t)) + | Mut t' -> Obj (Object Local, List.sort compare_field (mut t')) + | t -> Obj (Object Local, List.sort compare_field (immut t)) (* Shifting *) @@ -491,7 +495,7 @@ and rel_fields env rel eq tfs1 tfs2 = | _, [] when rel != eq -> true | tf1::tfs1', tf2::tfs2' -> - (match compare tf1.name tf2.name with + (match compare_field tf1 tf2 with | 0 -> rel_typ env rel eq tf1.typ tf2.typ && rel_fields env rel eq tfs1' tfs2' diff --git a/src/type.mli b/src/type.mli index b57608b1051..4fea582590d 100644 --- a/src/type.mli +++ b/src/type.mli @@ -43,6 +43,10 @@ and typ = and bind = {var : string; bound : typ} and field = {name : string; typ : typ} +(* field ordering *) + +val compare_field : field -> field -> int + type kind = | Def of bind list * typ | Abs of bind list * typ @@ -50,7 +54,7 @@ type kind = type con_env = kind Con.Env.t (* n-ary argument/result sequences *) - + val seq: typ list -> typ val as_seq : typ -> typ list diff --git a/src/typing.ml b/src/typing.ml index e16b9274aa2..1ac5b7fc277 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -199,7 +199,7 @@ and check_typ' env typ : T.typ = | ObjT (sort, fields) -> check_ids env (List.map (fun (field : typ_field) -> field.it.id) fields); let fs = List.map (check_typ_field env sort.it) fields in - T.Obj (sort.it, List.sort compare fs) + T.Obj (sort.it, List.sort T.compare_field fs) | ParT typ -> check_typ env typ @@ -928,7 +928,7 @@ and infer_exp_fields env s id t fields : T.field list * val_env = let env' = add_val env id t in let tfs, ve = List.fold_left (infer_exp_field env' s) ([], T.Env.empty) fields in - List.sort compare tfs, ve + List.sort T.compare_field tfs, ve and is_func_exp exp = match exp.it with From 50306dfc61ee19fbc5be404773f416c635bf7a90 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 23 Jan 2019 14:49:58 +0000 Subject: [PATCH 24/45] trivial code fixes --- src/arrange_ir.ml | 8 ++++---- src/check_ir.ml | 11 +++-------- src/ir.ml | 25 ++++++++++++------------- src/pipeline.ml | 9 +-------- src/syntax.ml | 26 +++++++++++++++----------- 5 files changed, 35 insertions(+), 44 deletions(-) diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index e298878e5d0..56fc9253719 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -1,12 +1,12 @@ open Source -open Arrange_type (* currently not used *) +open Arrange_type (* currently not used *) open Ir open Wasm.Sexpr -(* for concision, we shadow the imported definition of [Array_type.typ] and pretty print types instead *) - +(* for concision, we shadow the imported definition of [Arrange_type.typ] and pretty print types instead *) + let typ t = Atom (Type.string_of_typ t) -let kind k = Atom (Type.string_of_kind k) +let kind k = Atom (Type.string_of_kind k) let rec exp e = match e.it with | VarE i -> "VarE" $$ [id i] diff --git a/src/check_ir.ml b/src/check_ir.ml index e0c406e89c0..36654709ec6 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -2,8 +2,6 @@ open Source module T = Type module E = Effect -(* TODO: fix uses of List.sort compare etc on fields rather than field names *) - (* TODO: remove DecE from syntax, replace by BlockE [dec] *) (* TODO: check constraint matching supports recursive bounds *) @@ -161,7 +159,7 @@ let rec check_typ env typ : unit = let ts2 = List.map (T.open_ ts) ts2 in List.iter (check_typ env') ts1; List.iter (check_typ env') ts2; - if (control = T.Promises) then begin + if control = T.Promises then begin match ts2 with | [T.Async _ ] -> () | _ -> @@ -254,7 +252,7 @@ and check_inst_bounds env tbs typs at = (* Literals *) let infer_lit env lit at : T.prim = - Syntax.( (* yuck *) + let open Syntax in match lit with | NullLit -> T.Null | BoolLit _ -> T.Bool @@ -269,10 +267,9 @@ let infer_lit env lit at : T.prim = | TextLit _ -> T.Text | PreLit (s,p) -> error env at "unresolved literal %s of type\n %s" s (T.string_of_prim p) - ) let check_lit env t lit at = - Syntax.( + let open Syntax in match T.normalize env.cons t, lit with | T.Opt _, NullLit -> () | t, _ -> @@ -280,8 +277,6 @@ let check_lit env t lit at = if not (T.sub env.cons t' t) then error env at "literal of type\n %s\ndoes not have expected type\n %s" (T.string_of_typ t') (T.string_of_typ_expand env.cons t) - ) - open Ir (* Expressions *) diff --git a/src/ir.ml b/src/ir.ml index 2b30b4481d4..27ca2811ab5 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -1,12 +1,10 @@ (* Patterns *) -(* TODO: replace Syntax.typ_bind *) - -type 'a phrase = ('a,Syntax.typ_note) Source.annotated_phrase +type 'a phrase = ('a, Syntax.typ_note) Source.annotated_phrase type typ_bind = (Type.bind, Type.typ) Source.annotated_phrase -type pat = (pat',Type.typ) Source.annotated_phrase +type pat = (pat', Type.typ) Source.annotated_phrase and pat' = | WildP (* wildcard *) | VarP of Syntax.id (* variable *) @@ -31,7 +29,7 @@ and exp' = | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) | ActorE of (* actor *) - Syntax.id * exp_field list * Type.typ + Syntax.id * exp_field list * Type.typ | DotE of exp * Syntax.name (* object projection *) | ActorDotE of exp * Syntax.name (* actor field access *) | AssignE of exp * exp (* assignment *) @@ -52,9 +50,9 @@ and exp' = | AwaitE of exp (* await *) | AssertE of exp (* assertion *) | IsE of exp * exp (* instance-of *) - | DeclareE of Syntax.id * Type.typ * exp (* local promise (internal) *) - | DefineE of Syntax.id * Syntax.mut * exp (* promise fulfillment (internal) *) - | NewObjE of (* make an object, preserving mutable identity (internal) *) + | DeclareE of Syntax.id * Type.typ * exp (* local promise *) + | DefineE of Syntax.id * Syntax.mut * exp (* promise fulfillment *) + | NewObjE of (* make an object, preserving mutable identity *) Syntax.obj_sort * (Syntax.name * Syntax.id) list * Type.typ and exp_field = exp_field' Source.phrase @@ -68,11 +66,12 @@ and case' = {pat : pat; exp : exp} and dec = dec' phrase and dec' = - | ExpD of exp (* plain expression *) - | LetD of pat * exp (* immutable *) - | VarD of Syntax.id * exp (* mutable *) - | FuncD of Value.call_conv * Syntax.id * typ_bind list * pat * Type.typ * exp (* function *) - | TypD of Type.con * Type.kind (* type *) + | ExpD of exp (* plain expression *) + | LetD of pat * exp (* immutable *) + | VarD of Syntax.id * exp (* mutable *) + | FuncD of (* function *) + Value.call_conv * Syntax.id * typ_bind list * pat * Type.typ * exp + | TypD of Type.con * Type.kind (* type *) (* Program *) diff --git a/src/pipeline.ml b/src/pipeline.ml index 25512304cdc..5d68bc18f4c 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -244,14 +244,7 @@ let output_scope (senv, _) t v sscope dscope = let is_exp dec = match dec.Source.it with Syntax.ExpD _ -> true | _ -> false let run_with interpret output ((senv, denv) as env) name : run_result = - let result = interpret env name in (* - begin match Type.as_immut (Type.promote ce (e.Source.note.S.note_typ)) with - | Type.Obj (Type.Actor, _) -> I.ActorDotE (exp ce e, n) - | Type.Obj (_, _) | Type.Array _ -> I.DotE (exp ce e, n) - | Type.Con _ -> raise (Invalid_argument ("Con in promoted type")) - | _ -> raise (Invalid_argument ("non-object in dot operator")) - end *) - + let result = interpret env name in let env' = match result with | None -> diff --git a/src/syntax.ml b/src/syntax.ml index 75a4132cfbe..c77a6df2bee 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -138,7 +138,7 @@ and exp' = | ProjE of exp * int (* tuple projection *) | OptE of exp (* option injection *) | ObjE of obj_sort * id * exp_field list (* object *) - | DotE of exp * Type.obj_sort ref * name (* object projection *) + | DotE of exp * Type.obj_sort ref * name (* object projection *) | AssignE of exp * exp (* assignment *) | ArrayE of mut * exp list (* array *) | IdxE of exp * exp (* array indexing *) @@ -182,12 +182,15 @@ and case' = {pat : pat; exp : exp} and dec = (dec', typ_note) Source.annotated_phrase and dec' = - | ExpD of exp (* plain expression *) - | LetD of pat * exp (* immutable *) - | VarD of id * exp (* mutable *) - | FuncD of sharing * id * typ_bind list * pat * typ * exp (* function *) - | TypD of con_id * typ_bind list * typ (* type *) - | ClassD of id (*term id*) * con_id (*type id*) * typ_bind list * obj_sort * pat * id * exp_field list (* class *) + | ExpD of exp (* plain expression *) + | LetD of pat * exp (* immutable *) + | VarD of id * exp (* mutable *) + | FuncD of (* function *) + sharing * id * typ_bind list * pat * typ * exp +(* function *) + | TypD of con_id * typ_bind list * typ (* type *) + | ClassD of (* class *) + id * con_id * typ_bind list * obj_sort * pat * id * exp_field list (* Program *) @@ -201,10 +204,11 @@ and prog' = dec list let seqT ts = match ts with | [t] -> t - | ts -> {Source.it = TupT ts; - at = Source.no_region; - Source.note = Type.Tup (List.map (fun t -> t.Source.note) ts)} - + | ts -> + {Source.it = TupT ts; + at = Source.no_region; + Source.note = Type.Tup (List.map (fun t -> t.Source.note) ts)} + let as_seqT t = match t.Source.it with | TupT ts -> ts From 82eea3fad4a749d0bf89885aa95dc0b0b33df454 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 23 Jan 2019 15:27:37 +0000 Subject: [PATCH 25/45] remove unfold_obj in favour of Type.promote --- src/check_ir.ml | 21 ++++++--------------- src/ir.ml | 2 +- src/syntax.ml | 3 +-- 3 files changed, 8 insertions(+), 18 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 36654709ec6..633a4243922 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -75,19 +75,6 @@ let error env at fmt = let warn env at fmt = Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_warning at s)) fmt - -let unfold_obj env t at = - match t with - | T.Obj (_,_) -> t - | T.Con (c,ts) -> - begin - match Con.Env.find_opt c env.cons with - | Some T.Abs (tbs, (T.Obj(_,_) as t2)) -> - T.open_ ts t2 - | _ -> error env at "bad annotation %s (wrong kind)" (T.string_of_typ t) - end - | _ -> error env at "bad annotation %s (wrong form)" (T.string_of_typ t) - let add_lab c x t = {c with labs = T.Env.add x t c.labs} let add_val c x t = {c with vals = T.Env.add x t c.vals} @@ -392,7 +379,9 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | ActorE ( id, fields, t) -> let env' = { env with async = false } in let t1 = infer_obj env' T.Actor id fields in - let t2 = unfold_obj env t exp.at in + let t2 = T.promote env.cons t in + if not (T.is_obj t2) then + error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); if T.sub env.cons t1 t2 then t else @@ -588,7 +577,9 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = T.Obj(sort.it, List.sort T.compare_field (List.map (fun (name,id) -> {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in - let t2 = unfold_obj env t exp.at in + let t2 = T.promote env.cons t in + if not (T.is_obj t2) then + error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); if T.sub env.cons t1 t2 then t else diff --git a/src/ir.ml b/src/ir.ml index 27ca2811ab5..a6fed1e0286 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -70,7 +70,7 @@ and dec' = | LetD of pat * exp (* immutable *) | VarD of Syntax.id * exp (* mutable *) | FuncD of (* function *) - Value.call_conv * Syntax.id * typ_bind list * pat * Type.typ * exp + Value.call_conv * Syntax.id * typ_bind list * pat * Type.typ * exp | TypD of Type.con * Type.kind (* type *) diff --git a/src/syntax.ml b/src/syntax.ml index c77a6df2bee..2a57b3d08dc 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -187,7 +187,6 @@ and dec' = | VarD of id * exp (* mutable *) | FuncD of (* function *) sharing * id * typ_bind list * pat * typ * exp -(* function *) | TypD of con_id * typ_bind list * typ (* type *) | ClassD of (* class *) id * con_id * typ_bind list * obj_sort * pat * id * exp_field list @@ -208,7 +207,7 @@ let seqT ts = {Source.it = TupT ts; at = Source.no_region; Source.note = Type.Tup (List.map (fun t -> t.Source.note) ts)} - + let as_seqT t = match t.Source.it with | TupT ts -> ts From 394e0235fd70a1405c3831e94a4da5f1822b65da Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 00:00:48 +0000 Subject: [PATCH 26/45] WIP, simplify check_ir to do less inference using annotations (or, in future, more type info) --- src/check_ir.ml | 159 +++++++++++++++++++++++------------------------- 1 file changed, 77 insertions(+), 82 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 633a4243922..87b6226a812 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -10,6 +10,11 @@ module E = Effect (* Error bookkeeping *) +(* TODO: + check (type) environments well-formed before possible use + restore checks on functions, + remove redundant pat code, + open code review issues *) (* Recovering from errors *) exception Recover @@ -210,7 +215,7 @@ and check_typ_binds env typ_binds : T.con list * con_env = let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in let _pre_env' = add_typs {env with pre = true} cs pre_ks in let bds = List.map (fun typ_bind -> let t = T.open_ ts typ_bind.T.bound in - (* check_typ pre_env' t; *) + check_typ _pre_env' t; t) typ_binds in let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in let env' = add_typs env cs ks in @@ -282,7 +287,7 @@ and infer_exp_promote env exp : T.typ = and infer_exp_mut env exp : T.typ = let t = infer_exp' env exp in - if not env.pre then begin + begin (* TODO: enable me one infer_effect works on Ir nodes... let e = E.infer_effect_exp exp in assert (T.Triv < T.Await); @@ -290,12 +295,13 @@ and infer_exp_mut env exp : T.typ = error env exp.at "inferred effect not a subtype of expected effect" end; *) - if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then begin (*TBR*) - error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ exp)) - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - end + if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then + begin (*TBR*) + error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons (E.typ exp)) + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) + end end; E.typ exp; @@ -306,7 +312,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | VarE id -> (match T.Env.find_opt id.it env.vals with | Some T.Pre -> - error env id.at "cannot infer type of forward variable %s" id.it; + assert false (* error env id.at "cannot infer type of forward variable %s" id.it; *) | Some t -> t | None -> error env id.at "unbound variable %s" id.it ) @@ -316,7 +322,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = infer_exp_promote env exp1 in (* Special case for subtyping *) let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in - if not env.pre then begin + begin if not (Operator.has_unop t op) then error env exp.at "operator is not defined for operand type\n %s" (T.string_of_typ_expand env.cons t); @@ -330,7 +336,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in - if not env.pre then begin + begin if not (Operator.has_binop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) @@ -345,7 +351,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = infer_exp_promote env exp1 in let t2 = infer_exp_promote env exp2 in let t = T.lub env.cons t1 t2 in - if not env.pre then begin + begin if not (Operator.has_relop t op) then error env exp.at "operator not defined for operand types\n %s and\n %s" (T.string_of_typ_expand env.cons t1) @@ -378,7 +384,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | ActorE ( id, fields, t) -> let env' = { env with async = false } in - let t1 = infer_obj env' T.Actor id fields in + let t1 = infer_obj env' T.Actor id t fields in let t2 = T.promote env.cons t in if not (T.is_obj t2) then error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); @@ -430,7 +436,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let t1 = infer_exp_promote env exp1 in (try let t = T.as_array_sub env.cons t1 in - if not env.pre then check_exp env T.nat exp2; + check_exp env T.nat exp2; t with Invalid_argument _ -> error env exp1.at "expected array type, but expression produces type\n %s" @@ -442,7 +448,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (try let tbs, t2, t = T.as_func_sub (List.length insts) env.cons t1 in check_inst_bounds env tbs insts exp.at; - if not env.pre then check_exp env (T.open_ insts t2) exp2; + check_exp env (T.open_ insts t2) exp2; T.open_ insts t with Invalid_argument _ -> error env exp1.at "expected function type, but expression produces type\n %s" @@ -459,7 +465,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ t1); t | IfE (exp1, exp2, exp3) -> - if not env.pre then check_exp env T.bool exp1; + check_exp env T.bool exp1; let t2 = infer_exp env exp2 in let t3 = infer_exp env exp3 in let t = T.lub env.cons t2 t3 in @@ -473,19 +479,19 @@ and infer_exp' env (exp:Ir.exp) : T.typ = *) t | WhileE (exp1, exp2) -> - if not env.pre then begin + begin check_exp env T.bool exp1; check_exp env T.unit exp2 end; T.unit | LoopE (exp1, expo) -> - if not env.pre then begin + begin check_exp env T.unit exp1; Lib.Option.app (check_exp env T.bool) expo end; T.Non | ForE (pat, exp1, exp2) -> - if not env.pre then begin + begin let t1 = infer_exp_promote env exp1 in (try let _, tfs = T.as_obj_sub "next" env.cons t1 in @@ -503,13 +509,13 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.unit | LabelE (id, typ, exp1) -> let t = check_typ env typ;typ in - if not env.pre then check_exp (add_lab env id.it typ) t exp1; + check_exp (add_lab env id.it typ) t exp1; t | BreakE (id, exp1) -> (match T.Env.find_opt id.it env.labs with | Some t -> - if not env.pre then check_exp env t exp1 - | None -> + check_exp env t exp1 + | None -> (* TODO: fix me *) let name = match String.split_on_char ' ' id.it with | ["continue"; name] -> name @@ -518,10 +524,10 @@ and infer_exp' env (exp:Ir.exp) : T.typ = ); T.Non | RetE exp1 -> - if not env.pre then begin + begin match env.rets with | Some T.Pre -> - local_error env exp.at "cannot infer return type" + assert false; (* local_error env exp.at "cannot infer return type" *) | Some t -> check_exp env t exp1 | None -> @@ -530,7 +536,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.Non | AsyncE exp1 -> let env' = - {env with labs = T.Env.empty; rets = Some T.Pre; async = true} in + {env with labs = T.Env.empty; rets = Some (* T.Pre *) exp1.note.Syntax.note_typ; async = true} in let t = infer_exp env' exp1 in if not (T.sub env.cons t T.Shared) then error env exp1.at "async type has non-shared parameter type\n %s" @@ -547,11 +553,11 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ_expand env.cons t1) ) | AssertE exp1 -> - if not env.pre then check_exp env T.bool exp1; + check_exp env T.bool exp1; T.unit | IsE (exp1, exp2) -> (* TBR: restrict t1 to objects? *) - if not env.pre then begin + begin let _t1 = infer_exp env exp1 in check_exp env T.Class exp2 end; @@ -574,7 +580,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = end; T.unit | NewObjE (sort, labids, t) -> - let t1 = + let t1 = T.Obj(sort.it, List.sort T.compare_field (List.map (fun (name,id) -> {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in let t2 = T.promote env.cons t in @@ -586,7 +592,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = error env no_region "expecting object of type %s, but expression produces %s" (T.string_of_typ_expand env.cons t2) (T.string_of_typ_expand env.cons t1) - + and check_exp env t exp = let t' = T.normalize env.cons t in check_exp' env t' exp; @@ -626,7 +632,6 @@ and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env t_pat pat in recover (check_exp (adjoin_vals env ve) t) exp - (* Patterns *) and gather_pat env ve0 pat : val_env = @@ -638,7 +643,7 @@ and gather_pat env ve0 pat : val_env = | VarP id -> if T.Env.mem id.it ve0 then error env pat.at "duplicate binding for %s in block" id.it; - T.Env.add id.it T.Pre ve + T.Env.add id.it pat.note ve (*TBR*) | TupP pats -> List.fold_left go ve pats | AltP (pat1, pat2) -> @@ -647,30 +652,26 @@ and gather_pat env ve0 pat : val_env = go ve pat1 in T.Env.adjoin ve0 (go T.Env.empty pat) - - and infer_pat_exhaustive env pat : T.typ * val_env = let t, ve = infer_pat env pat in + (* TODO: actually check exhaustiveness *) t, ve and infer_pat env pat : T.typ * val_env = assert (pat.note <> T.Pre); let t, ve = infer_pat' env pat in - if not env.pre then - if not (T.eq env.cons t pat.note) then - local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons pat.note); + if not (T.eq env.cons t pat.note) then + local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons pat.note); t, ve and infer_pat' env pat : T.typ * val_env = match pat.it with | WildP -> (pat.note, T.Env.empty) - (* error env pat.at "cannot infer type of wildcard" *) | VarP id -> (pat.note, T.Env.singleton id.it pat.note) - (* error env pat.at "cannot infer type of variable" *) | LitP lit -> T.Prim (infer_lit env lit pat.at), T.Env.empty | TupP pats -> @@ -697,18 +698,18 @@ and infer_pats at env pats ts ve : T.typ list * val_env = and check_pat_exhaustive env t pat : val_env = + (* TODO: check exhaustiveness? *) check_pat env t pat and check_pat env t pat : val_env = assert (pat.note <> T.Pre); - if t = T.Pre then snd (infer_pat env pat) else + (* if t = T.Pre then snd (infer_pat env pat) else *) let t' = T.normalize env.cons t in let ve = check_pat' env t pat in - if not env.pre then - if not (T.eq env.cons t' pat.note) then - local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons pat.note); + if not (T.eq env.cons t' pat.note) then + local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons pat.note); ve and check_pat' env t pat : val_env = @@ -761,18 +762,13 @@ and check_pats env ts pats ve at : val_env = (* Objects *) -and infer_obj env s id fields : T.typ = - let pre_ve = gather_exp_fields env id.it fields in - let pre_env = adjoin_vals {env with pre = true} pre_ve in - let tfs, ve = infer_exp_fields pre_env s id.it T.Pre fields in - let t = T.Obj (s, tfs) in - if not env.pre then begin - let env' = adjoin_vals (add_val env id.it t) ve in - ignore (infer_exp_fields env' s id.it t fields) - end; - t - +and infer_obj env s id t fields : T.typ = + let ve = gather_exp_fields env id.it t fields in + let env' = adjoin_vals env ve in + let tfs, _ve = infer_exp_fields env' s id.it t fields in + T.Obj(s,tfs) +(* TBD: and check_obj env s tfs id fields at : T.typ = let pre_ve = gather_exp_fields env id.it fields in let pre_ve' = List.fold_left @@ -790,17 +786,17 @@ and check_obj env s tfs id fields at : T.typ = let env' = adjoin_vals (add_val env id.it t) ve in ignore (infer_exp_fields env' s id.it t fields); t +*) - -and gather_exp_fields env id fields : val_env = - let ve0 = T.Env.singleton id T.Pre in +and gather_exp_fields env id t fields : val_env = + let ve0 = T.Env.singleton id t in List.fold_left (gather_exp_field env) ve0 fields and gather_exp_field env ve field : val_env = - let {id; _} : exp_field' = field.it in + let {id; exp ; mut; priv;_} : exp_field' = field.it in if T.Env.mem id.it ve then error env id.at "duplicate field name %s in object" id.it; - T.Env.add id.it T.Pre ve + T.Env.add id.it (infer_mut mut exp.note.Syntax.note_typ) ve and infer_exp_fields env s id t fields : T.field list * val_env = @@ -824,21 +820,20 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = let t = match T.Env.find id.it env.vals with | T.Pre -> - infer_mut mut (infer_exp (adjoin_vals env ve) exp) + assert false (* infer_mut mut (infer_exp (adjoin_vals env ve) exp) *) | t -> - (* When checking object in analysis mode *) - if not env.pre then begin + begin check_exp (adjoin_vals env ve) (T.as_immut t) exp; if (mut.it = Syntax.Var) <> T.is_mut t then local_error env field.at "%smutable field %s cannot produce expected %smutable field of type\n %s" - (if mut .it = Syntax.Var then "" else "im") id.it + (if mut.it = Syntax.Var then "" else "im") id.it (if T.is_mut t then "" else "im") (T.string_of_typ_expand env.cons (T.as_immut t)) end; t in - if not env.pre then begin + begin if s = T.Actor && priv.it = Syntax.Public && not (is_func_exp exp) then error env field.at "public actor field is not a function"; if s <> T.Object T.Local && priv.it = Syntax.Public && not (T.sub env.cons t T.Shared) then @@ -890,7 +885,7 @@ and infer_dec env dec : T.typ = T.unit | FuncD (sort, id, typ_binds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in - if not env.pre then begin + begin let _cs,ce = check_open_typ_binds env typ_binds in let env' = adjoin_typs env ce in let _, ve = infer_pat_exhaustive env' pat in @@ -975,15 +970,8 @@ and check_dec env t dec = and infer_block_decs env decs : scope = let scope = gather_block_typdecs env decs in - let env' = adjoin {env with pre = true} scope in - let ce = infer_block_typdecs env' decs in - let env'' = adjoin env { scope with con_env = ce } in - let _ce' = infer_block_typdecs env'' decs in - (* TBR: assertion does not work for types with binders, due to stamping *) - (* assert (ce = ce'); *) - let pre_ve' = gather_block_valdecs env decs in - let ve = infer_block_valdecs (adjoin_vals env'' pre_ve') decs in - { val_env = ve; con_env = ce } + let ve = gather_block_valdecs env decs in + { val_env = ve; con_env = scope.con_env } (* Pass 1: collect type identifiers and their arity *) @@ -999,8 +987,7 @@ and gather_dec_typdecs env scope dec : scope = let ce' = Con.Env.add c k scope.con_env in {scope with con_env = ce'} - - +(* TBD (* Pass 2 and 3: infer type definitions *) and infer_block_typdecs env decs : con_env = let _env', ce = @@ -1026,6 +1013,7 @@ and infer_dec_typdecs env dec : con_env = check_typ env' (T.open_ ts typ); Con.Env.singleton c k + *) (* Pass 4: collect value identifiers *) and gather_block_valdecs env decs : val_env = List.fold_left (gather_dec_valdecs env) T.Env.empty decs @@ -1036,12 +1024,16 @@ and gather_dec_valdecs env ve dec : val_env = ve | LetD (pat, _) -> gather_pat env ve pat - | VarD (id, _) | FuncD (_, id, _, _, _, _) -> + | VarD (id, exp) -> if T.Env.mem id.it ve then error env dec.at "duplicate definition for %s in block" id.it; - T.Env.add id.it T.Pre ve - + T.Env.add id.it (T.Mut exp.note.Syntax.note_typ) ve + | FuncD (_, id, _, _, _, _) -> + if T.Env.mem id.it ve then + error env dec.at "duplicate definition for %s in block" id.it; + T.Env.add id.it dec.note.Syntax.note_typ ve +(* (* Pass 5: infer value types *) and infer_block_valdecs env decs : val_env = let _, ve = @@ -1050,7 +1042,9 @@ and infer_block_valdecs env decs : val_env = adjoin_vals env ve', T.Env.adjoin ve ve' ) (env, T.Env.empty) decs in ve + *) +(* TODO: restore some of these checks elsewhere then delete *) and infer_dec_valdecs env dec : val_env = match dec.it with | ExpD _ -> @@ -1105,6 +1099,7 @@ and infer_dec_valdecs env dec : val_env = | TypD _ -> T.Env.empty + (* Programs *) let check_prog scope prog : scope Diag.result = From b0814dc6cb2d65ed2ac67a9a19f81600577902d6 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 11:04:46 +0000 Subject: [PATCH 27/45] ir checker: remove redundant pat code --- src/check_ir.ml | 45 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 87b6226a812..d827e4b7d29 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -13,8 +13,11 @@ module E = Effect (* TODO: check (type) environments well-formed before possible use restore checks on functions, - remove redundant pat code, - open code review issues *) + open code review issues + place where we access Syntax.note_typ or .note are good places to consider add type info to + IR.exp' constructor (e.g. identifier bindings and PrimE) so that we can remove the type notes. + remove the many begin/ends; rework operators if nec. + *) (* Recovering from errors *) exception Recover @@ -419,7 +422,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ_expand env.cons t1) ) | AssignE (exp1, exp2) -> - if not env.pre then begin + begin let t1 = infer_exp_mut env exp1 in try let t2 = T.as_mut t1 in @@ -660,8 +663,8 @@ and infer_pat_exhaustive env pat : T.typ * val_env = and infer_pat env pat : T.typ * val_env = assert (pat.note <> T.Pre); let t, ve = infer_pat' env pat in - if not (T.eq env.cons t pat.note) then - local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" + if not (T.sub env.cons pat.note t) then (* TBR: should we allow contra-variance ?*) + local_error env pat.at "pattern of type \n %s\n cannot consume expected type \n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons pat.note); t, ve @@ -673,7 +676,12 @@ and infer_pat' env pat : T.typ * val_env = | VarP id -> (pat.note, T.Env.singleton id.it pat.note) | LitP lit -> - T.Prim (infer_lit env lit pat.at), T.Env.empty + let t = T.Prim (infer_lit env lit pat.at) in + if not (T.sub env.cons t pat.note) then (* TBR isn't this test the wrong way around? *) + error env pat.at "type of literal pattern \n %s\n cannot produce expected type \n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons pat.note); + (pat.note, T.Env.empty) | TupP pats -> let ts, ve = infer_pats pat.at env pats [] T.Env.empty in T.Tup ts, ve @@ -701,6 +709,17 @@ and check_pat_exhaustive env t pat : val_env = (* TODO: check exhaustiveness? *) check_pat env t pat +and check_pat env t pat : val_env = + assert (pat.note <> T.Pre); + let (t,ve) = infer_pat env pat in + let t' = T.normalize env.cons t in + if not (T.sub env.cons t t') then + local_error env pat.at "type of pattern \n %s\n cannot consume expected type \n %s" + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons pat.note); + ve + +(* and check_pat env t pat : val_env = assert (pat.note <> T.Pre); (* if t = T.Pre then snd (infer_pat env pat) else *) @@ -720,7 +739,7 @@ and check_pat' env t pat : val_env = | VarP id -> T.Env.singleton id.it t | LitP lit -> - if not env.pre then check_lit env t lit pat.at; + check_lit env t lit pat.at; T.Env.empty | TupP pats -> (try @@ -758,7 +777,7 @@ and check_pats env ts pats ve at : val_env = | ts, [] -> error env at "tuple pattern has %i more components than expected type" (List.length ts) - + *) (* Objects *) @@ -860,7 +879,7 @@ and infer_block_exps env decs : T.typ = | [] -> T.unit | [dec] -> infer_dec env dec | dec::decs' -> - if not env.pre then recover (check_dec env T.unit) dec; + recover (check_dec env T.unit) dec; recover_with T.Non (infer_block_exps env) decs' and check_open_typ_binds env typ_binds = @@ -881,7 +900,7 @@ and infer_dec env dec : T.typ = | ExpD exp -> infer_exp env exp | LetD (_, exp) | VarD (_, exp) -> - if not env.pre then ignore (infer_exp env exp); + ignore (infer_exp env exp); T.unit | FuncD (sort, id, typ_binds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in @@ -930,6 +949,7 @@ and check_block_exps env t decs at = recover (check_block_exps env t decs') at and check_dec env t dec = +(* TBD match dec.it with | ExpD exp -> check_exp env t exp; @@ -960,7 +980,8 @@ and check_dec env t dec = (T.string_of_typ t) ) *) - | _ -> + | _ -> +*) let t' = infer_dec env dec in (* TBR: special-case unit? *) if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then @@ -969,6 +990,7 @@ and check_dec env t dec = (T.string_of_typ_expand env.cons t') and infer_block_decs env decs : scope = +(* todo: unify gathering into single pass *) let scope = gather_block_typdecs env decs in let ve = gather_block_valdecs env decs in { val_env = ve; con_env = scope.con_env } @@ -978,6 +1000,7 @@ and infer_block_decs env decs : scope = and gather_block_typdecs env decs : scope = List.fold_left (gather_dec_typdecs env) empty_scope decs + and gather_dec_typdecs env scope dec : scope = match dec.it with | ExpD _ | LetD _ | VarD _ | FuncD _ -> scope From e443d6757e1a45de00d36c244c34f93290588fc5 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 11:43:56 +0000 Subject: [PATCH 28/45] restore checks on FuncD and DecD --- src/check_ir.ml | 101 ++++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 51 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index d827e4b7d29..91bd9df92e8 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -882,14 +882,17 @@ and infer_block_exps env decs : T.typ = recover (check_dec env T.unit) dec; recover_with T.Non (infer_block_exps env) decs' -and check_open_typ_binds env typ_binds = - let cs = List.map (fun tp -> match tp.note with - | T.Con(c,[]) -> c - | _ -> assert false (* TODO: remove me by tightening note to Con.t *) +and cons_of_typ_binds typ_binds = + List.map (fun tp -> match tp.note with + | T.Con(c,[]) -> c + | _ -> assert false (* TODO: remove me by tightening note to Con.t *) + + ) typ_binds - ) typ_binds in +and check_open_typ_binds env typ_binds = + let cs = cons_of_typ_binds typ_binds in let ks = List.map (fun tp -> T.Abs([],tp.it.T.bound)) typ_binds in - let ce = List.fold_right2 Con.Env.add cs ks Con.Env.empty in + let ce = List.fold_right2 Con.Env.add cs ks Con.Env.empty in let binds = T.close_binds cs (List.map (fun tb -> tb.it) typ_binds) in let _,_ = check_typ_binds env binds in cs,ce @@ -904,18 +907,25 @@ and infer_dec env dec : T.typ = T.unit | FuncD (sort, id, typ_binds, pat, typ, exp) -> let t = T.Env.find id.it env.vals in - begin - let _cs,ce = check_open_typ_binds env typ_binds in - let env' = adjoin_typs env ce in - let _, ve = infer_pat_exhaustive env' pat in - check_typ env' typ; - let env'' = - {env' with labs = T.Env.empty; rets = Some typ; async = false} in - check_exp (adjoin_vals env'' ve) typ exp - end; + let _cs,ce = check_open_typ_binds env typ_binds in + let env' = adjoin_typs env ce in + let t1, ve = infer_pat_exhaustive env' pat in + check_typ env' typ; + let env'' = + {env' with labs = T.Env.empty; rets = Some typ; async = false} in + check_exp (adjoin_vals env'' ve) typ exp; t - | TypD _ -> - T.unit + | TypD (c, k) -> + let (binds,typ) = + match k with + | T.Abs(binds,typ) + | T.Def(binds,typ) -> (binds,typ) + in + let cs,ce = check_typ_binds env binds in + let ts = List.map (fun c -> T.Con(c,[])) cs in + let env' = adjoin_typs env ce in + check_typ env' (T.open_ ts typ); + T.unit in if not (Type.sub env.cons t (E.typ dec)) then begin error env dec.at "inferred dec type %s not a subtype of expected type %s" @@ -949,39 +959,6 @@ and check_block_exps env t decs at = recover (check_block_exps env t decs') at and check_dec env t dec = -(* TBD - match dec.it with - | ExpD exp -> - check_exp env t exp; - if not (T.eq env.cons exp.note.Syntax.note_typ dec.note.Syntax.note_typ) then - local_error env dec.at "unequal type of expression \n %s\n in declaration \n %s" - (T.string_of_typ_expand env.cons exp.note.Syntax.note_typ) - (T.string_of_typ_expand env.cons dec.note.Syntax.note_typ) -(* TBR: push in external type annotation; - unfortunately, this isn't enough, because of the earlier recursive phases - | FuncD (id, [], pat, typ, exp) -> - (* TBR: special-case unit? *) - if T.eq env.cons t T.unit then - ignore (infer_dec env dec) - else - (match T.nonopt env.cons t with - | T.Func ([], t1, t2)-> - let ve = check_pat env t1 pat in - let t2' = check_typ env typ in - (* TBR: infer return type *) - if not (T.eq env.cons t2 t2') then - error dec.at "expected return type %s but found %s" - (T.string_of_typ t2) (T.string_of_typ t2'); - let env' = - {env with labs = T.Env.empty; rets = Some t2; async = false} in - check_exp (adjoin_vals env' ve) t2 exp - | _ -> - error exp.at "function expression cannot produce expected type %s" - (T.string_of_typ t) - ) - *) - | _ -> -*) let t' = infer_dec env dec in (* TBR: special-case unit? *) if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then @@ -1051,11 +1028,33 @@ and gather_dec_valdecs env ve dec : val_env = if T.Env.mem id.it ve then error env dec.at "duplicate definition for %s in block" id.it; T.Env.add id.it (T.Mut exp.note.Syntax.note_typ) ve +(* | FuncD (_, id, _, _, _, _) -> if T.Env.mem id.it ve then error env dec.at "duplicate definition for %s in block" id.it; T.Env.add id.it dec.note.Syntax.note_typ ve - + *) + | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> + let func_sort = call_conv.Value.sort in + let cs = cons_of_typ_binds typ_binds in + let t1 = pat.note in + let t2 = typ in + let ts1 = match call_conv.Value.n_args with + | 1 -> [t1] + | _ -> T.as_seq t1 + in + let ts2 = match call_conv.Value.n_res with + | 1 -> [t2] + | _ -> T.as_seq t2 + in + let c = match func_sort, t2 with + | T.Call T.Sharable, (T.Async _) -> T.Promises (* TBR: do we want this for T.Local too? *) + | _ -> T.Returns + in + let ts = List.map (fun typbind -> typbind.it.T.bound) typ_binds in + let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in + let t = T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) in + T.Env.add id.it t ve (* (* Pass 5: infer value types *) and infer_block_valdecs env decs : val_env = From 3c93dc82ff338306a31c0c52e3bd7f3c225a38ea Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 12:15:32 +0000 Subject: [PATCH 29/45] gather block scope in a single pass; remove commented out code --- src/check_ir.ml | 264 +++++++----------------------------------------- 1 file changed, 37 insertions(+), 227 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 91bd9df92e8..eac4569f24b 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -11,11 +11,10 @@ module E = Effect (* Error bookkeeping *) (* TODO: - check (type) environments well-formed before possible use - restore checks on functions, open code review issues - place where we access Syntax.note_typ or .note are good places to consider add type info to - IR.exp' constructor (e.g. identifier bindings and PrimE) so that we can remove the type notes. + place where we access Syntax.note_typ or pat.note are good places to considering + add type info to IR.exp' constructors + (e.g. identifier bindings and PrimE) so that we can remove the type notes altogether. remove the many begin/ends; rework operators if nec. *) (* Recovering from errors *) @@ -274,6 +273,7 @@ let check_lit env t lit at = (T.string_of_typ t') (T.string_of_typ_expand env.cons t) open Ir + (* Expressions *) let isAsyncE exp = @@ -601,12 +601,12 @@ and check_exp env t exp = check_exp' env t' exp; and check_exp' env t exp = - let t' = infer_exp env exp in - if not (T.sub env.cons t' t) then - local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons t) + let t' = infer_exp env exp in + if not (T.sub env.cons t' t) then + local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons t) (* Cases *) @@ -719,65 +719,6 @@ and check_pat env t pat : val_env = (T.string_of_typ_expand env.cons pat.note); ve -(* -and check_pat env t pat : val_env = - assert (pat.note <> T.Pre); - (* if t = T.Pre then snd (infer_pat env pat) else *) - let t' = T.normalize env.cons t in - let ve = check_pat' env t pat in - if not (T.eq env.cons t' pat.note) then - local_error env pat.at "unequal type of pattern \n %s\n and annotation \n %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons pat.note); - ve - -and check_pat' env t pat : val_env = - assert (t <> T.Pre); - match pat.it with - | WildP -> - T.Env.empty - | VarP id -> - T.Env.singleton id.it t - | LitP lit -> - check_lit env t lit pat.at; - T.Env.empty - | TupP pats -> - (try - let ts = T.as_tup_sub (List.length pats) env.cons t in - check_pats env ts pats T.Env.empty pat.at - with Invalid_argument _ -> - error env pat.at "tuple pattern cannot consume expected type\n %s" - (T.string_of_typ_expand env.cons t) - ) - | OptP pat1 -> - (try - let t1 = T.as_opt t in - check_pat env t1 pat1 - with Invalid_argument _ -> - error env pat.at "option pattern cannot consume expected type\n %s" - (T.string_of_typ_expand env.cons t) - ) - | AltP (pat1, pat2) -> - let ve1 = check_pat env t pat1 in - let ve2 = check_pat env t pat2 in - if ve1 <> T.Env.empty || ve2 <> T.Env.empty then - error env pat.at "variables are not allowed in pattern alternatives"; - T.Env.empty - -and check_pats env ts pats ve at : val_env = - match pats, ts with - | [], [] -> ve - | pat::pats', t::ts -> - let ve1 = check_pat env t pat in - let ve' = disjoint_union env at "duplicate binding for %s in pattern" ve ve1 in - check_pats env ts pats' ve' at - | [], ts -> - local_error env at "tuple pattern has %i fewer components than expected type" - (List.length ts); ve - | ts, [] -> - error env at "tuple pattern has %i more components than expected type" - (List.length ts) - *) (* Objects *) @@ -787,26 +728,6 @@ and infer_obj env s id t fields : T.typ = let tfs, _ve = infer_exp_fields env' s id.it t fields in T.Obj(s,tfs) -(* TBD: -and check_obj env s tfs id fields at : T.typ = - let pre_ve = gather_exp_fields env id.it fields in - let pre_ve' = List.fold_left - (fun ve {T.name; typ = t} -> - if not (T.Env.mem name ve) then - error env at "%s expression without field %s cannot produce expected type\n %s" - (if s = T.Actor then "actor" else "object") name - (T.string_of_typ_expand env.cons t); - T.Env.add name t ve - ) pre_ve tfs - in - let pre_env = adjoin_vals {env with pre = true} pre_ve' in - let tfs', ve = infer_exp_fields pre_env s id.it T.Pre fields in - let t = T.Obj (s, tfs') in - let env' = adjoin_vals (add_val env id.it t) ve in - ignore (infer_exp_fields env' s id.it t fields); - t -*) - and gather_exp_fields env id t fields : val_env = let ve0 = T.Env.singleton id t in List.fold_left (gather_exp_field env) ve0 fields @@ -839,7 +760,7 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = let t = match T.Env.find id.it env.vals with | T.Pre -> - assert false (* infer_mut mut (infer_exp (adjoin_vals env ve) exp) *) + assert false | t -> begin check_exp (adjoin_vals env ve) (T.as_immut t) exp; @@ -870,7 +791,7 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = (* Blocks and Declarations *) and infer_block env decs at : T.typ * scope = - let scope = infer_block_decs env decs in + let scope = gather_block_decs env decs in let t = infer_block_exps (adjoin env scope) decs in t, scope @@ -883,11 +804,12 @@ and infer_block_exps env decs : T.typ = recover_with T.Non (infer_block_exps env) decs' and cons_of_typ_binds typ_binds = - List.map (fun tp -> match tp.note with - | T.Con(c,[]) -> c - | _ -> assert false (* TODO: remove me by tightening note to Con.t *) - - ) typ_binds + let con_of_typ_bind tp = + match tp.note with + | T.Con(c,[]) -> c + | _ -> assert false (* TODO: remove me by tightening note to Con.t *) + in + List.map con_of_typ_bind typ_binds and check_open_typ_binds env typ_binds = let cs = cons_of_typ_binds typ_binds in @@ -942,7 +864,7 @@ and infer_dec env dec : T.typ = E.typ dec and check_block env t decs at : scope = - let scope = infer_block_decs env decs in + let scope = gather_block_decs env decs in check_block_exps (adjoin env scope) t decs at; scope @@ -966,74 +888,21 @@ and check_dec env t dec = (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons t') -and infer_block_decs env decs : scope = -(* todo: unify gathering into single pass *) - let scope = gather_block_typdecs env decs in - let ve = gather_block_valdecs env decs in - { val_env = ve; con_env = scope.con_env } - - -(* Pass 1: collect type identifiers and their arity *) -and gather_block_typdecs env decs : scope = - List.fold_left (gather_dec_typdecs env) empty_scope decs - +and gather_block_decs env decs = + List.fold_left (gather_dec env) empty_scope decs -and gather_dec_typdecs env scope dec : scope = +and gather_dec env scope dec : scope = match dec.it with - | ExpD _ | LetD _ | VarD _ | FuncD _ -> scope - | TypD (c, k) -> - if Con.Env.mem c scope.con_env then - error env dec.at "duplicate definition for type %s in block" (Con.to_string c); - let ce' = Con.Env.add c k scope.con_env in - {scope with con_env = ce'} - -(* TBD -(* Pass 2 and 3: infer type definitions *) -and infer_block_typdecs env decs : con_env = - let _env', ce = - List.fold_left (fun (env, ce) dec -> - let ce' = infer_dec_typdecs env dec in - adjoin_cons env ce', Con.Env.adjoin ce ce' - ) (env, Con.Env.empty) decs - in ce - -and infer_dec_typdecs env dec : con_env = - match dec.it with - | ExpD _ | LetD _ | VarD _ | FuncD _ -> - Con.Env.empty - | TypD (c, k) -> - let (binds,typ) = - match k with - | T.Abs(binds,typ) - | T.Def(binds,typ) -> (binds,typ) - in - let cs,ce = check_typ_binds env binds in - let ts = List.map (fun c -> T.Con(c,[])) cs in - let env' = adjoin_typs env ce in - check_typ env' (T.open_ ts typ); - Con.Env.singleton c k - - *) -(* Pass 4: collect value identifiers *) -and gather_block_valdecs env decs : val_env = - List.fold_left (gather_dec_valdecs env) T.Env.empty decs - -and gather_dec_valdecs env ve dec : val_env = - match dec.it with - | ExpD _ | TypD _ -> - ve + | ExpD _ -> + scope | LetD (pat, _) -> - gather_pat env ve pat + let ve = gather_pat env scope.val_env pat in + { scope with val_env = ve} | VarD (id, exp) -> - if T.Env.mem id.it ve then - error env dec.at "duplicate definition for %s in block" id.it; - T.Env.add id.it (T.Mut exp.note.Syntax.note_typ) ve -(* - | FuncD (_, id, _, _, _, _) -> - if T.Env.mem id.it ve then + if T.Env.mem id.it scope.val_env then error env dec.at "duplicate definition for %s in block" id.it; - T.Env.add id.it dec.note.Syntax.note_typ ve - *) + let ve = T.Env.add id.it (T.Mut exp.note.Syntax.note_typ) scope.val_env in + { scope with val_env = ve} | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> let func_sort = call_conv.Value.sort in let cs = cons_of_typ_binds typ_binds in @@ -1054,74 +923,15 @@ and gather_dec_valdecs env ve dec : val_env = let ts = List.map (fun typbind -> typbind.it.T.bound) typ_binds in let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in let t = T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2) in - T.Env.add id.it t ve -(* -(* Pass 5: infer value types *) -and infer_block_valdecs env decs : val_env = - let _, ve = - List.fold_left (fun (env, ve) dec -> - let ve' = infer_dec_valdecs env dec in - adjoin_vals env ve', T.Env.adjoin ve ve' - ) (env, T.Env.empty) decs - in ve - *) - -(* TODO: restore some of these checks elsewhere then delete *) -and infer_dec_valdecs env dec : val_env = - match dec.it with - | ExpD _ -> - T.Env.empty - | LetD (pat, exp) -> - let t = infer_exp {env with pre = true} exp in - let ve' = check_pat_exhaustive env t pat in - ve' - | VarD (id, exp) -> - let t = infer_exp {env with pre = true} exp in - T.Env.singleton id.it (T.Mut t) - | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> - let func_sort = call_conv.Value.sort in - let cs, ce = check_open_typ_binds env typ_binds in - let env' = adjoin_typs env ce in - let t1, _ = infer_pat {env' with pre = true} pat in - check_typ env' typ; - let t2 = typ in - if not env.pre && func_sort = T.Call T.Sharable then begin - if not (T.sub env'.cons t1 T.Shared) then - error env pat.at "shared function has non-shared parameter type\n %s" - (T.string_of_typ_expand env'.cons t1); - begin match t2 with - | T.Tup [] -> () - | T.Async t2 -> - if not (T.sub env'.cons t2 T.Shared) then - error env no_region "shared function has non-shared result type\n %s" - (T.string_of_typ_expand env'.cons t2); - if not (isAsyncE exp) then - error env dec.at "shared function with async type has non-async body" - | _ -> error env no_region "shared function has non-async result type\n %s" - (T.string_of_typ_expand env'.cons t2) - end; - end; - let ts1 = match call_conv.Value.n_args with - | 1 -> [t1] - | _ -> T.as_seq t1 - in - let ts2 = match call_conv.Value.n_res with - | 1 -> [t2] - | _ -> T.as_seq t2 - in - - let c = match func_sort, t2 with - | T.Call T.Sharable, (T.Async _) -> T.Promises (* TBR: do we want this for T.Local too? *) - | _ -> T.Returns - in - let ts = List.map (fun typbind -> typbind.it.T.bound) typ_binds in - let tbs = List.map2 (fun c t -> {T.var = Con.name c; bound = T.close cs t}) cs ts in - T.Env.singleton id.it - (T.Func (func_sort, c, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ts2)) - | TypD _ -> - T.Env.empty - + let ve' = T.Env.add id.it t scope.val_env in + {scope with val_env = ve'} + | TypD (c, k) -> + if Con.Env.mem c scope.con_env then + error env dec.at "duplicate definition for type %s in block" (Con.to_string c); + let ce' = Con.Env.add c k scope.con_env in + {scope with con_env = ce'} + (* Programs *) let check_prog scope prog : scope Diag.result = From b2ded26bdeec0656f9a88e6de2b09770fe4aa19d Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 14:25:20 +0000 Subject: [PATCH 30/45] more checking, less inference, cleanup --- src/check_ir.ml | 122 +++++++++++++++--------------------------------- 1 file changed, 38 insertions(+), 84 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index eac4569f24b..4c7c36daae2 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -309,6 +309,7 @@ and infer_exp_mut env exp : T.typ = E.typ exp; and infer_exp' env (exp:Ir.exp) : T.typ = + let t = E.typ exp in match exp.it with | PrimE _ -> exp.note.Syntax.note_typ (* error env exp.at "cannot infer type of primitive" *) @@ -322,48 +323,26 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | LitE lit -> T.Prim (infer_lit env lit exp.at) | UnE (ot, op, exp1) -> - let t1 = infer_exp_promote env exp1 in - (* Special case for subtyping *) - let t = if t1 = T.Prim T.Nat then T.Prim T.Int else t1 in - begin - if not (Operator.has_unop t op) then - error env exp.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons t); - if not (T.eq env.cons ot t) then - error env exp.at "bad operator annotation, expecting %s, found %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons ot); - end; - t + if not (Operator.has_unop ot op) then + error env exp.at "operator is not defined for operand type\n %s" + (T.string_of_typ_expand env.cons ot); + check_exp env ot exp1; + ot | BinE (ot, exp1, op, exp2) -> - let t1 = infer_exp_promote env exp1 in - let t2 = infer_exp_promote env exp2 in - let t = T.lub env.cons t1 t2 in - begin - if not (Operator.has_binop t op) then - error env exp.at "operator not defined for operand types\n %s and\n %s" - (T.string_of_typ_expand env.cons t1) - (T.string_of_typ_expand env.cons t2); - if not (T.eq env.cons ot t) then - error env exp.at "bad operator annotation, expecting %s, found %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons ot); - end; - t + if not (Operator.has_binop ot op) then + error env exp.at "operator not defined for operand types\n %s and\n %s" + (T.string_of_typ_expand env.cons ot) + (T.string_of_typ_expand env.cons ot); + check_exp env ot exp1; + check_exp env ot exp2; + ot | RelE (ot,exp1, op, exp2) -> - let t1 = infer_exp_promote env exp1 in - let t2 = infer_exp_promote env exp2 in - let t = T.lub env.cons t1 t2 in - begin - if not (Operator.has_relop t op) then - error env exp.at "operator not defined for operand types\n %s and\n %s" - (T.string_of_typ_expand env.cons t1) - (T.string_of_typ_expand env.cons t2); - if not (T.eq env.cons ot t) then - error env exp.at "bad operator annotation, expecting %s, found %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons ot); - end; + if not (Operator.has_relop ot op) then + error env exp.at "operator not defined for operand types\n %s and\n %s" + (T.string_of_typ_expand env.cons ot) + (T.string_of_typ_expand env.cons ot); + check_exp env ot exp1; + check_exp env ot exp2; T.bool | TupE exps -> let ts = List.map (infer_exp env) exps in @@ -469,29 +448,25 @@ and infer_exp' env (exp:Ir.exp) : T.typ = t | IfE (exp1, exp2, exp3) -> check_exp env T.bool exp1; - let t2 = infer_exp env exp2 in - let t3 = infer_exp env exp3 in - let t = T.lub env.cons t2 t3 in + check_exp env t exp2; + check_exp env t exp3; t | SwitchE (exp1, cases) -> let t1 = infer_exp_promote env exp1 in - let t = infer_cases env t1 T.Non cases in + (* let t = infer_cases env t1 T.Non cases in *) (* if not env.pre then if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; *) + check_cases env t1 t cases; t | WhileE (exp1, exp2) -> - begin - check_exp env T.bool exp1; - check_exp env T.unit exp2 - end; + check_exp env T.bool exp1; + check_exp env T.unit exp2; T.unit | LoopE (exp1, expo) -> - begin - check_exp env T.unit exp1; - Lib.Option.app (check_exp env T.bool) expo - end; + check_exp env T.unit exp1; + Lib.Option.app (check_exp env T.bool) expo; T.Non | ForE (pat, exp1, exp2) -> begin @@ -515,16 +490,17 @@ and infer_exp' env (exp:Ir.exp) : T.typ = check_exp (add_lab env id.it typ) t exp1; t | BreakE (id, exp1) -> - (match T.Env.find_opt id.it env.labs with - | Some t -> - check_exp env t exp1 - | None -> (* TODO: fix me *) - let name = - match String.split_on_char ' ' id.it with - | ["continue"; name] -> name + begin + match T.Env.find_opt id.it env.labs with + | Some t -> + check_exp env t exp1 + | None -> (* TODO: fix me *) + let name = + match String.split_on_char ' ' id.it with + | ["continue"; name] -> name | _ -> id.it - in local_error env id.at "unbound label %s" name - ); + in local_error env id.at "unbound label %s" name + end; T.Non | RetE exp1 -> begin @@ -597,10 +573,6 @@ and infer_exp' env (exp:Ir.exp) : T.typ = (T.string_of_typ_expand env.cons t1) and check_exp env t exp = - let t' = T.normalize env.cons t in - check_exp' env t' exp; - -and check_exp' env t exp = let t' = infer_exp env exp in if not (T.sub env.cons t' t) then local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" @@ -611,23 +583,6 @@ and check_exp' env t exp = (* Cases *) -and infer_cases env t_pat t cases : T.typ = - List.fold_left (infer_case env t_pat) t cases - -and infer_case env t_pat t {it = {pat; exp}; at; _} = - let ve = check_pat env t_pat pat in - let t' = recover_with T.Non (infer_exp (adjoin_vals env ve)) exp in - let t'' = T.lub env.cons t t' in - if - t'' = T.Any && - T.promote env.cons t <> T.Any && T.promote env.cons t' <> T.Any - then - warn env at "the switch has type %s because branches have inconsistent types,\nthis case produces type\n %s\nthe previous produce type\n %s" - (T.string_of_typ t'') - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons t'); - t'' - and check_cases env t_pat t cases = List.iter (check_case env t_pat t) cases @@ -733,12 +688,11 @@ and gather_exp_fields env id t fields : val_env = List.fold_left (gather_exp_field env) ve0 fields and gather_exp_field env ve field : val_env = - let {id; exp ; mut; priv;_} : exp_field' = field.it in + let {id; exp; mut; priv;_} : exp_field' = field.it in if T.Env.mem id.it ve then error env id.at "duplicate field name %s in object" id.it; T.Env.add id.it (infer_mut mut exp.note.Syntax.note_typ) ve - and infer_exp_fields env s id t fields : T.field list * val_env = let env' = add_val env id t in let tfs, ve = From 9d2d880983f3e6d998eb86b47f7c8d178a5ba6ba Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 16:02:25 +0000 Subject: [PATCH 31/45] remove pre field from env --- src/check_ir.ml | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 4c7c36daae2..cf9f78997c5 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -56,7 +56,6 @@ type env = labs : lab_env; rets : ret_env; async : bool; - pre : bool; msgs : Diag.msg_store; } @@ -66,7 +65,6 @@ let env_of_scope msgs scope = labs = T.Env.empty; rets = None; async = false; - pre = false; msgs; } @@ -214,26 +212,24 @@ and check_typ_field env s typ_field : unit = and check_typ_binds env typ_binds : T.con list * con_env = let ts,ce = Type.open_binds env.cons typ_binds in let cs = List.map (function T.Con(c,[]) -> c | _ -> assert false) ts in - let pre_ks = List.map (fun c -> T.Abs ([], T.Pre)) cs in - let _pre_env' = add_typs {env with pre = true} cs pre_ks in - let bds = List.map (fun typ_bind -> let t = T.open_ ts typ_bind.T.bound in - check_typ _pre_env' t; - t) typ_binds in let ks = List.map2 (fun c t -> T.Abs ([], t)) cs ts in let env' = add_typs env cs ks in - let _ = List.map (fun bd -> check_typ env' bd) bds in + let _ = List.map + (fun typ_bind -> + let bd = T.open_ ts typ_bind.T.bound in + check_typ env' bd) + typ_binds + in cs, Con.Env.from_list2 cs ks and check_typ_bounds env (tbs : T.bind list) typs at : unit = match tbs, typs with | tb::tbs', typ::typs' -> check_typ env typ; - if not env.pre then begin - if not (T.sub env.cons typ tb.T.bound) then + if not (T.sub env.cons typ tb.T.bound) then local_error env no_region "type argument\n %s\ndoes not match parameter bound\n %s" (T.string_of_typ_expand env.cons typ) - (T.string_of_typ_expand env.cons tb.T.bound) - end; + (T.string_of_typ_expand env.cons tb.T.bound); check_typ_bounds env tbs' typs' at | [], [] -> () | [], _ -> local_error env at "too many type arguments" @@ -297,9 +293,12 @@ and infer_exp_mut env exp : T.typ = if not (e <= E.eff exp) then begin error env exp.at "inferred effect not a subtype of expected effect" end; - *) + *) + (*TBR: it's weird that we need to mask mutability, but I think there's an inconsistency + between the way the type checker annotates l-expressions in checking (never immutable) + vs. inference mode (maybe mutable) *) if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then - begin (*TBR*) + begin error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ exp)) @@ -363,7 +362,6 @@ and infer_exp' env (exp:Ir.exp) : T.typ = error env exp1.at "expected tuple type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) ) - | ActorE ( id, fields, t) -> let env' = { env with async = false } in let t1 = infer_obj env' T.Actor id t fields in @@ -453,7 +451,6 @@ and infer_exp' env (exp:Ir.exp) : T.typ = t | SwitchE (exp1, cases) -> let t1 = infer_exp_promote env exp1 in - (* let t = infer_cases env t1 T.Non cases in *) (* if not env.pre then if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; @@ -498,7 +495,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let name = match String.split_on_char ' ' id.it with | ["continue"; name] -> name - | _ -> id.it + | _ -> id.it in local_error env id.at "unbound label %s" name end; T.Non @@ -543,7 +540,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.bool | DeclareE (id, typ, exp1) -> let env' = adjoin_vals env (T.Env.singleton id.it typ) in - infer_exp env' exp1 + infer_exp env' exp1 | DefineE (id, mut, exp1) -> begin match T.Env.find_opt id.it env.vals with @@ -673,7 +670,6 @@ and check_pat env t pat : val_env = (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons pat.note); ve - (* Objects *) From b90026599f0e8ccb1da122480121585c4252eafd Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 17:05:31 +0000 Subject: [PATCH 32/45] check_ir: fail on first error, no recovery --- src/check_ir.ml | 88 ++++++++++++++++++------------------------------- src/diag.ml | 7 ++-- src/diag.mli | 1 + src/pipeline.ml | 4 +-- 4 files changed, 39 insertions(+), 61 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index cf9f78997c5..e0fec3f5e6b 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -5,25 +5,14 @@ module E = Effect (* TODO: remove DecE from syntax, replace by BlockE [dec] *) (* TODO: check constraint matching supports recursive bounds *) -(* TODO: remove T.pre, desugar ClassD to TypD + FuncD, - make note immutable and remove remaining updates *) - -(* Error bookkeeping *) +(* TODO: make note immutable, perhaps just using type abstraction *) (* TODO: open code review issues - place where we access Syntax.note_typ or pat.note are good places to considering - add type info to IR.exp' constructors - (e.g. identifier bindings and PrimE) so that we can remove the type notes altogether. - remove the many begin/ends; rework operators if nec. - *) -(* Recovering from errors *) - -exception Recover - -let recover_with (x : 'a) (f : 'b -> 'a) (y : 'b) = try f y with Recover -> x -let recover_opt f y = recover_with None (fun y -> Some (f y)) y -let recover f y = recover_with () f y + place where we access Syntax.note_typ or pat.note are good places to considering + add type info to IR.exp' constructors + (e.g. identifier bindings, PrimE, branches) so that we can remove the type notes altogether. +*) (* Scope (the external interface) *) @@ -56,29 +45,23 @@ type env = labs : lab_env; rets : ret_env; async : bool; - msgs : Diag.msg_store; } -let env_of_scope msgs scope = +let env_of_scope scope = { vals = scope.Typing.val_env; cons = scope.Typing.con_env; labs = T.Env.empty; rets = None; async = false; - msgs; } (* More error bookkeeping *) let type_error at text : Diag.message = Diag.{ sev = Diag.Error; at; cat = "IR type"; text } -let type_warning at text : Diag.message = Diag.{ sev = Diag.Warning; at; cat = "IR type"; text } -let local_error env at fmt = - Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_error at s)) fmt let error env at fmt = - Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_error at s); raise Recover) fmt -let warn env at fmt = - Printf.ksprintf (fun s -> Diag.add_msg env.msgs (type_warning at s)) fmt + Printf.ksprintf (fun s -> failwith (Diag.string_of_message (type_error at s))) fmt + let add_lab c x t = {c with labs = T.Env.add x t c.labs} let add_val c x t = {c with vals = T.Env.add x t c.vals} @@ -227,12 +210,12 @@ and check_typ_bounds env (tbs : T.bind list) typs at : unit = | tb::tbs', typ::typs' -> check_typ env typ; if not (T.sub env.cons typ tb.T.bound) then - local_error env no_region "type argument\n %s\ndoes not match parameter bound\n %s" + error env no_region "type argument\n %s\ndoes not match parameter bound\n %s" (T.string_of_typ_expand env.cons typ) (T.string_of_typ_expand env.cons tb.T.bound); check_typ_bounds env tbs' typs' at | [], [] -> () - | [], _ -> local_error env at "too many type arguments" + | [], _ -> error env at "too many type arguments" | _, [] -> error env at "too few type arguments" and check_inst_bounds env tbs typs at = @@ -477,7 +460,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = let ve = check_pat_exhaustive env t2' pat in check_exp (adjoin_vals env ve) T.unit exp2 with Invalid_argument _ -> - local_error env exp1.at "expected iterable type, but expression has type\n %s" + error env exp1.at "expected iterable type, but expression has type\n %s" (T.string_of_typ_expand env.cons t1) ); end; @@ -491,23 +474,19 @@ and infer_exp' env (exp:Ir.exp) : T.typ = match T.Env.find_opt id.it env.labs with | Some t -> check_exp env t exp1 - | None -> (* TODO: fix me *) - let name = - match String.split_on_char ' ' id.it with - | ["continue"; name] -> name - | _ -> id.it - in local_error env id.at "unbound label %s" name + | None -> + in error env id.at "unbound label %s" name end; T.Non | RetE exp1 -> begin match env.rets with | Some T.Pre -> - assert false; (* local_error env exp.at "cannot infer return type" *) + assert false; (* error env exp.at "cannot infer return type" *) | Some t -> check_exp env t exp1 | None -> - local_error env exp.at "misplaced return" + error env exp.at "misplaced return" end; T.Non | AsyncE exp1 -> @@ -572,7 +551,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = and check_exp env t exp = let t' = infer_exp env exp in if not (T.sub env.cons t' t) then - local_error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" + error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons t) @@ -585,7 +564,7 @@ and check_cases env t_pat t cases = and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env t_pat pat in - recover (check_exp (adjoin_vals env ve) t) exp + check_exp (adjoin_vals env ve) t exp (* Patterns *) @@ -616,7 +595,7 @@ and infer_pat env pat : T.typ * val_env = assert (pat.note <> T.Pre); let t, ve = infer_pat' env pat in if not (T.sub env.cons pat.note t) then (* TBR: should we allow contra-variance ?*) - local_error env pat.at "pattern of type \n %s\n cannot consume expected type \n %s" + error env pat.at "pattern of type \n %s\n cannot consume expected type \n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons pat.note); t, ve @@ -666,7 +645,7 @@ and check_pat env t pat : val_env = let (t,ve) = infer_pat env pat in let t' = T.normalize env.cons t in if not (T.sub env.cons t t') then - local_error env pat.at "type of pattern \n %s\n cannot consume expected type \n %s" + error env pat.at "type of pattern \n %s\n cannot consume expected type \n %s" (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons pat.note); ve @@ -715,7 +694,7 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = begin check_exp (adjoin_vals env ve) (T.as_immut t) exp; if (mut.it = Syntax.Var) <> T.is_mut t then - local_error env field.at + error env field.at "%smutable field %s cannot produce expected %smutable field of type\n %s" (if mut.it = Syntax.Var then "" else "im") id.it (if T.is_mut t then "" else "im") @@ -750,8 +729,8 @@ and infer_block_exps env decs : T.typ = | [] -> T.unit | [dec] -> infer_dec env dec | dec::decs' -> - recover (check_dec env T.unit) dec; - recover_with T.Non (infer_block_exps env) decs' + check_dec env T.unit dec; + infer_block_exps env decs' and cons_of_typ_binds typ_binds = let con_of_typ_bind tp = @@ -822,19 +801,19 @@ and check_block_exps env t decs at = match decs with | [] -> if not (T.sub env.cons T.unit t) then - local_error env at "empty block cannot produce expected type\n %s" + error env at "empty block cannot produce expected type\n %s" (T.string_of_typ_expand env.cons t) | [dec] -> check_dec env t dec | dec::decs' -> - recover (check_dec env T.unit) dec; - recover (check_block_exps env t decs') at + check_dec env T.unit dec; + check_block_exps env t decs' at and check_dec env t dec = let t' = infer_dec env dec in (* TBR: special-case unit? *) if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then - local_error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" + error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons t') @@ -881,15 +860,12 @@ and gather_dec env scope dec : scope = let ce' = Con.Env.add c k scope.con_env in {scope with con_env = ce'} - (* Programs *) -let check_prog scope prog : scope Diag.result = - Diag.with_message_store (fun msgs -> - let env = env_of_scope msgs scope in - recover_opt (check_block env T.unit prog.it) prog.at) +let check_prog scope prog : scope = + let env = env_of_scope scope in + check_block env T.unit prog.it prog.at -let infer_prog scope prog : (T.typ * scope) Diag.result = - Diag.with_message_store (fun msgs -> - let env = env_of_scope msgs scope in - recover_opt (infer_block env prog.it) prog.at) +let infer_prog scope prog : (T.typ * scope) = + let env = env_of_scope scope in + infer_block env prog.it prog.at diff --git a/src/diag.ml b/src/diag.ml index cbc30fa7040..377edfecf6f 100644 --- a/src/diag.ml +++ b/src/diag.ml @@ -22,11 +22,14 @@ let has_errors : messages -> bool = let fatal_error at text = { sev = Error; at; cat = "fatal"; text } -let print_message msg = +let string_of_message msg = let label = match msg.sev with | Error -> Printf.sprintf "%s error" msg.cat | Warning -> "warning" in - Printf.eprintf "%s: %s, %s\n%!" (Source.string_of_region msg.at) label msg.text + Printf.sprintf "%s: %s, %s\n" (Source.string_of_region msg.at) label msg.text + +let print_message msg = + Printf.eprintf "%s%!" (string_of_message msg) let print_messages = List.iter print_message diff --git a/src/diag.mli b/src/diag.mli index 18816847990..e07ec356517 100644 --- a/src/diag.mli +++ b/src/diag.mli @@ -13,6 +13,7 @@ type messages = message list val fatal_error : Source.region -> string -> message +val string_of_message : message -> string val print_message : message -> unit val print_messages : messages -> unit diff --git a/src/pipeline.ml b/src/pipeline.ml index 5d68bc18f4c..c9c410f2890 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -291,9 +291,7 @@ let compile_with check mode name : compile_result = let prog = async_lowering true prog name in let prog = tailcall_optimization true prog name in let prog = Desugar.prog prog in - match Check_ir.check_prog initial_stat_env prog with - | Error msgs -> Diag.print_messages msgs; assert (false) - | Ok (_,msgs) -> Diag.print_messages msgs; + (* ignore (Check_ir.check_prog initial_stat_env prog); *) phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ From f1e81e42fca66bf2f9e56ce93f953919818025f7 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 17:39:25 +0000 Subject: [PATCH 33/45] add check for async body, remove check_lit --- src/check_ir.ml | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index e0fec3f5e6b..bcb9c75cd09 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -12,6 +12,8 @@ module E = Effect place where we access Syntax.note_typ or pat.note are good places to considering add type info to IR.exp' constructors (e.g. identifier bindings, PrimE, branches) so that we can remove the type notes altogether. + add type and term predicate to rule out constructs after passes, We could even compose these I guess.... + restore effect inference *) (* Scope (the external interface) *) @@ -241,16 +243,6 @@ let infer_lit env lit at : T.prim = | PreLit (s,p) -> error env at "unresolved literal %s of type\n %s" s (T.string_of_prim p) -let check_lit env t lit at = - let open Syntax in - match T.normalize env.cons t, lit with - | T.Opt _, NullLit -> () - | t, _ -> - let t' = T.Prim (infer_lit env lit at) in - if not (T.sub env.cons t' t) then - error env at "literal of type\n %s\ndoes not have expected type\n %s" - (T.string_of_typ t') (T.string_of_typ_expand env.cons t) - open Ir (* Expressions *) @@ -536,8 +528,11 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.unit | NewObjE (sort, labids, t) -> let t1 = - T.Obj(sort.it, List.sort T.compare_field (List.map (fun (name,id) -> - {T.name = Syntax.string_of_name name.it; T.typ = T.Env.find id.it env.vals}) labids)) in + T.Obj(sort.it, + List.sort T.compare_field (List.map (fun (name,id) -> + {T.name = Syntax.string_of_name name.it; + T.typ = T.Env.find id.it env.vals}) labids)) + in let t2 = T.promote env.cons t in if not (T.is_obj t2) then error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); @@ -837,6 +832,8 @@ and gather_dec env scope dec : scope = let cs = cons_of_typ_binds typ_binds in let t1 = pat.note in let t2 = typ in + if Type.is_async t2 && not (isAsyncE exp) then + error env dec.at "shared function with async type has non-async body" let ts1 = match call_conv.Value.n_args with | 1 -> [t1] | _ -> T.as_seq t1 From be09e7ad62bfdd6a8dad1f14a51486c0138ab945 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 17:44:12 +0000 Subject: [PATCH 34/45] spacing --- src/check_ir.ml | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index bcb9c75cd09..6f971716087 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -171,7 +171,7 @@ let rec check_typ env typ : unit = | T.Obj (sort, fields) -> let rec sorted fields = match fields with - | [] + | [] | [_] -> true | f1::((f2::_) as fields') -> T.compare_field f1 f2 < 0 && sorted fields' @@ -270,10 +270,10 @@ and infer_exp_mut env exp : T.typ = end; *) (*TBR: it's weird that we need to mask mutability, but I think there's an inconsistency - between the way the type checker annotates l-expressions in checking (never immutable) + between the way the type checker annotates l-expressions in checking (never immutable) vs. inference mode (maybe mutable) *) if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then - begin + begin error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ exp)) @@ -466,7 +466,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = match T.Env.find_opt id.it env.labs with | Some t -> check_exp env t exp1 - | None -> + | None -> in error env id.at "unbound label %s" name end; T.Non @@ -805,12 +805,12 @@ and check_block_exps env t decs at = check_block_exps env t decs' at and check_dec env t dec = - let t' = infer_dec env dec in - (* TBR: special-case unit? *) - if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then - error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons t') + let t' = infer_dec env dec in + (* TBR: special-case unit? *) + if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then + error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons t') and gather_block_decs env decs = List.fold_left (gather_dec env) empty_scope decs @@ -860,9 +860,9 @@ and gather_dec env scope dec : scope = (* Programs *) let check_prog scope prog : scope = - let env = env_of_scope scope in - check_block env T.unit prog.it prog.at + let env = env_of_scope scope in + check_block env T.unit prog.it prog.at let infer_prog scope prog : (T.typ * scope) = - let env = env_of_scope scope in - infer_block env prog.it prog.at + let env = env_of_scope scope in + infer_block env prog.it prog.at From f5b5256f7d5398f8a2ce1b56aff50e31d8249996 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 21:15:13 +0000 Subject: [PATCH 35/45] clean up desugarer a little --- src/desugar.ml | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/src/desugar.ml b/src/desugar.ml index 14a0f4d6ff6..dfa8b538d11 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -3,6 +3,8 @@ module S = Syntax module I = Ir module T = Type +(* TODO: clean me up when IrOps available, especially build_obj *) + (* Combinators used in the desguaring *) let bool_lit b : Ir.exp = @@ -91,21 +93,20 @@ let | S.NewObjE (s, fs) -> I.NewObjE (s, fs, note.S.note_typ) and field_to_dec (f : S.exp_field) : Ir.dec = - match f.it.S.mut.it with - | S.Const -> - {it = I.LetD ({it = I.VarP f.it.S.id; at = no_region; - note = f.it.S.exp.note.S.note_typ - }, - exp f.it.S.exp); - at = f.at; - note = { f.it.S.exp.note with S.note_typ = T.unit} - } - | S.Var -> - {it = I.VarD (f.it.S.id, exp f.it.S.exp); - at = f.at; - note = { f.it.S.exp.note with S.note_typ = T.unit} - } - + let {it={S.id;S.exp=e;S.mut;_};at;note} = f in + let d = match mut.it with + | S.Const -> I.LetD ({it = I.VarP id; + at = no_region; + note = e.note.S.note_typ + }, + exp e) + | S.Var -> + I.VarD (id, exp e) + in + { it = d; + at; + note = { e.note with S.note_typ = T.unit} + } and field_to_obj_entry (f : S.exp_field) = match f.it.S.priv.it with | S.Private -> [] From 8a6e2cac73c698a4c0c3966a766bae3eb083e001 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Thu, 24 Jan 2019 22:11:55 +0000 Subject: [PATCH 36/45] add IR effect inference and checking of effects in check-ir; eventually replacing effect inference on source --- src/check_ir.ml | 169 ++++++++++++++++++++++-------------------------- src/effect.ml | 157 +++++++++++++++++++++++++++++++++++--------- src/effect.mli | 16 ++++- 3 files changed, 216 insertions(+), 126 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 6f971716087..66731b61e48 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -149,7 +149,7 @@ let rec check_typ env typ : unit = if not (T.sub env'.cons t1 T.Shared) then error env no_region "shared function has non-shared parameter type\n %s" (T.string_of_typ_expand env'.cons t1); - begin match ts2 with + match ts2 with | [] -> () | [T.Async t2] -> if not (T.sub env'.cons t2 T.Shared) then @@ -157,7 +157,6 @@ let rec check_typ env typ : unit = (T.string_of_typ_expand env'.cons t2); | _ -> error env no_region "shared function has non-async result type\n %s" (T.string_of_typ_expand env'.cons (T.seq ts2)) - end end | T.Opt typ -> check_typ env typ @@ -223,7 +222,6 @@ and check_typ_bounds env (tbs : T.bind list) typs at : unit = and check_inst_bounds env tbs typs at = check_typ_bounds env tbs typs at - (* Literals *) let infer_lit env lit at : T.prim = @@ -261,26 +259,19 @@ and infer_exp_promote env exp : T.typ = and infer_exp_mut env exp : T.typ = let t = infer_exp' env exp in - begin - (* TODO: enable me one infer_effect works on Ir nodes... - let e = E.infer_effect_exp exp in - assert (T.Triv < T.Await); - if not (e <= E.eff exp) then begin - error env exp.at "inferred effect not a subtype of expected effect" - end; - *) - (*TBR: it's weird that we need to mask mutability, but I think there's an inconsistency - between the way the type checker annotates l-expressions in checking (never immutable) - vs. inference mode (maybe mutable) *) - if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then - begin - error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ exp)) - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - end - end; - E.typ exp; + let e = E.Ir.infer_effect_exp exp in + assert (T.Triv < T.Await); + if not (e <= E.eff exp) then + error env exp.at "inferred effect not a subtype of expected effect"; + (* TBR: it's weird that we need to mask mutability, but I think there's an inconsistency + between the way the type checker annotates l-expressions in checking (never immutable) + vs. inference mode (maybe mutable) *) + if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then + error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" + (T.string_of_typ_expand env.cons t) + (T.string_of_typ_expand env.cons (E.typ exp)) + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) + E.typ exp; and infer_exp' env (exp:Ir.exp) : T.typ = let t = E.typ exp in @@ -326,17 +317,18 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.Opt t1 | ProjE (exp1, n) -> let t1 = infer_exp_promote env exp1 in - (try - let ts = T.as_tup_sub n env.cons t1 in - match List.nth_opt ts n with - | Some t -> t - | None -> - error env exp.at "tuple projection %n is out of bounds for type\n %s" - n (T.string_of_typ_expand env.cons t1) - with Invalid_argument _ -> - error env exp1.at "expected tuple type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) - ) + begin + try + let ts = T.as_tup_sub n env.cons t1 in + match List.nth_opt ts n with + | Some t -> t + | None -> + error env exp.at "tuple projection %n is out of bounds for type\n %s" + n (T.string_of_typ_expand env.cons t1) + with Invalid_argument _ -> + error env exp1.at "expected tuple type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + end | ActorE ( id, fields, t) -> let env' = { env with async = false } in let t1 = infer_obj env' T.Actor id t fields in @@ -352,29 +344,30 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | ActorDotE(exp1,{it = Syntax.Name n;_}) | DotE (exp1, {it = Syntax.Name n;_}) -> let t1 = infer_exp_promote env exp1 in - (try - let sort, tfs = T.as_obj_sub n env.cons t1 in - begin - match exp.it with - | ActorDotE _ -> - if (sort <> T.Actor) then - error env exp.at "expected actor found object" - | DotE _ -> - if (sort == T.Actor) then - error env exp.at "expected object found actor" - | _ -> assert false - end; - match List.find_opt (fun {T.name; _} -> name = n) tfs with - | Some {T.typ = t; _} -> t - | None -> - error env exp1.at "field name %s does not exist in type\n %s" - n (T.string_of_typ_expand env.cons t1) - with Invalid_argument _ -> - error env exp1.at "expected object type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) - ) + begin + try + let sort, tfs = T.as_obj_sub n env.cons t1 in + begin + match exp.it with + | ActorDotE _ -> + if (sort <> T.Actor) then + error env exp.at "expected actor found object" + | DotE _ -> + if (sort == T.Actor) then + error env exp.at "expected object found actor" + | _ -> assert false + end; + match List.find_opt (fun {T.name; _} -> name = n) tfs with + | Some {T.typ = t; _} -> t + | None -> + error env exp1.at "field name %s does not exist in type\n %s" + n (T.string_of_typ_expand env.cons t1) + with Invalid_argument _ -> + error env exp1.at "expected object type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + end | AssignE (exp1, exp2) -> - begin + begin let t1 = infer_exp_mut env exp1 in try let t2 = T.as_mut t1 in @@ -389,14 +382,15 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.Array (match mut.it with Syntax.Const -> t1 | Syntax.Var -> T.Mut t1) | IdxE (exp1, exp2) -> let t1 = infer_exp_promote env exp1 in - (try - let t = T.as_array_sub env.cons t1 in - check_exp env T.nat exp2; - t - with Invalid_argument _ -> - error env exp1.at "expected array type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) - ) + begin + try + let t = T.as_array_sub env.cons t1 in + check_exp env T.nat exp2; + t + with Invalid_argument _ -> + error env exp1.at "expected array type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + end | CallE (call_conv, exp1, insts, exp2) -> (* TODO: check call_conv (assuming there's something to check) *) let t1 = infer_exp_promote env exp1 in @@ -443,7 +437,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | ForE (pat, exp1, exp2) -> begin let t1 = infer_exp_promote env exp1 in - (try + try let _, tfs = T.as_obj_sub "next" env.cons t1 in let t = T.lookup_field "next" tfs in let t1, t2 = T.as_mono_func_sub env.cons t in @@ -454,7 +448,6 @@ and infer_exp' env (exp:Ir.exp) : T.typ = with Invalid_argument _ -> error env exp1.at "expected iterable type, but expression has type\n %s" (T.string_of_typ_expand env.cons t1) - ); end; T.unit | LabelE (id, typ, exp1) -> @@ -493,21 +486,20 @@ and infer_exp' env (exp:Ir.exp) : T.typ = if not env.async then error env exp.at "misplaced await"; let t1 = infer_exp_promote env exp1 in - (try - T.as_async_sub env.cons t1 - with Invalid_argument _ -> - error env exp1.at "expected async type, but expression has type\n %s" - (T.string_of_typ_expand env.cons t1) - ) + begin + try + T.as_async_sub env.cons t1 + with Invalid_argument _ -> + error env exp1.at "expected async type, but expression has type\n %s" + (T.string_of_typ_expand env.cons t1) + end | AssertE exp1 -> check_exp env T.bool exp1; T.unit | IsE (exp1, exp2) -> (* TBR: restrict t1 to objects? *) - begin - let _t1 = infer_exp env exp1 in - check_exp env T.Class exp2 - end; + let _t1 = infer_exp env exp1 in + check_exp env T.Class exp2 T.bool | DeclareE (id, typ, exp1) -> let env' = adjoin_vals env (T.Env.singleton id.it typ) in @@ -551,7 +543,6 @@ and check_exp env t exp = (T.string_of_typ_expand env.cons t') (T.string_of_typ_expand env.cons t) - (* Cases *) and check_cases env t_pat t cases = @@ -697,13 +688,11 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = end; t in - begin - if s = T.Actor && priv.it = Syntax.Public && not (is_func_exp exp) then - error env field.at "public actor field is not a function"; - if s <> T.Object T.Local && priv.it = Syntax.Public && not (T.sub env.cons t T.Shared) then - error env field.at "public shared object or actor field %s has non-shared type\n %s" - (Syntax.string_of_name name.it) (T.string_of_typ_expand env.cons t) - end; + if s = T.Actor && priv.it = Syntax.Public && not (is_func_exp exp) then + error env field.at "public actor field is not a function"; + if s <> T.Object T.Local && priv.it = Syntax.Public && not (T.sub env.cons t T.Shared) then + error env field.at "public shared object or actor field %s has non-shared type\n %s" + (Syntax.string_of_name name.it) (T.string_of_typ_expand env.cons t); let ve' = T.Env.add id.it t ve in let tfs' = if priv.it = Syntax.Private @@ -773,18 +762,14 @@ and infer_dec env dec : T.typ = check_typ env' (T.open_ ts typ); T.unit in - if not (Type.sub env.cons t (E.typ dec)) then begin + if not (Type.sub env.cons t (E.typ dec)) then error env dec.at "inferred dec type %s not a subtype of expected type %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ dec)); - end; - (* TODO: enable me one infer_effect works on Ir nodes... - let e = E.infer_effect_dec dec in + let e = E.Ir.infer_effect_dec dec in assert (T.Triv < T.Await); - if not (e <= E.eff dec) then begin - error env dec.at "inferred effect not a subtype of expected effect" - end; - *) + if not (e <= E.eff dec) then + error env dec.at "inferred effect not a subtype of expected effect"; E.typ dec and check_block env t decs at : scope = diff --git a/src/effect.ml b/src/effect.ml index a7eee96ddd9..ef7ee3e6d1a 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -13,14 +13,20 @@ let max_eff e1 e2 = | _ , T.Await -> T.Await | T.Await,_ -> T.Await -let effect_exp (exp:Syntax.exp) : T.eff = - exp.note.note_eff - -(* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated *) +let typ phrase = phrase.note.note_typ + +let eff phrase = phrase.note.note_eff + +let is_triv phrase = + eff phrase = T.Triv + +let effect_exp (exp:Syntax.exp) : T.eff = eff exp + +(* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated es*) let rec infer_effect_exp (exp:Syntax.exp) : T.eff = match exp.it with | PrimE _ - | VarE _ + | VarE _ | LitE _ -> T.Triv | UnE (_, _, exp1) @@ -28,36 +34,36 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | OptE exp1 | DotE (exp1, _, _) | NotE exp1 - | AssertE exp1 - | LabelE (_, _, exp1) - | BreakE (_, exp1) - | RetE exp1 - | AnnotE (exp1, _) - | LoopE (exp1, None) -> - effect_exp exp1 + | AssertE exp1 + | LabelE (_, _, exp1) + | BreakE (_, exp1) + | RetE exp1 + | AnnotE (exp1, _) + | LoopE (exp1, None) -> + effect_exp exp1 | BinE (_, exp1, _, exp2) | IdxE (exp1, exp2) - | IsE (exp1, exp2) - | RelE (_, exp1, _, exp2) - | AssignE (exp1, exp2) - | CallE (exp1, _, exp2) + | IsE (exp1, exp2) + | RelE (_, exp1, _, exp2) + | AssignE (exp1, exp2) + | CallE (exp1, _, exp2) | AndE (exp1, exp2) - | OrE (exp1, exp2) - | WhileE (exp1, exp2) - | LoopE (exp1, Some exp2) + | OrE (exp1, exp2) + | WhileE (exp1, exp2) + | LoopE (exp1, Some exp2) | ForE (_, exp1, exp2)-> let t1 = effect_exp exp1 in let t2 = effect_exp exp2 in max_eff t1 t2 - | TupE exps + | TupE exps | ArrayE (_, exps) -> let es = List.map effect_exp exps in List.fold_left max_eff Type.Triv es | BlockE (decs,_) -> let es = List.map effect_dec decs in - List.fold_left max_eff Type.Triv es + List.fold_left max_eff Type.Triv es | ObjE (_, _, efs) -> - effect_field_exps efs + effect_field_exps efs | IfE (exp1, exp2, exp3) -> let e1 = effect_exp exp1 in let e2 = effect_exp exp2 in @@ -70,7 +76,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = | AsyncE exp1 -> T.Triv | AwaitE exp1 -> - T.Await + T.Await | DecE (d, _) -> effect_dec d | DeclareE (_, _, exp1) -> @@ -79,7 +85,7 @@ let rec infer_effect_exp (exp:Syntax.exp) : T.eff = effect_exp exp1 | NewObjE _ -> T.Triv - + and effect_cases cases = match cases with | [] -> @@ -90,14 +96,14 @@ and effect_cases cases = and effect_field_exps efs = List.fold_left (fun e (fld:exp_field) -> max_eff e (effect_exp fld.it.exp)) T.Triv efs - + and effect_dec dec = dec.note.note_eff -and infer_effect_dec dec = +and infer_effect_dec dec = match dec.it with | ExpD e - | LetD (_,e) + | LetD (_,e) | VarD (_, e) -> effect_exp e | TypD (v, tps, t) -> @@ -107,10 +113,99 @@ and infer_effect_dec dec = | ClassD (v, l, tps, s, p, v', efs) -> T.Triv +(* effect inference on Ir *) -let typ phrase = phrase.note.note_typ +(* TODO: remove effect inference on Source once await.ml ported to work on IR + since effect inference is purely syntactic, we could roll this into desugaring +*) -let eff phrase = phrase.note.note_eff +module Ir = + struct + open Ir -let is_triv phrase = - eff phrase = T.Triv + let effect_exp (exp: exp) : T.eff = eff exp + + (* infer the effect of an expression, assuming all sub-expressions are correctly effect-annotated es*) + let rec infer_effect_exp (exp: exp) : T.eff = + match exp.it with + | PrimE _ + | VarE _ + | LitE _ -> + T.Triv + | UnE (_, _, exp1) + | ProjE (exp1, _) + | OptE exp1 + | DotE (exp1, _) + | ActorDotE (exp1, _) + | AssertE exp1 + | LabelE (_, _, exp1) + | BreakE (_, exp1) + | RetE exp1 + | LoopE (exp1, None) -> + effect_exp exp1 + | BinE (_, exp1, _, exp2) + | IdxE (exp1, exp2) + | IsE (exp1, exp2) + | RelE (_, exp1, _, exp2) + | AssignE (exp1, exp2) + | CallE (_, exp1, _, exp2) + | WhileE (exp1, exp2) + | LoopE (exp1, Some exp2) + | ForE (_, exp1, exp2) -> + let t1 = effect_exp exp1 in + let t2 = effect_exp exp2 in + max_eff t1 t2 + | TupE exps + | ArrayE (_, _, exps) -> + let es = List.map effect_exp exps in + List.fold_left max_eff Type.Triv es + | BlockE (decs,_) -> + let es = List.map effect_dec decs in + List.fold_left max_eff Type.Triv es + | IfE (exp1, exp2, exp3) -> + let e1 = effect_exp exp1 in + let e2 = effect_exp exp2 in + let e3 = effect_exp exp3 in + max_eff e1 (max_eff e2 e3) + | SwitchE (exp1, cases) -> + let e1 = effect_exp exp1 in + let e2 = effect_cases cases in + max_eff e1 e2 + | ActorE (_,efs,_) -> + effect_field_exps efs + | AsyncE exp1 -> + T.Triv + | AwaitE exp1 -> + T.Await + | DeclareE (_, _, exp1) -> + effect_exp exp1 + | DefineE (_, _, exp1) -> + effect_exp exp1 + | NewObjE _ -> + T.Triv + + and effect_cases cases = + match cases with + | [] -> + T.Triv + | {it = {pat; exp}; _}::cases' -> + let e = effect_exp exp in + max_eff e (effect_cases cases') + + and effect_field_exps efs = + List.fold_left (fun e (fld:exp_field) -> max_eff e (effect_exp fld.it.exp)) T.Triv efs + + and effect_dec dec = + dec.note.note_eff + + and infer_effect_dec (dec:Ir.dec) = + match dec.it with + | ExpD e + | LetD (_,e) + | VarD (_, e) -> + effect_exp e + | TypD (c,k) -> + T.Triv + | FuncD (s, v, tps, p, t, e) -> + T.Triv +end diff --git a/src/effect.mli b/src/effect.mli index c816396c645..5585f452ba8 100644 --- a/src/effect.mli +++ b/src/effect.mli @@ -1,15 +1,25 @@ -open Source +open Source open Syntax open Type val max_eff : eff -> eff -> eff -val effect_exp: exp -> eff +(* (incremental) effect inference on Source *) +(* TODO: delete once await.ml ported to IR *) +val effect_exp: exp -> eff val infer_effect_exp : exp -> eff val infer_effect_dec : dec -> eff val typ : ('a, typ_note) annotated_phrase -> typ val eff : ('a, typ_note) annotated_phrase -> eff -val is_triv : ('a, typ_note) annotated_phrase -> bool +val is_triv : ('a, typ_note) annotated_phrase -> bool + +(* (incremental) effect inference on IR *) + +module Ir : sig + val effect_exp: Ir.exp -> eff + val infer_effect_exp : Ir.exp -> eff + val infer_effect_dec : Ir.dec -> eff +end From 6bfcefd6fc4431f6165d18ac12f92a53524627c0 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Fri, 25 Jan 2019 11:10:03 +0000 Subject: [PATCH 37/45] restored ir-checking that was masking failing build --- src/check_ir.ml | 12 ++++++------ src/pipeline.ml | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 66731b61e48..3d23f17795e 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -270,8 +270,8 @@ and infer_exp_mut env exp : T.typ = error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons (E.typ exp)) - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - E.typ exp; + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)); + E.typ exp; and infer_exp' env (exp:Ir.exp) : T.typ = let t = E.typ exp in @@ -460,7 +460,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | Some t -> check_exp env t exp1 | None -> - in error env id.at "unbound label %s" name + error env id.at "unbound label %s" id.it end; T.Non | RetE exp1 -> @@ -499,7 +499,7 @@ and infer_exp' env (exp:Ir.exp) : T.typ = | IsE (exp1, exp2) -> (* TBR: restrict t1 to objects? *) let _t1 = infer_exp env exp1 in - check_exp env T.Class exp2 + check_exp env T.Class exp2; T.bool | DeclareE (id, typ, exp1) -> let env' = adjoin_vals env (T.Env.singleton id.it typ) in @@ -800,7 +800,7 @@ and check_dec env t dec = and gather_block_decs env decs = List.fold_left (gather_dec env) empty_scope decs -and gather_dec env scope dec : scope = +and gather_dec env scope dec : scope = match dec.it with | ExpD _ -> scope @@ -818,7 +818,7 @@ and gather_dec env scope dec : scope = let t1 = pat.note in let t2 = typ in if Type.is_async t2 && not (isAsyncE exp) then - error env dec.at "shared function with async type has non-async body" + error env dec.at "shared function with async type has non-async body"; let ts1 = match call_conv.Value.n_args with | 1 -> [t1] | _ -> T.as_seq t1 diff --git a/src/pipeline.ml b/src/pipeline.ml index c9c410f2890..6a18fda894f 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -291,7 +291,7 @@ let compile_with check mode name : compile_result = let prog = async_lowering true prog name in let prog = tailcall_optimization true prog name in let prog = Desugar.prog prog in - (* ignore (Check_ir.check_prog initial_stat_env prog); *) + ignore (Check_ir.check_prog initial_stat_env prog); phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ From fc05eb9e464fc8cfdb92f95c1884c84a01da4d40 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Sat, 26 Jan 2019 15:56:26 +0000 Subject: [PATCH 38/45] WIP; rewrite check_ir to avoid inference --- src/check_ir.ml | 497 ++++++++++++++++++++++++++---------------------- 1 file changed, 273 insertions(+), 224 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 3d23f17795e..7bd8c82b858 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -18,6 +18,10 @@ module E = Effect (* Scope (the external interface) *) +let typ = E.typ + +let immute_typ p = T.as_immut (typ p) + type val_env = T.typ T.Env.t type con_env = T.con_env @@ -90,7 +94,6 @@ let disjoint_union env at fmt env1 env2 = try T.Env.disjoint_union env1 env2 with T.Env.Clash k -> error env at fmt k - (* Types *) let check_ids env ids = ignore @@ -243,6 +246,9 @@ let infer_lit env lit at : T.prim = open Ir +let string_of_exp exp = Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp) +let string_of_dec exp = Wasm.Sexpr.to_string 80 (Arrange_ir.dec exp) + (* Expressions *) let isAsyncE exp = @@ -250,6 +256,7 @@ let isAsyncE exp = | AsyncE _ -> true | _ -> false +(* TBD let rec infer_exp env exp : T.typ = T.as_immut (infer_exp_mut env exp) @@ -272,253 +279,289 @@ and infer_exp_mut env exp : T.typ = (T.string_of_typ_expand env.cons (E.typ exp)) (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)); E.typ exp; + *) +let rec check_exp env exp : unit = + check_exp' env exp +(* + let t' = infer_exp env exp in + if not (T.sub env.cons t' t) then + error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" + (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) + (T.string_of_typ_expand env.cons t') + (T.string_of_typ_expand env.cons t) + *) -and infer_exp' env (exp:Ir.exp) : T.typ = +and check_exp' env (exp:Ir.exp) : unit = + let check p = + if p then ignore + else fun fmt -> error env exp.at fmt + in + let (<:) t1 t2 = + if (T.sub env.cons t1 t2) + then () + else error env exp.at "subtype violation in expression\n %s\n %s\n %s" + (string_of_exp exp) (T.string_of_typ t1) (T.string_of_typ t2) + in let t = E.typ exp in match exp.it with - | PrimE _ -> - exp.note.Syntax.note_typ (* error env exp.at "cannot infer type of primitive" *) + | PrimE _ -> () | VarE id -> - (match T.Env.find_opt id.it env.vals with - | Some T.Pre -> - assert false (* error env id.at "cannot infer type of forward variable %s" id.it; *) - | Some t -> t - | None -> error env id.at "unbound variable %s" id.it - ) + let t0 = try T.Env.find id.it env.vals with + | Not_found -> error env id.at "unbound variable %s" id.it + in + if T.is_mut t then + t0 <: t + else + T.as_immut t0 <: t | LitE lit -> - T.Prim (infer_lit env lit exp.at) + T.Prim (infer_lit env lit exp.at) <: t | UnE (ot, op, exp1) -> - if not (Operator.has_unop ot op) then - error env exp.at "operator is not defined for operand type\n %s" - (T.string_of_typ_expand env.cons ot); - check_exp env ot exp1; - ot + check (Operator.has_unop ot op) "unary operator is not defined for operand type"; + check_exp env exp1; + (immute_typ exp1) <: ot; + ot <: t; | BinE (ot, exp1, op, exp2) -> - if not (Operator.has_binop ot op) then - error env exp.at "operator not defined for operand types\n %s and\n %s" - (T.string_of_typ_expand env.cons ot) - (T.string_of_typ_expand env.cons ot); - check_exp env ot exp1; - check_exp env ot exp2; - ot + check (Operator.has_binop ot op) "binary operator is not defined for operand type"; + check_exp env exp1; + check_exp env exp2; + immute_typ exp1 <: ot; + immute_typ exp2 <: ot; + ot <: t; | RelE (ot,exp1, op, exp2) -> - if not (Operator.has_relop ot op) then - error env exp.at "operator not defined for operand types\n %s and\n %s" - (T.string_of_typ_expand env.cons ot) - (T.string_of_typ_expand env.cons ot); - check_exp env ot exp1; - check_exp env ot exp2; - T.bool + check (Operator.has_relop ot op) "relational operator is not defined for operand type"; + check_exp env exp1; + check_exp env exp2; + immute_typ exp1 <: ot; + immute_typ exp2 <: ot; + T.bool <: t; | TupE exps -> - let ts = List.map (infer_exp env) exps in - T.Tup ts + List.iter (check_exp env) exps; + T.Tup (List.map immute_typ exps) <: t; | OptE exp1 -> - let t1 = infer_exp env exp1 in - T.Opt t1 + check_exp env exp1; + T.Opt (immute_typ exp1) <: t; | ProjE (exp1, n) -> - let t1 = infer_exp_promote env exp1 in begin - try - let ts = T.as_tup_sub n env.cons t1 in - match List.nth_opt ts n with - | Some t -> t - | None -> - error env exp.at "tuple projection %n is out of bounds for type\n %s" - n (T.string_of_typ_expand env.cons t1) - with Invalid_argument _ -> - error env exp1.at "expected tuple type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) + check_exp env exp1; + let t1 = T.promote env.cons (immute_typ exp1) in + let ts = try T.as_tup_sub n env.cons t1 + with Invalid_argument _ -> + error env exp1.at "expected tuple type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) in + let tn = try List.nth ts n with + | Invalid_argument _ -> + error env exp.at "tuple projection %n is out of bounds for type\n %s" + n (T.string_of_typ_expand env.cons t1) in + tn <: t end - | ActorE ( id, fields, t) -> + | ActorE ( id, fields, t0) -> let env' = { env with async = false } in let t1 = infer_obj env' T.Actor id t fields in let t2 = T.promote env.cons t in - if not (T.is_obj t2) then - error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); - if T.sub env.cons t1 t2 then - t - else - error env no_region "expecting actor of type %s, but expression produces %s" - (T.string_of_typ_expand env.cons t2) - (T.string_of_typ_expand env.cons t1) + check (T.is_obj t2) "bad annotation (object type expected)"; + t1 <: t2; + t0 <: t; | ActorDotE(exp1,{it = Syntax.Name n;_}) | DotE (exp1, {it = Syntax.Name n;_}) -> - let t1 = infer_exp_promote env exp1 in begin - try - let sort, tfs = T.as_obj_sub n env.cons t1 in - begin - match exp.it with - | ActorDotE _ -> - if (sort <> T.Actor) then - error env exp.at "expected actor found object" - | DotE _ -> - if (sort == T.Actor) then - error env exp.at "expected object found actor" - | _ -> assert false - end; - match List.find_opt (fun {T.name; _} -> name = n) tfs with - | Some {T.typ = t; _} -> t - | None -> - error env exp1.at "field name %s does not exist in type\n %s" - n (T.string_of_typ_expand env.cons t1) - with Invalid_argument _ -> - error env exp1.at "expected object type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) + check_exp env exp1; + let t1 = immute_typ exp1 in + let sort, tfs = + try T.as_obj_sub n env.cons t1 with + | Invalid_argument _ -> + error env exp1.at "expected object type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + in + check (match exp.it with + | ActorDotE _ -> sort = T.Actor + | DotE _ -> sort <> T.Actor + | _ -> false) "sort mismatch"; + match List.find_opt (fun {T.name; _} -> name = n) tfs with + | Some {T.typ = tn;_} -> + if T.is_mut t then + tn <: t + else + T.as_immut tn <: t + | None -> + error env exp1.at "field name %s does not exist in type\n %s" + n (T.string_of_typ_expand env.cons t1) end | AssignE (exp1, exp2) -> - begin - let t1 = infer_exp_mut env exp1 in - try - let t2 = T.as_mut t1 in - check_exp env t2 exp2 - with Invalid_argument _ -> - error env exp.at "expected mutable assignment target"; - end; - T.unit - | ArrayE (mut, t, exps) -> - let ts = List.map (infer_exp env) exps in - let t1 = List.fold_left (T.lub env.cons) t ts in - T.Array (match mut.it with Syntax.Const -> t1 | Syntax.Var -> T.Mut t1) + check_exp env exp1; + check_exp env exp2; + (* let t1 = infer_exp_mut env exp1 in *) + let t2 = try T.as_mut (typ exp1) with + Invalid_argument _ -> error env exp.at "expected mutable assignment target" + in + immute_typ exp2 <: t2; + T.unit <: t; + | ArrayE (mut, t0, exps) -> + List.iter (check_exp env) exps; + List.iter (fun e -> immute_typ e <: t0) exps; + let t1 = T.Array (match mut.it with Syntax.Const -> t0 | Syntax.Var -> T.Mut t0) in + t1 <: t; | IdxE (exp1, exp2) -> - let t1 = infer_exp_promote env exp1 in - begin - try - let t = T.as_array_sub env.cons t1 in - check_exp env T.nat exp2; - t - with Invalid_argument _ -> - error env exp1.at "expected array type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) - end + check_exp env exp1; + check_exp env exp2; + let t1 = T.promote env.cons (immute_typ exp1) in + let t2 = try T.as_array_sub env.cons t1 with + | Invalid_argument _ -> + error env exp1.at "expected array type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + in + immute_typ exp2 <: T.nat; + if T.is_mut t then + t2 <: t + else + T.as_immut t2 <: t | CallE (call_conv, exp1, insts, exp2) -> + check_exp env exp1; + check_exp env exp2; (* TODO: check call_conv (assuming there's something to check) *) - let t1 = infer_exp_promote env exp1 in - (try - let tbs, t2, t = T.as_func_sub (List.length insts) env.cons t1 in - check_inst_bounds env tbs insts exp.at; - check_exp env (T.open_ insts t2) exp2; - T.open_ insts t - with Invalid_argument _ -> - error env exp1.at "expected function type, but expression produces type\n %s" - (T.string_of_typ_expand env.cons t1) - ) - | BlockE (decs, t) -> + let t1 = T.promote env.cons (immute_typ exp1) in + let tbs, t2, t3 = + try T.as_func_sub (List.length insts) env.cons t1 with + | Invalid_argument _ -> + error env exp1.at "expected function type, but expression produces type\n %s" + (T.string_of_typ_expand env.cons t1) + in + check_inst_bounds env tbs insts exp.at; + check_exp env exp2; + (immute_typ exp2) <: T.open_ insts t2; + T.open_ insts t3 <: t; + | BlockE (decs, t0) -> let t1, scope = infer_block env decs exp.at in (* let _t2 = try T.avoid env.cons scope.con_env t1 with T.Unavoidable c -> assert false in *) let env' = adjoin env scope in - check_typ env t; - if not (T.eq env.cons t T.unit || T.eq env'.cons t1 t) then - error env exp.at "expected block type\n %s, found declaration with inequivalent type\n %s" - (T.string_of_typ t) - (T.string_of_typ t1); - t + check_typ env t0; + check (T.eq env.cons t T.unit || T.eq env'.cons t1 t0) "unexpected expected block type"; + t0 <: t; | IfE (exp1, exp2, exp3) -> - check_exp env T.bool exp1; - check_exp env t exp2; - check_exp env t exp3; - t + check_exp env exp1; + immute_typ exp1 <: T.bool; + check_exp env exp2; + immute_typ exp2 <: t; + check_exp env exp3; + immute_typ exp3 <: t; | SwitchE (exp1, cases) -> - let t1 = infer_exp_promote env exp1 in + check_exp env exp1; + let t1 = T.promote env.cons (immute_typ exp1) in (* if not env.pre then if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; *) check_cases env t1 t cases; - t | WhileE (exp1, exp2) -> - check_exp env T.bool exp1; - check_exp env T.unit exp2; - T.unit + check_exp env exp1; + immute_typ exp1 <: T.bool; + check_exp env exp2; + immute_typ exp2 <: T.unit; + T.unit <: t; | LoopE (exp1, expo) -> - check_exp env T.unit exp1; - Lib.Option.app (check_exp env T.bool) expo; - T.Non + check_exp env exp1; + immute_typ exp1 <: T.unit; + begin match expo with + | Some exp2 -> + check_exp env exp2; + (immute_typ exp2) <: T.bool; + | _ -> () + end; + T.Non <: t; (* redundant *) | ForE (pat, exp1, exp2) -> begin - let t1 = infer_exp_promote env exp1 in + check_exp env exp1; + let t1 = T.promote env.cons (immute_typ exp1) in try let _, tfs = T.as_obj_sub "next" env.cons t1 in - let t = T.lookup_field "next" tfs in - let t1, t2 = T.as_mono_func_sub env.cons t in - if not (T.sub env.cons T.unit t1) then raise (Invalid_argument ""); + let t0 = T.lookup_field "next" tfs in + let t1, t2 = T.as_mono_func_sub env.cons t0 in + T.unit <: t1; let t2' = T.as_opt_sub env.cons t2 in let ve = check_pat_exhaustive env t2' pat in - check_exp (adjoin_vals env ve) T.unit exp2 + check_exp (adjoin_vals env ve) exp2; + immute_typ exp2 <: T.unit; + T.unit <: t with Invalid_argument _ -> error env exp1.at "expected iterable type, but expression has type\n %s" (T.string_of_typ_expand env.cons t1) end; - T.unit - | LabelE (id, typ, exp1) -> - let t = check_typ env typ;typ in - check_exp (add_lab env id.it typ) t exp1; - t + | LabelE (id, t0, exp1) -> + assert (t0 <> T.Pre); + check_typ env t0; + check_exp (add_lab env id.it t0) exp1; + immute_typ exp1 <: t0; + t0 <: t; | BreakE (id, exp1) -> begin match T.Env.find_opt id.it env.labs with - | Some t -> - check_exp env t exp1 | None -> error env id.at "unbound label %s" id.it + | Some t1 -> + check_exp env exp1; + immute_typ exp1 <: t1; + T.Non <: t1; end; - T.Non | RetE exp1 -> begin match env.rets with - | Some T.Pre -> - assert false; (* error env exp.at "cannot infer return type" *) - | Some t -> - check_exp env t exp1 | None -> error env exp.at "misplaced return" + | Some t0 -> + assert (t0 <> T.Pre); + check_exp env exp1; + immute_typ exp1 <: t0; + T.Non <: t; end; - T.Non | AsyncE exp1 -> + let t1 = immute_typ exp1 in let env' = - {env with labs = T.Env.empty; rets = Some (* T.Pre *) exp1.note.Syntax.note_typ; async = true} in - let t = infer_exp env' exp1 in - if not (T.sub env.cons t T.Shared) then - error env exp1.at "async type has non-shared parameter type\n %s" - (T.string_of_typ_expand env.cons t); - T.Async t + {env with labs = T.Env.empty; rets = Some t1; async = true} in + check_exp env' exp1; + t1 <: T.Shared; + T.Async t1 <: t | AwaitE exp1 -> - if not env.async then - error env exp.at "misplaced await"; - let t1 = infer_exp_promote env exp1 in - begin - try - T.as_async_sub env.cons t1 - with Invalid_argument _ -> - error env exp1.at "expected async type, but expression has type\n %s" - (T.string_of_typ_expand env.cons t1) - end + check env.async "misplaced await"; + check_exp env exp1; + let t1 = T.promote env.cons (immute_typ exp1) in + let t2 = try T.as_async_sub env.cons t1 + with Invalid_argument _ -> + error env exp1.at "expected async type, but expression has type\n %s" + (T.string_of_typ_expand env.cons t1) + in + t2 <: t; | AssertE exp1 -> - check_exp env T.bool exp1; - T.unit + check_exp env exp1; + immute_typ exp1 <: T.bool; + T.unit <: t; | IsE (exp1, exp2) -> - (* TBR: restrict t1 to objects? *) - let _t1 = infer_exp env exp1 in - check_exp env T.Class exp2; - T.bool - | DeclareE (id, typ, exp1) -> - let env' = adjoin_vals env (T.Env.singleton id.it typ) in - infer_exp env' exp1 + (* TBR: restrict immute_typ exp1 to objects? *) + check_exp env exp1; + check_exp env exp2; + immute_typ exp2 <: T.Class; + T.bool <: t; + | DeclareE (id, t0, exp1) -> + check_typ env t0; + let env' = adjoin_vals env (T.Env.singleton id.it t0) in + check_exp env' exp1; + (immute_typ exp1) <: t; | DefineE (id, mut, exp1) -> - begin - match T.Env.find_opt id.it env.vals with - | Some t1 -> - begin - try - let t2 = match mut.it with | Syntax.Var -> T.as_mut t1 | Syntax.Const -> t1 in - check_exp env t2 exp1 - with Invalid_argument _ -> - error env exp.at "expected mutable assignment target"; - end; - | None -> error env id.at "unbound variable %s" id.it + check_exp env exp1; + begin + match T.Env.find_opt id.it env.vals with + | None -> error env id.at "unbound variable %s" id.it + | Some t0 -> + match mut.it with + | Syntax.Const -> + immute_typ exp1 <: t0 + | Syntax.Var -> + let t0 = try T.as_mut t0 with + | Invalid_argument _ -> + error env exp.at "expected mutable %s" (T.string_of_typ t0) + in + immute_typ exp1 <: t0 end; - T.unit - | NewObjE (sort, labids, t) -> + T.unit <: t + | NewObjE (sort, labids, t0) -> let t1 = T.Obj(sort.it, List.sort T.compare_field (List.map (fun (name,id) -> @@ -526,22 +569,9 @@ and infer_exp' env (exp:Ir.exp) : T.typ = T.typ = T.Env.find id.it env.vals}) labids)) in let t2 = T.promote env.cons t in - if not (T.is_obj t2) then - error env exp.at "bad annotation %s (object type expected)" (T.string_of_typ t); - if T.sub env.cons t1 t2 then - t - else - error env no_region "expecting object of type %s, but expression produces %s" - (T.string_of_typ_expand env.cons t2) - (T.string_of_typ_expand env.cons t1) - -and check_exp env t exp = - let t' = infer_exp env exp in - if not (T.sub env.cons t' t) then - error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons t) + check (T.is_obj t2) "bad annotation (object type expected)"; + t1 <: t2; + t0 <: t; (* Cases *) @@ -550,7 +580,9 @@ and check_cases env t_pat t cases = and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env t_pat pat in - check_exp (adjoin_vals env ve) t exp + check_exp (adjoin_vals env ve) exp; + if not (T.sub env.cons (immute_typ exp) t) then + error env exp.at "bad case" (* Patterns *) @@ -678,7 +710,9 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = assert false | t -> begin - check_exp (adjoin_vals env ve) (T.as_immut t) exp; + check_exp (adjoin_vals env ve) exp; + if not (T.sub env.cons (immute_typ exp) (T.as_immut t)) then + error env field.at "subtype violation"; if (mut.it = Syntax.Var) <> T.is_mut t then error env field.at "%smutable field %s cannot produce expected %smutable field of type\n %s" @@ -711,9 +745,11 @@ and infer_block env decs at : T.typ * scope = and infer_block_exps env decs : T.typ = match decs with | [] -> T.unit - | [dec] -> infer_dec env dec + | [dec] -> + check_dec env dec; + immute_typ dec; | dec::decs' -> - check_dec env T.unit dec; + check_dec env dec; infer_block_exps env decs' and cons_of_typ_binds typ_binds = @@ -732,24 +768,36 @@ and check_open_typ_binds env typ_binds = let _,_ = check_typ_binds env binds in cs,ce -and infer_dec env dec : T.typ = - let t = +and check_dec env dec = + let check p = + if p then ignore + else fun fmt -> error env dec.at fmt + in + let (<:) t1 t2 = + if (T.sub env.cons t1 t2) + then () + else error env dec.at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) + in + let t = typ dec in + begin match dec.it with | ExpD exp -> - infer_exp env exp + check_exp env exp; + (immute_typ exp) <: t | LetD (_, exp) | VarD (_, exp) -> - ignore (infer_exp env exp); - T.unit - | FuncD (sort, id, typ_binds, pat, typ, exp) -> - let t = T.Env.find id.it env.vals in + check_exp env exp; + T.unit <: t + | FuncD (sort, id, typ_binds, pat, t2, exp) -> + let t0 = T.Env.find id.it env.vals in let _cs,ce = check_open_typ_binds env typ_binds in let env' = adjoin_typs env ce in let t1, ve = infer_pat_exhaustive env' pat in - check_typ env' typ; + check_typ env' t2; let env'' = - {env' with labs = T.Env.empty; rets = Some typ; async = false} in - check_exp (adjoin_vals env'' ve) typ exp; - t + {env' with labs = T.Env.empty; rets = Some t2; async = false} in + check_exp (adjoin_vals env'' ve) exp; + check (T.sub env'.cons (typ exp) t2) "function body subtype violation"; + t0 <: t; | TypD (c, k) -> let (binds,typ) = match k with @@ -760,17 +808,12 @@ and infer_dec env dec : T.typ = let ts = List.map (fun c -> T.Con(c,[])) cs in let env' = adjoin_typs env ce in check_typ env' (T.open_ ts typ); - T.unit - in - if not (Type.sub env.cons t (E.typ dec)) then - error env dec.at "inferred dec type %s not a subtype of expected type %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ dec)); + T.unit <: t; + end; let e = E.Ir.infer_effect_dec dec in assert (T.Triv < T.Await); if not (e <= E.eff dec) then error env dec.at "inferred effect not a subtype of expected effect"; - E.typ dec and check_block env t decs at : scope = let scope = gather_block_decs env decs in @@ -784,11 +827,14 @@ and check_block_exps env t decs at = error env at "empty block cannot produce expected type\n %s" (T.string_of_typ_expand env.cons t) | [dec] -> - check_dec env t dec + check_dec env dec; + if not (T.is_unit t || T.sub env.cons (immute_typ dec) t) then + error env at "subtyp violation" | dec::decs' -> - check_dec env T.unit dec; + check_dec env dec; check_block_exps env t decs' at +(* and check_dec env t dec = let t' = infer_dec env dec in (* TBR: special-case unit? *) @@ -796,7 +842,9 @@ and check_dec env t dec = error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" (T.string_of_typ_expand env.cons t) (T.string_of_typ_expand env.cons t') + *) + and gather_block_decs env decs = List.fold_left (gather_dec env) empty_scope decs @@ -810,7 +858,7 @@ and gather_dec env scope dec : scope = | VarD (id, exp) -> if T.Env.mem id.it scope.val_env then error env dec.at "duplicate definition for %s in block" id.it; - let ve = T.Env.add id.it (T.Mut exp.note.Syntax.note_typ) scope.val_env in + let ve = T.Env.add id.it (T.Mut (immute_typ exp)) scope.val_env in { scope with val_env = ve} | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> let func_sort = call_conv.Value.sort in @@ -851,3 +899,4 @@ let check_prog scope prog : scope = let infer_prog scope prog : (T.typ * scope) = let env = env_of_scope scope in infer_block env prog.it prog.at + From ff32768e7e3fa754ebe912534922349c10f6c827 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Sat, 26 Jan 2019 16:26:40 +0000 Subject: [PATCH 39/45] cleanup --- src/check_ir.ml | 100 +++++++++++++++--------------------------------- 1 file changed, 30 insertions(+), 70 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 7bd8c82b858..92b0a0068f3 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -8,20 +8,18 @@ module E = Effect (* TODO: make note immutable, perhaps just using type abstraction *) (* TODO: - open code review issues - place where we access Syntax.note_typ or pat.note are good places to considering - add type info to IR.exp' constructors - (e.g. identifier bindings, PrimE, branches) so that we can remove the type notes altogether. add type and term predicate to rule out constructs after passes, We could even compose these I guess.... - restore effect inference -*) + *) -(* Scope (the external interface) *) +(* helpers *) let typ = E.typ let immute_typ p = T.as_immut (typ p) + +(* Scope (the external interface) *) + type val_env = T.typ T.Env.t type con_env = T.con_env @@ -105,6 +103,15 @@ let check_ids env ids = ignore ) [] ids ) +let check env at p = + if p then ignore + else fun fmt -> error env at fmt + +let check_sub env at t1 t2 = + if (T.sub env.cons t1 t2) + then () + else error env at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) + let infer_mut mut : T.typ -> T.typ = match mut.it with | Syntax.Const -> fun t -> t @@ -256,52 +263,14 @@ let isAsyncE exp = | AsyncE _ -> true | _ -> false -(* TBD -let rec infer_exp env exp : T.typ = - T.as_immut (infer_exp_mut env exp) - -and infer_exp_promote env exp : T.typ = - let t = infer_exp env exp in - T.promote env.cons t - -and infer_exp_mut env exp : T.typ = - let t = infer_exp' env exp in - let e = E.Ir.infer_effect_exp exp in - assert (T.Triv < T.Await); - if not (e <= E.eff exp) then - error env exp.at "inferred effect not a subtype of expected effect"; - (* TBR: it's weird that we need to mask mutability, but I think there's an inconsistency - between the way the type checker annotates l-expressions in checking (never immutable) - vs. inference mode (maybe mutable) *) - if not (Type.sub env.cons (if T.is_mut (E.typ exp) then t else T.as_immut t) (E.typ exp)) then - error env exp.at "inferred type %s not a subtype of expected type %s in \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons (E.typ exp)) - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)); - E.typ exp; - *) -let rec check_exp env exp : unit = - check_exp' env exp -(* - let t' = infer_exp env exp in - if not (T.sub env.cons t' t) then - error env exp.at "expression\n %s\n of type\n %s\ncannot produce expected type\n %s" - (Wasm.Sexpr.to_string 80 (Arrange_ir.exp exp)) - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons t) - *) - -and check_exp' env (exp:Ir.exp) : unit = - let check p = - if p then ignore - else fun fmt -> error env exp.at fmt - in - let (<:) t1 t2 = - if (T.sub env.cons t1 t2) - then () - else error env exp.at "subtype violation in expression\n %s\n %s\n %s" - (string_of_exp exp) (T.string_of_typ t1) (T.string_of_typ t2) - in +let rec check_exp env (exp:Ir.exp) : unit = + (* helpers *) + let check p = check env exp.at p in + let (<:) t1 t2 = check_sub env exp.at t1 t2 in + (* check effect *) + check (E.Ir.infer_effect_exp exp <= E.eff exp) + "inferred effect not a subtype of expected effect"; + (* check typing *) let t = E.typ exp in match exp.it with | PrimE _ -> () @@ -364,7 +333,7 @@ and check_exp' env (exp:Ir.exp) : unit = | ActorDotE(exp1,{it = Syntax.Name n;_}) | DotE (exp1, {it = Syntax.Name n;_}) -> begin - check_exp env exp1; + check_exp env exp1; let t1 = immute_typ exp1 in let sort, tfs = try T.as_obj_sub n env.cons t1 with @@ -389,7 +358,6 @@ and check_exp' env (exp:Ir.exp) : unit = | AssignE (exp1, exp2) -> check_exp env exp1; check_exp env exp2; - (* let t1 = infer_exp_mut env exp1 in *) let t2 = try T.as_mut (typ exp1) with Invalid_argument _ -> error env exp.at "expected mutable assignment target" in @@ -769,17 +737,14 @@ and check_open_typ_binds env typ_binds = cs,ce and check_dec env dec = - let check p = - if p then ignore - else fun fmt -> error env dec.at fmt - in - let (<:) t1 t2 = - if (T.sub env.cons t1 t2) - then () - else error env dec.at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) - in + (* helpers *) + let check p = check env dec.at p in + let (<:) t1 t2 = check_sub env dec.at t1 t2 in + (* check effect *) + check (E.Ir.infer_effect_dec dec <= E.eff dec) + "inferred effect not a subtype of expected effect"; + (* check typing *) let t = typ dec in - begin match dec.it with | ExpD exp -> check_exp env exp; @@ -809,11 +774,6 @@ and check_dec env dec = let env' = adjoin_typs env ce in check_typ env' (T.open_ ts typ); T.unit <: t; - end; - let e = E.Ir.infer_effect_dec dec in - assert (T.Triv < T.Await); - if not (e <= E.eff dec) then - error env dec.at "inferred effect not a subtype of expected effect"; and check_block env t decs at : scope = let scope = gather_block_decs env decs in From 53245d9919e209d8e232395f4fbccba20ff18e50 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Sat, 26 Jan 2019 17:52:06 +0000 Subject: [PATCH 40/45] remove infer_pat*; replace by check_pat*; rename other infer_ to type_ --- src/check_ir.ml | 139 ++++++++++++++++++------------------------------ 1 file changed, 53 insertions(+), 86 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 92b0a0068f3..8705c223615 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -9,6 +9,7 @@ module E = Effect (* TODO: add type and term predicate to rule out constructs after passes, We could even compose these I guess.... + dereferencing is still implicit in the IR (see immut_typ below) - consider making it explicit as part of desugaring. *) (* helpers *) @@ -17,7 +18,6 @@ let typ = E.typ let immute_typ p = T.as_immut (typ p) - (* Scope (the external interface) *) type val_env = T.typ T.Env.t @@ -112,7 +112,7 @@ let check_sub env at t1 t2 = then () else error env at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) -let infer_mut mut : T.typ -> T.typ = +let make_mut mut : T.typ -> T.typ = match mut.it with | Syntax.Const -> fun t -> t | Syntax.Var -> fun t -> T.Mut t @@ -234,7 +234,7 @@ and check_inst_bounds env tbs typs at = (* Literals *) -let infer_lit env lit at : T.prim = +let type_lit env lit at : T.prim = let open Syntax in match lit with | NullLit -> T.Null @@ -283,7 +283,7 @@ let rec check_exp env (exp:Ir.exp) : unit = else T.as_immut t0 <: t | LitE lit -> - T.Prim (infer_lit env lit exp.at) <: t + T.Prim ( type_lit env lit exp.at) <: t | UnE (ot, op, exp1) -> check (Operator.has_unop ot op) "unary operator is not defined for operand type"; check_exp env exp1; @@ -325,7 +325,7 @@ let rec check_exp env (exp:Ir.exp) : unit = end | ActorE ( id, fields, t0) -> let env' = { env with async = false } in - let t1 = infer_obj env' T.Actor id t fields in + let t1 = type_obj env' T.Actor id t fields in let t2 = T.promote env.cons t in check (T.is_obj t2) "bad annotation (object type expected)"; t1 <: t2; @@ -398,8 +398,7 @@ let rec check_exp env (exp:Ir.exp) : unit = (immute_typ exp2) <: T.open_ insts t2; T.open_ insts t3 <: t; | BlockE (decs, t0) -> - let t1, scope = infer_block env decs exp.at in - (* let _t2 = try T.avoid env.cons scope.con_env t1 with T.Unavoidable c -> assert false in *) + let t1, scope = type_block env decs exp.at in let env' = adjoin env scope in check_typ env t0; check (T.eq env.cons t T.unit || T.eq env'.cons t1 t0) "unexpected expected block type"; @@ -445,7 +444,8 @@ let rec check_exp env (exp:Ir.exp) : unit = let t1, t2 = T.as_mono_func_sub env.cons t0 in T.unit <: t1; let t2' = T.as_opt_sub env.cons t2 in - let ve = check_pat_exhaustive env t2' pat in + let ve = check_pat_exhaustive env pat in + pat.note <: t2'; check_exp (adjoin_vals env ve) exp2; immute_typ exp2 <: T.unit; T.unit <: t @@ -547,7 +547,8 @@ and check_cases env t_pat t cases = List.iter (check_case env t_pat t) cases and check_case env t_pat t {it = {pat; exp}; _} = - let ve = check_pat env t_pat pat in + let ve = check_pat env pat in + check_sub env pat.at pat.note t_pat; check_exp (adjoin_vals env ve) exp; if not (T.sub env.cons (immute_typ exp) t) then error env exp.at "bad case" @@ -567,81 +568,59 @@ and gather_pat env ve0 pat : val_env = | TupP pats -> List.fold_left go ve pats | AltP (pat1, pat2) -> - go ve pat1 + ve | OptP pat1 -> go ve pat1 in T.Env.adjoin ve0 (go T.Env.empty pat) -and infer_pat_exhaustive env pat : T.typ * val_env = - let t, ve = infer_pat env pat in +and check_pat_exhaustive env pat : val_env = + let ve = check_pat env pat in (* TODO: actually check exhaustiveness *) - t, ve + ve -and infer_pat env pat : T.typ * val_env = +and check_pat env pat : val_env = assert (pat.note <> T.Pre); - let t, ve = infer_pat' env pat in - if not (T.sub env.cons pat.note t) then (* TBR: should we allow contra-variance ?*) - error env pat.at "pattern of type \n %s\n cannot consume expected type \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons pat.note); - t, ve - -and infer_pat' env pat : T.typ * val_env = + let (<:) = check_sub env pat.at in + let t = pat.note in match pat.it with - | WildP -> - (pat.note, T.Env.empty) - | VarP id -> - (pat.note, T.Env.singleton id.it pat.note) + | WildP -> T.Env.empty + | VarP id -> T.Env.singleton id.it pat.note | LitP lit -> - let t = T.Prim (infer_lit env lit pat.at) in - if not (T.sub env.cons t pat.note) then (* TBR isn't this test the wrong way around? *) - error env pat.at "type of literal pattern \n %s\n cannot produce expected type \n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons pat.note); - (pat.note, T.Env.empty) + let t1 = T.Prim ( type_lit env lit pat.at) in + t1 <: t; + T.Env.empty | TupP pats -> - let ts, ve = infer_pats pat.at env pats [] T.Env.empty in - T.Tup ts, ve + let ve = check_pats pat.at env pats T.Env.empty in + let ts = List.map (fun pat -> pat.note) pats in + T.Tup ts <: t; + ve | OptP pat1 -> - let t1, ve = infer_pat env pat1 in - T.Opt t1, ve + let ve = check_pat env pat1 in + T.Opt pat1.note <: t; + ve | AltP (pat1, pat2) -> - let t1, ve1 = infer_pat env pat1 in - let t2, ve2 = infer_pat env pat2 in - let t = T.lub env.cons t1 t2 in + let ve1 = check_pat env pat1 in + let ve2 = check_pat env pat2 in + pat1.note <: t; + pat2.note <: t; if ve1 <> T.Env.empty || ve2 <> T.Env.empty then error env pat.at "variables are not allowed in pattern alternatives"; - t, T.Env.empty + T.Env.empty -and infer_pats at env pats ts ve : T.typ list * val_env = +and check_pats at env pats ve : val_env = match pats with - | [] -> List.rev ts, ve + | [] -> ve | pat::pats' -> - let t, ve1 = infer_pat env pat in + let ve1 = check_pat env pat in let ve' = disjoint_union env at "duplicate binding for %s in pattern" ve ve1 in - infer_pats at env pats' (t::ts) ve' - - -and check_pat_exhaustive env t pat : val_env = - (* TODO: check exhaustiveness? *) - check_pat env t pat - -and check_pat env t pat : val_env = - assert (pat.note <> T.Pre); - let (t,ve) = infer_pat env pat in - let t' = T.normalize env.cons t in - if not (T.sub env.cons t t') then - error env pat.at "type of pattern \n %s\n cannot consume expected type \n %s" - (T.string_of_typ_expand env.cons t') - (T.string_of_typ_expand env.cons pat.note); - ve + check_pats at env pats' ve' (* Objects *) -and infer_obj env s id t fields : T.typ = +and type_obj env s id t fields : T.typ = let ve = gather_exp_fields env id.it t fields in let env' = adjoin_vals env ve in - let tfs, _ve = infer_exp_fields env' s id.it t fields in + let tfs, _ve = type_exp_fields env' s id.it t fields in T.Obj(s,tfs) and gather_exp_fields env id t fields : val_env = @@ -652,12 +631,12 @@ and gather_exp_field env ve field : val_env = let {id; exp; mut; priv;_} : exp_field' = field.it in if T.Env.mem id.it ve then error env id.at "duplicate field name %s in object" id.it; - T.Env.add id.it (infer_mut mut exp.note.Syntax.note_typ) ve + T.Env.add id.it ( make_mut mut (immute_typ exp)) ve -and infer_exp_fields env s id t fields : T.field list * val_env = +and type_exp_fields env s id t fields : T.field list * val_env = let env' = add_val env id t in let tfs, ve = - List.fold_left (infer_exp_field env' s) ([], T.Env.empty) fields in + List.fold_left (type_exp_field env' s) ([], T.Env.empty) fields in List.sort T.compare_field tfs, ve and is_func_exp exp = @@ -670,7 +649,7 @@ and is_func_dec dec = | FuncD _ -> true | _ -> Printf.printf "[2]%!"; false -and infer_exp_field env s (tfs, ve) field : T.field list * val_env = +and type_exp_field env s (tfs, ve) field : T.field list * val_env = let {id; name; exp; mut; priv} = field.it in let t = match T.Env.find id.it env.vals with @@ -705,12 +684,12 @@ and infer_exp_field env s (tfs, ve) field : T.field list * val_env = (* Blocks and Declarations *) -and infer_block env decs at : T.typ * scope = +and type_block env decs at : T.typ * scope = let scope = gather_block_decs env decs in - let t = infer_block_exps (adjoin env scope) decs in + let t = type_block_exps (adjoin env scope) decs in t, scope -and infer_block_exps env decs : T.typ = +and type_block_exps env decs : T.typ = match decs with | [] -> T.unit | [dec] -> @@ -718,7 +697,7 @@ and infer_block_exps env decs : T.typ = immute_typ dec; | dec::decs' -> check_dec env dec; - infer_block_exps env decs' + type_block_exps env decs' and cons_of_typ_binds typ_binds = let con_of_typ_bind tp = @@ -742,7 +721,7 @@ and check_dec env dec = let (<:) t1 t2 = check_sub env dec.at t1 t2 in (* check effect *) check (E.Ir.infer_effect_dec dec <= E.eff dec) - "inferred effect not a subtype of expected effect"; + "inferred effect not a subtype of expected effect"; (* check typing *) let t = typ dec in match dec.it with @@ -756,7 +735,7 @@ and check_dec env dec = let t0 = T.Env.find id.it env.vals in let _cs,ce = check_open_typ_binds env typ_binds in let env' = adjoin_typs env ce in - let t1, ve = infer_pat_exhaustive env' pat in + let ve = check_pat_exhaustive env' pat in check_typ env' t2; let env'' = {env' with labs = T.Env.empty; rets = Some t2; async = false} in @@ -794,21 +773,10 @@ and check_block_exps env t decs at = check_dec env dec; check_block_exps env t decs' at -(* -and check_dec env t dec = - let t' = infer_dec env dec in - (* TBR: special-case unit? *) - if not (T.eq env.cons t T.unit || T.sub env.cons t' t) then - error env dec.at "expression of type\n %s\ncannot produce expected type\n %s" - (T.string_of_typ_expand env.cons t) - (T.string_of_typ_expand env.cons t') - *) - - and gather_block_decs env decs = List.fold_left (gather_dec env) empty_scope decs -and gather_dec env scope dec : scope = +and gather_dec env scope dec : scope = match dec.it with | ExpD _ -> scope @@ -856,7 +824,6 @@ let check_prog scope prog : scope = let env = env_of_scope scope in check_block env T.unit prog.it prog.at -let infer_prog scope prog : (T.typ * scope) = +let type_prog scope prog : (T.typ * scope) = let env = env_of_scope scope in - infer_block env prog.it prog.at - + type_block env prog.it prog.at From 8f6c1930330132f5ffe54443dd34a608d74161bb Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Sat, 26 Jan 2019 19:44:54 +0000 Subject: [PATCH 41/45] revise typing.ml to (re) annotate rvalues with dereferenced type; simplify check_ir to avoid explicit dereferencing --- src/check_ir.ml | 88 +++++++++++++++++++++++++------------------------ src/typing.ml | 7 ++-- src/value.ml | 2 +- 3 files changed, 51 insertions(+), 46 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 8705c223615..812339ea0d1 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -16,7 +16,9 @@ module E = Effect let typ = E.typ -let immute_typ p = T.as_immut (typ p) +let immute_typ p = + assert (not (T.is_mut (typ p))); + (typ p) (* Scope (the external interface) *) @@ -287,28 +289,28 @@ let rec check_exp env (exp:Ir.exp) : unit = | UnE (ot, op, exp1) -> check (Operator.has_unop ot op) "unary operator is not defined for operand type"; check_exp env exp1; - (immute_typ exp1) <: ot; + typ exp1 <: ot; ot <: t; | BinE (ot, exp1, op, exp2) -> check (Operator.has_binop ot op) "binary operator is not defined for operand type"; check_exp env exp1; check_exp env exp2; - immute_typ exp1 <: ot; - immute_typ exp2 <: ot; + typ exp1 <: ot; + typ exp2 <: ot; ot <: t; | RelE (ot,exp1, op, exp2) -> check (Operator.has_relop ot op) "relational operator is not defined for operand type"; check_exp env exp1; check_exp env exp2; - immute_typ exp1 <: ot; - immute_typ exp2 <: ot; + typ exp1 <: ot; + typ exp2 <: ot; T.bool <: t; | TupE exps -> List.iter (check_exp env) exps; - T.Tup (List.map immute_typ exps) <: t; + T.Tup (List.map typ exps) <: t; | OptE exp1 -> check_exp env exp1; - T.Opt (immute_typ exp1) <: t; + T.Opt (typ exp1) <: t; | ProjE (exp1, n) -> begin check_exp env exp1; @@ -334,7 +336,7 @@ let rec check_exp env (exp:Ir.exp) : unit = | DotE (exp1, {it = Syntax.Name n;_}) -> begin check_exp env exp1; - let t1 = immute_typ exp1 in + let t1 = typ exp1 in let sort, tfs = try T.as_obj_sub n env.cons t1 with | Invalid_argument _ -> @@ -361,23 +363,23 @@ let rec check_exp env (exp:Ir.exp) : unit = let t2 = try T.as_mut (typ exp1) with Invalid_argument _ -> error env exp.at "expected mutable assignment target" in - immute_typ exp2 <: t2; + typ exp2 <: t2; T.unit <: t; | ArrayE (mut, t0, exps) -> List.iter (check_exp env) exps; - List.iter (fun e -> immute_typ e <: t0) exps; + List.iter (fun e -> typ e <: t0) exps; let t1 = T.Array (match mut.it with Syntax.Const -> t0 | Syntax.Var -> T.Mut t0) in t1 <: t; | IdxE (exp1, exp2) -> check_exp env exp1; check_exp env exp2; - let t1 = T.promote env.cons (immute_typ exp1) in + let t1 = T.promote env.cons (typ exp1) in let t2 = try T.as_array_sub env.cons t1 with | Invalid_argument _ -> error env exp1.at "expected array type, but expression produces type\n %s" (T.string_of_typ_expand env.cons t1) in - immute_typ exp2 <: T.nat; + typ exp2 <: T.nat; if T.is_mut t then t2 <: t else @@ -386,7 +388,7 @@ let rec check_exp env (exp:Ir.exp) : unit = check_exp env exp1; check_exp env exp2; (* TODO: check call_conv (assuming there's something to check) *) - let t1 = T.promote env.cons (immute_typ exp1) in + let t1 = T.promote env.cons (typ exp1) in let tbs, t2, t3 = try T.as_func_sub (List.length insts) env.cons t1 with | Invalid_argument _ -> @@ -395,7 +397,7 @@ let rec check_exp env (exp:Ir.exp) : unit = in check_inst_bounds env tbs insts exp.at; check_exp env exp2; - (immute_typ exp2) <: T.open_ insts t2; + (typ exp2) <: T.open_ insts t2; T.open_ insts t3 <: t; | BlockE (decs, t0) -> let t1, scope = type_block env decs exp.at in @@ -405,14 +407,14 @@ let rec check_exp env (exp:Ir.exp) : unit = t0 <: t; | IfE (exp1, exp2, exp3) -> check_exp env exp1; - immute_typ exp1 <: T.bool; + typ exp1 <: T.bool; check_exp env exp2; - immute_typ exp2 <: t; + typ exp2 <: t; check_exp env exp3; - immute_typ exp3 <: t; + typ exp3 <: t; | SwitchE (exp1, cases) -> check_exp env exp1; - let t1 = T.promote env.cons (immute_typ exp1) in + let t1 = T.promote env.cons (typ exp1) in (* if not env.pre then if not (Coverage.check_cases env.cons cases t1) then warn env exp.at "the cases in this switch do not cover all possible values"; @@ -420,24 +422,24 @@ let rec check_exp env (exp:Ir.exp) : unit = check_cases env t1 t cases; | WhileE (exp1, exp2) -> check_exp env exp1; - immute_typ exp1 <: T.bool; + typ exp1 <: T.bool; check_exp env exp2; - immute_typ exp2 <: T.unit; + typ exp2 <: T.unit; T.unit <: t; | LoopE (exp1, expo) -> check_exp env exp1; - immute_typ exp1 <: T.unit; + typ exp1 <: T.unit; begin match expo with | Some exp2 -> check_exp env exp2; - (immute_typ exp2) <: T.bool; + (typ exp2) <: T.bool; | _ -> () end; T.Non <: t; (* redundant *) | ForE (pat, exp1, exp2) -> begin check_exp env exp1; - let t1 = T.promote env.cons (immute_typ exp1) in + let t1 = T.promote env.cons (typ exp1) in try let _, tfs = T.as_obj_sub "next" env.cons t1 in let t0 = T.lookup_field "next" tfs in @@ -447,7 +449,7 @@ let rec check_exp env (exp:Ir.exp) : unit = let ve = check_pat_exhaustive env pat in pat.note <: t2'; check_exp (adjoin_vals env ve) exp2; - immute_typ exp2 <: T.unit; + typ exp2 <: T.unit; T.unit <: t with Invalid_argument _ -> error env exp1.at "expected iterable type, but expression has type\n %s" @@ -457,7 +459,7 @@ let rec check_exp env (exp:Ir.exp) : unit = assert (t0 <> T.Pre); check_typ env t0; check_exp (add_lab env id.it t0) exp1; - immute_typ exp1 <: t0; + typ exp1 <: t0; t0 <: t; | BreakE (id, exp1) -> begin @@ -466,7 +468,7 @@ let rec check_exp env (exp:Ir.exp) : unit = error env id.at "unbound label %s" id.it | Some t1 -> check_exp env exp1; - immute_typ exp1 <: t1; + typ exp1 <: t1; T.Non <: t1; end; | RetE exp1 -> @@ -477,11 +479,11 @@ let rec check_exp env (exp:Ir.exp) : unit = | Some t0 -> assert (t0 <> T.Pre); check_exp env exp1; - immute_typ exp1 <: t0; + typ exp1 <: t0; T.Non <: t; end; | AsyncE exp1 -> - let t1 = immute_typ exp1 in + let t1 = typ exp1 in let env' = {env with labs = T.Env.empty; rets = Some t1; async = true} in check_exp env' exp1; @@ -490,7 +492,7 @@ let rec check_exp env (exp:Ir.exp) : unit = | AwaitE exp1 -> check env.async "misplaced await"; check_exp env exp1; - let t1 = T.promote env.cons (immute_typ exp1) in + let t1 = T.promote env.cons (typ exp1) in let t2 = try T.as_async_sub env.cons t1 with Invalid_argument _ -> error env exp1.at "expected async type, but expression has type\n %s" @@ -499,19 +501,19 @@ let rec check_exp env (exp:Ir.exp) : unit = t2 <: t; | AssertE exp1 -> check_exp env exp1; - immute_typ exp1 <: T.bool; + typ exp1 <: T.bool; T.unit <: t; | IsE (exp1, exp2) -> - (* TBR: restrict immute_typ exp1 to objects? *) + (* TBR: restrict typ exp1 to objects? *) check_exp env exp1; check_exp env exp2; - immute_typ exp2 <: T.Class; + typ exp2 <: T.Class; T.bool <: t; | DeclareE (id, t0, exp1) -> check_typ env t0; let env' = adjoin_vals env (T.Env.singleton id.it t0) in check_exp env' exp1; - (immute_typ exp1) <: t; + (typ exp1) <: t; | DefineE (id, mut, exp1) -> check_exp env exp1; begin @@ -520,13 +522,13 @@ let rec check_exp env (exp:Ir.exp) : unit = | Some t0 -> match mut.it with | Syntax.Const -> - immute_typ exp1 <: t0 + typ exp1 <: t0 | Syntax.Var -> let t0 = try T.as_mut t0 with | Invalid_argument _ -> error env exp.at "expected mutable %s" (T.string_of_typ t0) in - immute_typ exp1 <: t0 + typ exp1 <: t0 end; T.unit <: t | NewObjE (sort, labids, t0) -> @@ -550,7 +552,7 @@ and check_case env t_pat t {it = {pat; exp}; _} = let ve = check_pat env pat in check_sub env pat.at pat.note t_pat; check_exp (adjoin_vals env ve) exp; - if not (T.sub env.cons (immute_typ exp) t) then + if not (T.sub env.cons (typ exp) t) then error env exp.at "bad case" (* Patterns *) @@ -631,7 +633,7 @@ and gather_exp_field env ve field : val_env = let {id; exp; mut; priv;_} : exp_field' = field.it in if T.Env.mem id.it ve then error env id.at "duplicate field name %s in object" id.it; - T.Env.add id.it ( make_mut mut (immute_typ exp)) ve + T.Env.add id.it ( make_mut mut (typ exp)) ve and type_exp_fields env s id t fields : T.field list * val_env = let env' = add_val env id t in @@ -658,7 +660,7 @@ and type_exp_field env s (tfs, ve) field : T.field list * val_env = | t -> begin check_exp (adjoin_vals env ve) exp; - if not (T.sub env.cons (immute_typ exp) (T.as_immut t)) then + if not (T.sub env.cons (typ exp) (T.as_immut t)) then error env field.at "subtype violation"; if (mut.it = Syntax.Var) <> T.is_mut t then error env field.at @@ -694,7 +696,7 @@ and type_block_exps env decs : T.typ = | [] -> T.unit | [dec] -> check_dec env dec; - immute_typ dec; + typ dec; | dec::decs' -> check_dec env dec; type_block_exps env decs' @@ -727,7 +729,7 @@ and check_dec env dec = match dec.it with | ExpD exp -> check_exp env exp; - (immute_typ exp) <: t + (typ exp) <: t | LetD (_, exp) | VarD (_, exp) -> check_exp env exp; T.unit <: t @@ -767,7 +769,7 @@ and check_block_exps env t decs at = (T.string_of_typ_expand env.cons t) | [dec] -> check_dec env dec; - if not (T.is_unit t || T.sub env.cons (immute_typ dec) t) then + if not (T.is_unit t || T.sub env.cons (typ dec) t) then error env at "subtyp violation" | dec::decs' -> check_dec env dec; @@ -786,7 +788,7 @@ and gather_dec env scope dec : scope = | VarD (id, exp) -> if T.Env.mem id.it scope.val_env then error env dec.at "duplicate definition for %s in block" id.it; - let ve = T.Env.add id.it (T.Mut (immute_typ exp)) scope.val_env in + let ve = T.Env.add id.it (T.Mut (typ exp)) scope.val_env in { scope with val_env = ve} | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> let func_sort = call_conv.Value.sort in diff --git a/src/typing.ml b/src/typing.ml index 1ac5b7fc277..f8f1a4dfcf0 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -308,7 +308,7 @@ let check_lit env t lit at = lit := Word32Lit (check_word32 env at s) | T.Prim T.Word64, PreLit (s, (T.Nat | T.Int)) -> lit := Word64Lit (check_word64 env at s) - | T.Prim T.Float, PreLit (s, (T.Nat | T.Int | T.Float)) -> + | T.Prim T.Float, PreLit (s, (T.Nat | T.Int | T.Float)) -> lit := FloatLit (check_float env at s) | t, _ -> let t' = T.Prim (infer_lit env lit at) in @@ -325,7 +325,10 @@ let isAsyncE exp = | _ -> false let rec infer_exp env exp : T.typ = - T.as_immut (infer_exp_mut env exp) + let t = T.as_immut (infer_exp_mut env exp) in + if not env.pre then + exp.note <- {exp.note with note_typ = T.as_immut exp.note.note_typ}; + t and infer_exp_promote env exp : T.typ = let t = infer_exp env exp in diff --git a/src/value.ml b/src/value.ml index eff4e4c98f3..8d9f4f5859c 100644 --- a/src/value.ml +++ b/src/value.ml @@ -201,7 +201,7 @@ let call_conv_of_typ typ = match typ with | Type.Func(sort, control, tbds, dom, res) -> { sort; control; n_args = List.length dom; n_res = List.length res } - | _ -> raise (Invalid_argument "call_conv_of_typ") + | _ -> raise (Invalid_argument ("call_conv_of_typ"^T.string_of_typ typ)) type func = (value -> value cont -> unit) From 1e5001fd884b709b5715786bd6d748582e2f7803 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 30 Jan 2019 00:24:39 +0000 Subject: [PATCH 42/45] address joachim's comments and refactor some remaining error as checks --- src/check_ir.ml | 148 +++++++++++++++++++++--------------------------- src/pipeline.ml | 2 +- 2 files changed, 66 insertions(+), 84 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index 812339ea0d1..f00233ffa2d 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -13,7 +13,7 @@ module E = Effect *) (* helpers *) - +let (==>) p q = not p || q let typ = E.typ let immute_typ p = @@ -106,13 +106,13 @@ let check_ids env ids = ignore ) let check env at p = - if p then ignore - else fun fmt -> error env at fmt + if p then ignore + else error env at let check_sub env at t1 t2 = - if (T.sub env.cons t1 t2) - then () - else error env at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) + if (T.sub env.cons t1 t2) + then () + else error env at "subtype violation %s %s" (T.string_of_typ t1) (T.string_of_typ t2) let make_mut mut : T.typ -> T.typ = match mut.it with @@ -135,7 +135,7 @@ let rec check_typ env typ : unit = | T.Non -> () | T.Shared -> () | T.Class -> () - | T.Prim _ -> () + | T.Prim _ -> () | T.Array typ -> check_typ env typ | T.Tup typs -> @@ -158,15 +158,11 @@ let rec check_typ env typ : unit = end; if sort = T.Call T.Sharable then begin let t1 = T.seq ts1 in - if not (T.sub env'.cons t1 T.Shared) then - error env no_region "shared function has non-shared parameter type\n %s" - (T.string_of_typ_expand env'.cons t1); + check_sub env' no_region t1 T.Shared; match ts2 with | [] -> () | [T.Async t2] -> - if not (T.sub env'.cons t2 T.Shared) then - error env no_region "shared function has non-shared result type\n %s" - (T.string_of_typ_expand env'.cons t2); + check_sub env' no_region t2 T.Shared; | _ -> error env no_region "shared function has non-async result type\n %s" (T.string_of_typ_expand env'.cons (T.seq ts2)) end @@ -174,9 +170,7 @@ let rec check_typ env typ : unit = check_typ env typ | T.Async typ -> let t' = T.promote env.cons typ in - if not (T.sub env.cons t' T.Shared) then - error env no_region "async type has non-shared parameter type\n %s" - (T.string_of_typ_expand env.cons t') + check_sub env no_region t' T.Shared | T.Like typ -> check_typ env typ | T.Obj (sort, fields) -> @@ -189,21 +183,20 @@ let rec check_typ env typ : unit = in check_ids env (List.map (fun (field : T.field) -> field.T.name) fields); List.iter (check_typ_field env sort) fields; - if not (sorted fields) then - error env no_region "object type's fields are not sorted\n %s" - (T.string_of_typ_expand env.cons typ); + check env no_region (sorted fields) "object type's fields are not sorted" | T.Mut typ -> check_typ env typ and check_typ_field env s typ_field : unit = let {T.name; T.typ} = typ_field in check_typ env typ; - if s = T.Actor && not (T.is_func (T.promote env.cons typ)) then - error env no_region "actor field %s has non-function type\n %s" - name (T.string_of_typ_expand env.cons typ); - if s <> T.Object T.Local && not (T.sub env.cons typ T.Shared) then - error env no_region "shared object or actor field %s has non-shared type\n %s" - name (T.string_of_typ_expand env.cons typ) + check env no_region + (s <> T.Actor || T.is_func (T.promote env.cons typ)) + "actor field has non-function type"; + check env no_region + (s = T.Object T.Local || T.sub env.cons typ T.Shared) + "shared object or actor field has non-shared type" + and check_typ_binds env typ_binds : T.con list * con_env = let ts,ce = Type.open_binds env.cons typ_binds in @@ -222,10 +215,8 @@ and check_typ_bounds env (tbs : T.bind list) typs at : unit = match tbs, typs with | tb::tbs', typ::typs' -> check_typ env typ; - if not (T.sub env.cons typ tb.T.bound) then - error env no_region "type argument\n %s\ndoes not match parameter bound\n %s" - (T.string_of_typ_expand env.cons typ) - (T.string_of_typ_expand env.cons tb.T.bound); + check env at (T.sub env.cons typ tb.T.bound) + "type argument does not match parameter bound"; check_typ_bounds env tbs' typs' at | [], [] -> () | [], _ -> error env at "too many type arguments" @@ -236,7 +227,7 @@ and check_inst_bounds env tbs typs at = (* Literals *) -let type_lit env lit at : T.prim = +let type_lit env lit at : T.prim = let open Syntax in match lit with | NullLit -> T.Null @@ -269,6 +260,12 @@ let rec check_exp env (exp:Ir.exp) : unit = (* helpers *) let check p = check env exp.at p in let (<:) t1 t2 = check_sub env exp.at t1 t2 in + let (<~) t1 t2 = + if T.is_mut t2 then + t1 <: t2 + else + T.as_immut t1 <: t2 + in (* check effect *) check (E.Ir.infer_effect_exp exp <= E.eff exp) "inferred effect not a subtype of expected effect"; @@ -280,12 +277,9 @@ let rec check_exp env (exp:Ir.exp) : unit = let t0 = try T.Env.find id.it env.vals with | Not_found -> error env id.at "unbound variable %s" id.it in - if T.is_mut t then - t0 <: t - else - T.as_immut t0 <: t + t0 <~ t | LitE lit -> - T.Prim ( type_lit env lit exp.at) <: t + T.Prim (type_lit env lit exp.at) <: t | UnE (ot, op, exp1) -> check (Operator.has_unop ot op) "unary operator is not defined for operand type"; check_exp env exp1; @@ -349,10 +343,7 @@ let rec check_exp env (exp:Ir.exp) : unit = | _ -> false) "sort mismatch"; match List.find_opt (fun {T.name; _} -> name = n) tfs with | Some {T.typ = tn;_} -> - if T.is_mut t then - tn <: t - else - T.as_immut tn <: t + tn <~ t | None -> error env exp1.at "field name %s does not exist in type\n %s" n (T.string_of_typ_expand env.cons t1) @@ -380,10 +371,7 @@ let rec check_exp env (exp:Ir.exp) : unit = (T.string_of_typ_expand env.cons t1) in typ exp2 <: T.nat; - if T.is_mut t then - t2 <: t - else - T.as_immut t2 <: t + t2 <~ t | CallE (call_conv, exp1, insts, exp2) -> check_exp env exp1; check_exp env exp2; @@ -588,7 +576,7 @@ and check_pat env pat : val_env = | WildP -> T.Env.empty | VarP id -> T.Env.singleton id.it pat.note | LitP lit -> - let t1 = T.Prim ( type_lit env lit pat.at) in + let t1 = T.Prim (type_lit env lit pat.at) in t1 <: t; T.Env.empty | TupP pats -> @@ -605,8 +593,8 @@ and check_pat env pat : val_env = let ve2 = check_pat env pat2 in pat1.note <: t; pat2.note <: t; - if ve1 <> T.Env.empty || ve2 <> T.Env.empty then - error env pat.at "variables are not allowed in pattern alternatives"; + check env pat.at (T.Env.is_empty ve1 && T.Env.is_empty ve2) + "variables are not allowed in pattern alternatives"; T.Env.empty and check_pats at env pats ve : val_env = @@ -622,7 +610,7 @@ and check_pats at env pats ve : val_env = and type_obj env s id t fields : T.typ = let ve = gather_exp_fields env id.it t fields in let env' = adjoin_vals env ve in - let tfs, _ve = type_exp_fields env' s id.it t fields in + let tfs, _ve = type_exp_fields env' s id.it t fields in T.Obj(s,tfs) and gather_exp_fields env id t fields : val_env = @@ -644,38 +632,32 @@ and type_exp_fields env s id t fields : T.field list * val_env = and is_func_exp exp = match exp.it with | BlockE ([dec],_)-> is_func_dec dec - | _ -> Printf.printf "[1]%!"; false + | _ -> false and is_func_dec dec = match dec.it with | FuncD _ -> true - | _ -> Printf.printf "[2]%!"; false + | _ -> false and type_exp_field env s (tfs, ve) field : T.field list * val_env = let {id; name; exp; mut; priv} = field.it in - let t = - match T.Env.find id.it env.vals with - | T.Pre -> - assert false - | t -> - begin - check_exp (adjoin_vals env ve) exp; - if not (T.sub env.cons (typ exp) (T.as_immut t)) then - error env field.at "subtype violation"; - if (mut.it = Syntax.Var) <> T.is_mut t then - error env field.at - "%smutable field %s cannot produce expected %smutable field of type\n %s" - (if mut.it = Syntax.Var then "" else "im") id.it - (if T.is_mut t then "" else "im") - (T.string_of_typ_expand env.cons (T.as_immut t)) - end; - t + let t = try T.Env.find id.it env.vals with + | Not_found -> error env field.at "field typing not found" in - if s = T.Actor && priv.it = Syntax.Public && not (is_func_exp exp) then - error env field.at "public actor field is not a function"; - if s <> T.Object T.Local && priv.it = Syntax.Public && not (T.sub env.cons t T.Shared) then - error env field.at "public shared object or actor field %s has non-shared type\n %s" - (Syntax.string_of_name name.it) (T.string_of_typ_expand env.cons t); + assert (t <> T.Pre); + check_exp (adjoin_vals env ve) exp; + check_sub env field.at (typ exp) (T.as_immut t); + check env field.at ((mut.it = Syntax.Var) = T.is_mut t) + "inconsistent mutability of field and field type"; + check env field.at + ((s = T.Actor && priv.it = Syntax.Public) ==> + is_func_exp exp) + "public actor field is not a function"; + check env field.at + (if (s <> T.Object T.Local && priv.it = Syntax.Public) + then T.sub env.cons t T.Shared + else true) + "public shared object or actor field has non-shared type"; let ve' = T.Env.add id.it t ve in let tfs' = if priv.it = Syntax.Private @@ -739,10 +721,12 @@ and check_dec env dec = let env' = adjoin_typs env ce in let ve = check_pat_exhaustive env' pat in check_typ env' t2; + check (Type.is_async t2 ==> isAsyncE exp) + "shared function with async type has non-async body"; let env'' = {env' with labs = T.Env.empty; rets = Some t2; async = false} in check_exp (adjoin_vals env'' ve) exp; - check (T.sub env'.cons (typ exp) t2) "function body subtype violation"; + check_sub env' dec.at (typ exp) t2; t0 <: t; | TypD (c, k) -> let (binds,typ) = @@ -764,13 +748,11 @@ and check_block env t decs at : scope = and check_block_exps env t decs at = match decs with | [] -> - if not (T.sub env.cons T.unit t) then - error env at "empty block cannot produce expected type\n %s" - (T.string_of_typ_expand env.cons t) + check_sub env at T.unit t | [dec] -> check_dec env dec; - if not (T.is_unit t || T.sub env.cons (typ dec) t) then - error env at "subtyp violation" + check env at (T.is_unit t || T.sub env.cons (typ dec) t) + "declaration does not produce expect type" | dec::decs' -> check_dec env dec; check_block_exps env t decs' at @@ -786,8 +768,9 @@ and gather_dec env scope dec : scope = let ve = gather_pat env scope.val_env pat in { scope with val_env = ve} | VarD (id, exp) -> - if T.Env.mem id.it scope.val_env then - error env dec.at "duplicate definition for %s in block" id.it; + check env dec.at + (not (T.Env.mem id.it scope.val_env)) + "duplicate variable definition in block"; let ve = T.Env.add id.it (T.Mut (typ exp)) scope.val_env in { scope with val_env = ve} | FuncD (call_conv, id, typ_binds, pat, typ, exp) -> @@ -795,8 +778,6 @@ and gather_dec env scope dec : scope = let cs = cons_of_typ_binds typ_binds in let t1 = pat.note in let t2 = typ in - if Type.is_async t2 && not (isAsyncE exp) then - error env dec.at "shared function with async type has non-async body"; let ts1 = match call_conv.Value.n_args with | 1 -> [t1] | _ -> T.as_seq t1 @@ -815,8 +796,9 @@ and gather_dec env scope dec : scope = let ve' = T.Env.add id.it t scope.val_env in {scope with val_env = ve'} | TypD (c, k) -> - if Con.Env.mem c scope.con_env then - error env dec.at "duplicate definition for type %s in block" (Con.to_string c); + check env dec.at + (not (Con.Env.mem c scope.con_env)) + "duplicate definition of type in block"; let ce' = Con.Env.add c k scope.con_env in {scope with con_env = ce'} diff --git a/src/pipeline.ml b/src/pipeline.ml index 6a18fda894f..c3ff5ebd9e4 100644 --- a/src/pipeline.ml +++ b/src/pipeline.ml @@ -291,7 +291,7 @@ let compile_with check mode name : compile_result = let prog = async_lowering true prog name in let prog = tailcall_optimization true prog name in let prog = Desugar.prog prog in - ignore (Check_ir.check_prog initial_stat_env prog); + ignore (Check_ir.check_prog initial_stat_env prog); phase "Compiling" name; let module_ = Compile.compile mode name prelude [prog] in Ok module_ From 47ad813e560ba22253df45e09a5a936759dfafaa Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 30 Jan 2019 00:29:51 +0000 Subject: [PATCH 43/45] refactor <~ --- src/check_ir.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index f00233ffa2d..d380376d1af 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -261,10 +261,7 @@ let rec check_exp env (exp:Ir.exp) : unit = let check p = check env exp.at p in let (<:) t1 t2 = check_sub env exp.at t1 t2 in let (<~) t1 t2 = - if T.is_mut t2 then - t1 <: t2 - else - T.as_immut t1 <: t2 + (if T.is_mut t2 then t1 else T.as_immut t1) <: t2 in (* check effect *) check (E.Ir.infer_effect_exp exp <= E.eff exp) From 7b15375f8f5aca6c071ef04bd13ab35486ca5723 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 30 Jan 2019 09:31:54 +0000 Subject: [PATCH 44/45] add comments to T.Non <: ... cases --- src/check_ir.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/check_ir.ml b/src/check_ir.ml index d380376d1af..771354aa50f 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -420,7 +420,7 @@ let rec check_exp env (exp:Ir.exp) : unit = (typ exp2) <: T.bool; | _ -> () end; - T.Non <: t; (* redundant *) + T.Non <: t; (* vacuously true *) | ForE (pat, exp1, exp2) -> begin check_exp env exp1; @@ -454,7 +454,7 @@ let rec check_exp env (exp:Ir.exp) : unit = | Some t1 -> check_exp env exp1; typ exp1 <: t1; - T.Non <: t1; + T.Non <: t1; (* vacuously true *) end; | RetE exp1 -> begin @@ -465,7 +465,7 @@ let rec check_exp env (exp:Ir.exp) : unit = assert (t0 <> T.Pre); check_exp env exp1; typ exp1 <: t0; - T.Non <: t; + T.Non <: t; (* vacuously true *) end; | AsyncE exp1 -> let t1 = typ exp1 in From 775a3af8bc077f8269ce90bb19de2b937fb7fb44 Mon Sep 17 00:00:00 2001 From: Claudio Russo Date: Wed, 30 Jan 2019 13:24:13 +0000 Subject: [PATCH 45/45] merge fixes --- src/definedness.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/definedness.ml b/src/definedness.ml index 625377ef6e5..9d0cbfaf3e9 100644 --- a/src/definedness.ml +++ b/src/definedness.ml @@ -95,12 +95,12 @@ let rec exp msgs e : f = match e.it with | Type.Actor -> eagerify f | Type.Object _ -> f end - | DotE (e, i) -> exp msgs e + | DotE (e, _t, i) -> exp msgs e | AssignE (e1, e2) -> exps msgs [e1; e2] | ArrayE (m, es) -> exps msgs es | IdxE (e1, e2) -> exps msgs [e1; e2] | CallE (e1, ts, e2) -> eagerify (exps msgs [e1; e2]) - | BlockE ds -> decs msgs ds + | BlockE (ds, _) -> decs msgs ds | NotE e -> exp msgs e | AndE (e1, e2) -> exps msgs [e1; e2] | OrE (e1, e2) -> exps msgs [e1; e2] @@ -118,7 +118,7 @@ let rec exp msgs e : f = match e.it with | AssertE e -> exp msgs e | IsE (e, t) -> exp msgs e | AnnotE (e, t) -> exp msgs e - | DecE d -> close (dec msgs d) + | DecE (d, t) -> close (dec msgs d) | OptE e -> exp msgs e | DeclareE (i, t, e) -> exp msgs e // i.it | DefineE (i, m, e) -> id i ++ exp msgs e