diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 36b574c3b7e..58b8760f23d 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -71,6 +71,7 @@ and dec d = match d.it with "TypD" $$ [con c; kind k] and typ_bind (tb : typ_bind) = - tb.it.Type.var $$ [typ tb.it.Type.bound] + Con.to_string tb.it.con $$ [typ tb.it.bound] + and prog prog = "BlockE" $$ List.map dec prog.it diff --git a/src/async.ml b/src/async.ml index 5938bbfd8b9..e91e6907cb4 100644 --- a/src/async.ml +++ b/src/async.ml @@ -375,8 +375,11 @@ and t_pat' pat = | AltP (pat1, pat2) -> AltP (t_pat pat1, t_pat pat2) +and t_typ_bind' {con; bound} = + {con; bound = t_typ bound} + and t_typ_bind typ_bind = - { typ_bind with it = t_bind typ_bind.it } + { typ_bind with it = t_typ_bind' typ_bind.it } and t_typ_binds typbinds = List.map t_typ_bind typbinds diff --git a/src/check_ir.ml b/src/check_ir.ml index d4a3f2472b3..95be4d11026 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -693,13 +693,16 @@ and cons_of_typ_binds typ_binds = 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 - let ks = List.map (fun tp -> T.Abs([],tp.it.T.bound)) typ_binds in + let cs = List.map (fun tp -> tp.it.con) typ_binds in + let ks = List.map (fun tp -> T.Abs([],tp.it.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 binds = close_typ_binds cs (List.map (fun tb -> tb.it) typ_binds) in let _,_ = check_typ_binds env binds in cs,ce +and close_typ_binds cs tbs = + List.map (fun {con; bound} -> {Type.var = Con.name con; bound = Type.close cs bound}) tbs + and check_dec env dec = (* helpers *) let check p = check env dec.at p in @@ -777,7 +780,7 @@ and gather_dec env scope dec : scope = { 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 + let cs = List.map (fun tb -> tb.it.con) typ_binds in let t1 = pat.note in let t2 = typ in let ts1 = match call_conv.Value.n_args with @@ -792,7 +795,7 @@ and gather_dec env scope dec : scope = | 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 ts = List.map (fun typbind -> typbind.it.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 let ve' = T.Env.add id.it t scope.val_env in diff --git a/src/compile.ml b/src/compile.ml index 7c77c1c4a15..94601a684f0 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -239,8 +239,8 @@ module E = struct This shoulds be extracte into Type.add_open_typ_binds and maybe we need a type open_typ_bind that can be used inside the IR. *) - let cs = Check_ir.cons_of_typ_binds typ_binds in - let ks = List.map (fun tp -> Type.Abs([],tp.it.Type.bound)) typ_binds in + let cs = List.map (fun tp -> tp.it.con) typ_binds in + let ks = List.map (fun tp -> Type.Abs([],tp.it.bound)) typ_binds in let ce = List.fold_right2 Con.Env.add cs ks Con.Env.empty in { env with con_env = Con.Env.adjoin env.con_env ce } diff --git a/src/desugar.ml b/src/desugar.ml index 393c5994ae2..becb43e73a9 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -128,9 +128,14 @@ and exp_field' (f : S.exp_field') = 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 } + let c = match tb.note with + | Some c -> c + | _ -> assert false + in + { it = { Ir.con = c; Ir.bound = tb.it.S.bound.note} + ; at = tb.at + ; note = () + } and decs ds = match ds with @@ -163,8 +168,8 @@ and dec' at n d = match d with let inst = List.map (fun tb -> match tb.note with - | Type.Pre -> assert false - | t -> t) + | None -> assert false + | Some c -> T.Con (c, [])) tbs in let obj_typ = match n.S.note_typ with diff --git a/src/ir.ml b/src/ir.ml index 69b1162163c..55b1aca6e63 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -3,7 +3,8 @@ type type_note = Syntax.typ_note = {note_typ : Type.typ; note_eff : Type.eff} type 'a phrase = ('a, Syntax.typ_note) Source.annotated_phrase -type typ_bind = (Type.bind, Type.typ) Source.annotated_phrase +and typ_bind' = {con : Con.t; bound : Type.typ} +type typ_bind = typ_bind' Source.phrase type pat = (pat', Type.typ) Source.annotated_phrase and pat' = diff --git a/src/parser.mly b/src/parser.mly index 294e1cd3cd9..3d205e2c8c3 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -256,9 +256,9 @@ typ_field : typ_bind : | x=id SUB t=typ - { {var = x; bound = t} @! at $sloc } + { {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 } diff --git a/src/syntax.ml b/src/syntax.ml index eab511f8aad..01fa40b3ad1 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -42,7 +42,7 @@ and typ' = and typ_field = typ_field' Source.phrase and typ_field' = {id : id; typ : typ; mut : mut} -and typ_bind = (typ_bind', Type.typ) Source.annotated_phrase +and typ_bind = (typ_bind', Con.t option) Source.annotated_phrase and typ_bind' = {var : id; bound : typ} diff --git a/src/tailcall.ml b/src/tailcall.ml index 35f4df59122..00adecd6305 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -64,10 +64,10 @@ let bind env i (info:func_info option) : env = let are_generic_insts tbs insts = List.for_all2 (fun tb inst -> - match tb.note, inst with - | Con(c1,[]), Con(c2,[]) -> c1 = c2 (* conservative, but safe *) - | Con(c1,[]), _ -> false - | _,_ -> assert false) tbs insts + match inst with + | Con(c2,[]) -> tb.it.con = c2 (* conservative, but safe *) + | _ -> false + ) tbs insts let rec tailexp env e = {e with it = exp' env e} @@ -210,7 +210,7 @@ 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 + let cs = List.map (fun tb -> Con (tb.it.con, [])) tbs in if !tail_called then let ids = match typ d with | Func( _, _, _, dom, _) -> List.map (fun t -> fresh_id (open_ cs t)) dom diff --git a/src/typing.ml b/src/typing.ml index ad59595bef7..e5113c3ed5d 100644 --- a/src/typing.ml +++ b/src/typing.ml @@ -214,7 +214,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 <- T.Con (c, [])) typ_binds cs; + List.iter2 (fun typ_bind c -> typ_bind.note <- Some 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