diff --git a/src/arrange_ir.ml b/src/arrange_ir.ml index 47566074646..35b14a2bdad 100644 --- a/src/arrange_ir.ml +++ b/src/arrange_ir.ml @@ -40,6 +40,8 @@ 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] + | FuncE (x, cc, tp, p, t, e) -> + "FuncE" $$ [Atom x; call_conv cc] @ List.map typ_bind tp @ [pat p; typ t; exp e] | NewObjE (s, nameids, t)-> "NewObjE" $$ (Arrange.obj_sort' s :: List.fold_left (fun flds (n,i) -> Atom (name n)::(id i):: flds) [typ t] nameids) @@ -66,8 +68,6 @@ and dec d = match d.it with | ExpD e -> "ExpD" $$ [exp e ] | 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 typ_bind tp @ [pat p; typ t; exp e] | TypD c -> "TypD" $$ [con c; kind (Con.kind c)] diff --git a/src/async.ml b/src/async.ml index cc936f914a5..1ff6bccc383 100644 --- a/src/async.ml +++ b/src/async.ml @@ -72,8 +72,6 @@ module Transform() = struct let fullfill = fresh_var (typ (projE call_new_async 1)) in (async,fullfill),call_new_async - let letP p e = {it = LetD(p, e); at = no_region; note = e.note} - let new_nary_async_reply t1 = let (unary_async,unary_fullfill),call_new_async = new_async t1 in let v' = fresh_var t1 in @@ -326,33 +324,17 @@ module Transform() = struct DeclareE (id, t_typ typ, t_exp exp1) | DefineE (id, mut ,exp1) -> DefineE (id, mut, t_exp exp1) - | NewObjE (sort, ids, t) -> - NewObjE (sort, ids, t_typ t) - - and t_dec dec = - { it = t_dec' dec.it; - note = { note_typ = t_typ dec.note.note_typ; - note_eff = dec.note.note_eff }; - at = dec.at } - - and t_dec' dec' = - match dec' with - | ExpD exp -> ExpD (t_exp exp) - | TypD con_id -> - TypD (t_con con_id) - | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) - | VarD (id,exp) -> VarD (id,t_exp exp) - | FuncD (cc, id, typbinds, pat, typT, exp) -> + | FuncE (x, cc, typbinds, pat, typT, exp) -> let s = cc.Value.sort in begin match s with | T.Local -> - FuncD (cc, id, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) | T.Sharable -> begin match typ exp with | T.Tup [] -> - FuncD (cc, id, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) + FuncE (x, cc, t_typ_binds typbinds, t_pat pat, t_typ typT, t_exp exp) | T.Async res_typ -> let cc' = Value.message_cc (cc.Value.n_args + 1) in let res_typ = t_typ res_typ in @@ -362,7 +344,7 @@ module Transform() = struct let k = fresh_var reply_typ in let pat',d = extendTupP pat (varP k) in let typbinds' = t_typ_binds typbinds in - let x = fresh_var res_typ in + let y = fresh_var res_typ in let exp' = match exp.it with | CallE(_, async,_,cps) -> @@ -370,15 +352,31 @@ module Transform() = struct match async.it with | PrimE("@async") -> blockE - (d [expD ((t_exp cps) -*- (x --> (k -*- x)))]) + (d [expD ((t_exp cps) -*- (y --> (k -*- y)))]) | _ -> assert false end | _ -> assert false in - FuncD (cc', id, typbinds', pat', typ', exp') + FuncE (x, cc', typbinds', pat', typ', exp') | _ -> assert false end end + | NewObjE (sort, ids, t) -> + NewObjE (sort, ids, t_typ t) + + and t_dec dec = + { it = t_dec' dec.it; + note = { note_typ = t_typ dec.note.note_typ; + note_eff = dec.note.note_eff }; + at = dec.at } + + and t_dec' dec' = + match dec' with + | ExpD exp -> ExpD (t_exp exp) + | TypD con_id -> + TypD (t_con con_id) + | LetD (pat,exp) -> LetD (t_pat pat,t_exp exp) + | VarD (id,exp) -> VarD (id,t_exp exp) and t_decs decs = List.map t_dec decs diff --git a/src/await.ml b/src/await.ml index bb26637368a..6dec847f264 100644 --- a/src/await.ml +++ b/src/await.ml @@ -137,6 +137,9 @@ and t_exp' context exp' = DeclareE (id, typ, t_exp context exp1) | DefineE (id, mut ,exp1) -> DefineE (id, mut, t_exp context exp1) + | FuncE (x, s, typbinds, pat, typ, exp) -> + let context' = LabelEnv.add id_ret Label LabelEnv.empty in + FuncE (x, s, typbinds, pat, typ,t_exp context' exp) | NewObjE (sort, ids, typ) -> exp' and t_dec context dec = @@ -147,9 +150,6 @@ and t_dec' context dec' = | TypD _ -> dec' | LetD (pat, exp) -> LetD (pat, t_exp context exp) | VarD (id, exp) -> VarD (id, t_exp context exp) - | FuncD (s, id, typbinds, pat, typ, exp) -> - let context' = LabelEnv.add id_ret Label LabelEnv.empty in - FuncD (s, id, typbinds, pat, typ,t_exp context' exp) and t_decs context decs = List.map (t_dec context) decs @@ -317,7 +317,8 @@ and c_exp' context exp k = k -@- (t_exp context exp) | PrimE _ | VarE _ - | LitE _ -> + | LitE _ + | FuncE _ -> assert false | UnE (ot, op, exp1) -> unary context k (fun v1 -> e (UnE (ot, op, v1))) exp1 @@ -460,13 +461,6 @@ and c_dec context dec (k:kont) = (meta (typ exp) (fun v -> k -@- define_idE id varM v)) end - | FuncD (_, id, _ (* typbinds *), _ (* pat *), _ (* typ *), _ (* exp *) ) -> - let func_typ = typ dec in - let v = fresh_var func_typ in - let u = fresh_var T.unit in - blockE [letD v (decE (t_dec context dec)); - letD u (define_idE id constM v); - expD (k -@- v)] and c_decs context decs k = @@ -485,7 +479,6 @@ and declare_dec dec exp : exp = | TypD _ -> exp | LetD (pat, _) -> declare_pat pat exp | VarD (id, exp1) -> declare_id id (T.Mut (typ exp1)) exp - | FuncD (_, id, _, _, _, _) -> declare_id id (typ dec) exp and declare_decs decs exp : exp = match decs with diff --git a/src/check_ir.ml b/src/check_ir.ml index e9f07746f3c..558fbcf460b 100644 --- a/src/check_ir.ml +++ b/src/check_ir.ml @@ -262,9 +262,7 @@ 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 else T.as_immut t1) <: t2 - in + let (<~) 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) "inferred effect not a subtype of expected effect"; @@ -387,6 +385,12 @@ let rec check_exp env (exp:Ir.exp) : unit = (typ exp2) <: T.open_ insts t2; T.open_ insts t3 <: t; | BlockE decs -> + (* Really, this should be a tuple of decs and an expression now *) + check (decs <> []) "BlockE [] is invalid"; + begin match (Lib.List.last decs).it with + | ExpD _ -> () + | _ -> error env exp.at "last entry in a BlockE must be an expression" + end; let t1, scope = type_block env decs exp.at in t1 <: t; | IfE (exp1, exp2, exp3) -> @@ -512,6 +516,29 @@ let rec check_exp env (exp:Ir.exp) : unit = typ exp1 <: t0 end; T.unit <: t + | FuncE (x, cc, typ_binds, pat, ret_ty, exp) -> + let cs,ce = check_open_typ_binds env typ_binds in + let arg_ty, ret_ty = match t with + | T.Func (cc, _, _, ts1, ts2) -> + 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 + T.seq ts1, T.seq ts2 + | _ -> error env exp.at "FuncE not annotated with a function type" + in + let env' = adjoin_cons env ce in + let ve = check_pat_exhaustive env' pat in + check (cc = Value.call_conv_of_typ t) "different calling convention in FuncE and its type"; + check_typ env' arg_ty; + check_typ env' ret_ty; + check ((cc.Value.sort = T.Sharable && Type.is_async ret_ty) + ==> isAsyncE exp) + "shared function with async type has non-async body"; + let env'' = + {env' with labs = T.Env.empty; rets = Some ret_ty; async = false} in + check_exp (adjoin_vals env'' ve) exp; + check_sub env' exp.at arg_ty pat.note; + check_sub env' exp.at (typ exp) ret_ty | NewObjE (sort, labids, t0) -> let t1 = T.Obj(sort, @@ -624,12 +651,7 @@ 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 - | _ -> false - -and is_func_dec dec = - match dec.it with - | FuncD _ -> true + | FuncE _ -> true | _ -> false and type_exp_field env s (tfs, ve) field : T.field list * val_env = @@ -690,32 +712,24 @@ and check_dec env dec = (* helpers *) let check p = check env dec.at p in let (<:) t1 t2 = check_sub env dec.at t1 t2 in + let (<~) t1 t2 = (if T.is_mut t2 then t1 else T.as_immut 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 match dec.it with - | ExpD exp | LetD (_, exp) -> + | ExpD exp -> check_exp env exp; - (typ exp) <: t + typ exp <: t + | LetD (pat, exp) -> + ignore (check_pat_exhaustive env pat); + check_exp env exp; + typ exp <~ pat.note; + T.unit <: t | VarD (_, exp) -> check_exp env exp; T.unit <: t - | FuncD (cc, 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_cons env ce in - let ve = check_pat_exhaustive env' pat in - check_typ env' t2; - check ((cc.Value.sort = T.Sharable && 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_sub env' dec.at (typ exp) t2; - t0 <: t; | TypD c -> check (T.ConSet.mem c env.cons) "free type constructor"; let (binds,typ) = @@ -762,28 +776,6 @@ and gather_dec env scope dec : scope = "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) -> - let func_sort = call_conv.Value.sort 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 - | 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.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.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 - { scope with val_env = ve' } | TypD c -> check env dec.at (not (T.ConSet.mem c scope.con_env)) diff --git a/src/compile.ml b/src/compile.ml index 20f9242fcb6..1b07dead6ba 100644 --- a/src/compile.ml +++ b/src/compile.ml @@ -870,7 +870,7 @@ module Var = struct let load = Heap.load_field mutbox_field let store = Heap.store_field mutbox_field - let add_local env name = + let _add_local env name = E.add_local_with_offset env name mutbox_field (* Stores the payload (which is found on the stack) *) @@ -1007,9 +1007,10 @@ module AllocHow = struct (set_of_map how))) let is_static_exp env how0 exp = match exp.it with - | BlockE [{ it = FuncD _; _} as dec] -> - let f = Freevars.close (Freevars.dec dec) in - is_static env how0 f + | FuncE (_, cc, _, _, _ , _) + (* Messages cannot be static *) + when cc.Value.sort <> Type.Sharable -> + is_static env how0 (Freevars.exp exp) | _ -> false let dec env (seen, how0) dec = @@ -1020,12 +1021,6 @@ module AllocHow = struct (* Mutable variables are, well, mutable *) | VarD _ -> map_of_set LocalMut d - (* Messages cannot be static *) - | FuncD (cc, _, _, _, _, _) when cc.Value.sort = Type.Sharable -> - map_of_set LocalImmut d - (* Static functions *) - | FuncD _ when is_static env how0 f -> - M.empty (* Static functions in an let-expression *) | LetD ({it = VarP _; _}, e) when is_static_exp env how0 e -> M.empty @@ -2908,7 +2903,7 @@ module FuncDec = struct ) let static_self_message_pointer env name = - Dfinity.compile_databuf_of_bytes env name.it ^^ + Dfinity.compile_databuf_of_bytes env name ^^ export_self_message env (* Create a WebAssembly func from a pattern (for the argument) and the body. @@ -2998,121 +2993,102 @@ module FuncDec = struct ) (* Compile a closed function declaration (has no free variables) *) - let dec_closed pre_env cc name mk_pat mk_body at = - let (fi, fill) = E.reserve_fun pre_env name.it in - let d = StackRep.deferred_of_static_think pre_env (SR.StaticFun fi) in - let pre_env1 = E.add_local_deferred pre_env name.it d in - ( pre_env1, fun env -> + let closed pre_env cc name mk_pat mk_body at = + let (fi, fill) = E.reserve_fun pre_env name in + ( SR.StaticFun fi, fun env -> let restore_no_env env1 _ = (env1, G.nop) in let f = compile_local_function env cc restore_no_env mk_pat mk_body at in fill f ) (* Compile a closure declaration (has free variables) *) - let dec_closure pre_env cc h name captured mk_pat mk_body at = + let closure env cc name captured mk_pat mk_body at = let is_local = cc.Value.sort <> Type.Sharable in - let (set_li, get_li) = new_local pre_env (name.it ^ "_clos") in - let (pre_env1, alloc_code0) = AllocHow.add_how pre_env name.it (Some h) in + let (set_clos, get_clos) = new_local env (name ^ "_clos") in let len = Wasm.I32.of_int_u (List.length captured) in - let alloc_code = - (* Allocate a heap object for the closure *) - Heap.alloc pre_env (Int32.add Closure.header_size len) ^^ - set_li ^^ + let (store_env, restore_env) = + let rec go i = function + | [] -> (G.nop, fun env1 _ -> (env1, G.nop)) + | (v::vs) -> + let (store_rest, restore_rest) = go (i+1) vs in + let (store_this, restore_this) = Var.capture env v in + let store_env = + get_clos ^^ + store_this ^^ + Closure.store_data (Wasm.I32.of_int_u i) ^^ + store_rest in + let restore_env env1 get_env = + let (env2, code) = restore_this env1 in + let (env3, code_rest) = restore_rest env2 get_env in + (env3, + get_env ^^ + Closure.load_data (Wasm.I32.of_int_u i) ^^ + code ^^ + code_rest + ) + in (store_env, restore_env) in + go 0 captured in - (* Alloc space for the name of the function *) - alloc_code0 - in + let f = + if is_local + then compile_local_function env cc restore_env mk_pat mk_body at + else compile_message env cc restore_env mk_pat mk_body at in - ( pre_env1, alloc_code, fun env -> + let fi = E.add_fun env f name in - let (store_env, restore_env) = - let rec go i = function - | [] -> (G.nop, fun env1 _ -> (env1, G.nop)) - | (v::vs) -> - let (store_rest, restore_rest) = go (i+1) vs in - let (store_this, restore_this) = Var.capture env v in - let store_env = - get_li ^^ - store_this ^^ - Closure.store_data (Wasm.I32.of_int_u i) ^^ - store_rest in - let restore_env env1 get_env = - let (env2, code) = restore_this env1 in - let (env3, code_rest) = restore_rest env2 get_env in - (env3, - get_env ^^ - Closure.load_data (Wasm.I32.of_int_u i) ^^ - code ^^ - code_rest - ) - in (store_env, restore_env) in - go 0 captured in - - let fi = - if is_local - then - let f = compile_local_function env cc restore_env mk_pat mk_body at in - E.add_fun env f name.it - else - let f = compile_message env cc restore_env mk_pat mk_body at in - let fi = E.add_fun env f name.it in - E.add_dfinity_type env (fi, - CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) - ); - fi - in + if not is_local then + E.add_dfinity_type env (fi, + CustomSections.(I32 :: Lib.List.make cc.Value.n_args ElemBuf) + ); + + let code = + (* Allocate a heap object for the closure *) + Heap.alloc env (Int32.add Closure.header_size len) ^^ + set_clos ^^ (* Store the tag *) - get_li ^^ + get_clos ^^ Tagged.store Tagged.Closure ^^ (* Store the function number: *) - get_li ^^ + get_clos ^^ compile_unboxed_const fi ^^ Heap.store_field Closure.funptr_field ^^ (* Store the length *) - get_li ^^ + get_clos ^^ compile_unboxed_const len ^^ Heap.store_field Closure.len_field ^^ (* Store all captured values *) - store_env ^^ - - (* Possibly turn into a funcref *) - begin - if is_local - then get_li - else - Tagged.obj env Tagged.Reference [ - compile_unboxed_const fi ^^ - G.i (Call (nr (Dfinity.func_externalize_i env))) ^^ - get_li ^^ - ClosureTable.remember_closure env ^^ - G.i (Call (nr (Dfinity.func_bind_i env))) ^^ - ElemHeap.remember_reference env - ] - end ^^ + store_env + in - (* Store it *) - Var.set_val env name.it) + (* Possibly turn into a funcref *) + if is_local + then + SR.Vanilla, + code ^^ + get_clos + else + SR.UnboxedReference, + code ^^ + compile_unboxed_const fi ^^ + G.i (Call (nr (Dfinity.func_externalize_i env))) ^^ + get_clos ^^ + ClosureTable.remember_closure env ^^ + G.i (Call (nr (Dfinity.func_bind_i env))) - let dec pre_env how name cc captured mk_pat mk_body at = + let lit env how name cc captured mk_pat mk_body at = let is_local = cc.Value.sort <> Type.Sharable in - if not is_local && E.mode pre_env <> DfinityMode - then - let (pre_env1, _) = Var.add_local pre_env name.it in - ( pre_env1, G.i Unreachable, fun env -> G.i Unreachable) - else match AllocHow.M.find_opt name.it how with - | None -> - assert is_local; - let (pre_env1, fill) = dec_closed pre_env cc name mk_pat mk_body at in - (pre_env1, G.nop, fun env -> fill env; G.nop) - | Some h -> - dec_closure pre_env cc h name captured mk_pat mk_body at + if not is_local && E.mode env <> DfinityMode + then SR.Unreachable, G.i Unreachable + else + (* TODO: Can we create a static function here? Do we ever have to? *) + closure env cc name captured mk_pat mk_body at end (* FuncDec *) @@ -3538,6 +3514,11 @@ and compile_exp (env : E.t) exp = SR.unit, compile_exp_vanilla env e ^^ Var.set_val env name.it + | FuncE (x, cc, typ_binds, p, _rt, e) -> + let captured = Freevars.captured p e in + let mk_pat env1 = compile_func_pat env1 cc p in + let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in + FuncDec.lit env typ_binds x cc captured mk_pat mk_body exp.at | NewObjE (Type.Object _ (*sharing*), fs, _) -> SR.Vanilla, let fs' = fs |> List.map @@ -3785,17 +3766,6 @@ and compile_dec pre_env how dec : E.t * G.t * (E.t -> (SR.t * G.t)) = compile_exp_vanilla env e ^^ Var.set_val env name.it ) - | FuncD (cc, name, typ_binds, p, _rt, e) -> - (* Get captured variables *) - let captured = Freevars.captured p e in - let mk_pat env1 = compile_func_pat env1 cc p in - let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - let (pre_env1, alloc_code, mk_code) = FuncDec.dec pre_env how name cc captured mk_pat mk_body dec.at in - (pre_env1, alloc_code, fun env -> - (* Bring type parameters into scope *) - let sr, code = Var.get_val env name.it in - sr, mk_code env ^^ code - ) and compile_decs env decs : SR.t * G.t = snd (compile_decs_block env decs) @@ -3820,15 +3790,11 @@ and compile_decs_block env decs : (E.t * (SR.t * G.t)) = (env1, (sr, alloc_code ^^ code)) and compile_static_exp env how exp = match exp.it with - | BlockE [{ it = FuncD (cc, name, typ_binds, p, _rt, e); _}] -> + | FuncE (name, cc, typ_binds, p, _rt, e) -> (* Get captured variables *) let mk_pat env1 = compile_func_pat env1 cc p in let mk_body env1 = compile_exp_as env1 (StackRep.of_arity cc.Value.n_res) e in - let (env1, fill) = FuncDec.dec_closed env cc name mk_pat mk_body exp.at in - begin match Var.get_val env1 name.it with - | (SR.StaticThing st, _) -> (st, fill) - | _ -> assert false - end + FuncDec.closed env cc name mk_pat mk_body exp.at | _ -> assert false and compile_prelude env = @@ -3872,20 +3838,19 @@ 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); _ }] -> - (cc, name, ty_args, pat, rt, exp) + let Name name = f.it.name.it in + let (cc, pat, exp) = match f.it.exp.it with + | FuncE (_x, cc, ty_args, pat, rt, exp) -> (cc, pat, exp) | _ -> assert false (* "public actor field not a function" *) - in find_func f.it.exp in + in - let (fi, fill) = E.reserve_fun pre_env name.it in + let (fi, fill) = E.reserve_fun pre_env name in E.add_dfinity_type pre_env (fi, Lib.List.make cc.Value.n_args CustomSections.ElemBuf); E.add_export pre_env (nr { - name = Dfinity.explode name.it; + name = Dfinity.explode name; edesc = nr (FuncExport (nr fi)) }); - let pre_env1 = E.add_local_deferred_vanilla pre_env name.it + let pre_env1 = E.add_local_deferred_vanilla pre_env f.it.id.it (fun env -> FuncDec.static_self_message_pointer env name) in ( pre_env1, fun env -> G.with_region f.at @@ diff --git a/src/construct.ml b/src/construct.ml index 58e14188801..977d87a7e37 100644 --- a/src/construct.ml +++ b/src/construct.ml @@ -255,7 +255,7 @@ let newObjE sort ids typ = let letP pat exp = { it = LetD (pat, exp); at = no_region; - note = exp.note; + note = { S.note_eff = eff exp; S.note_typ = T.unit } } let letD x exp = letP (varP x) exp @@ -275,43 +275,55 @@ let is_expD dec = match dec.it with ExpD _ -> true | _ -> false let letE x exp1 exp2 = blockE [letD x exp1; expD exp2] +(* Mono-morphic function expression *) +let funcE name t x exp = + let retty = match t with + | T.Func(_, _, _, _, ts2) -> T.seq ts2 + | _ -> assert false in + let cc = Value.call_conv_of_typ t in + ({it = FuncE + ( name, + cc, + [], + varP x, + (* TODO: Assert invariant: retty has no free (unbound) DeBruijn indices -- Claudio *) + retty, + exp + ); + at = no_region; + note = { S.note_eff = T.Triv; S.note_typ = t } + }) + +let nary_funcE name t xs exp = + let retty = match t with + | T.Func(_, _, _, _, ts2) -> T.seq ts2 + | _ -> assert false in + let cc = Value.call_conv_of_typ t in + ({it = FuncE + ( name, + cc, + [], + seqP (List.map varP xs), + retty, + exp + ); + at = no_region; + note = { S.note_eff = T.Triv; S.note_typ = t } + }) + (* Mono-morphic function declaration, sharing inferred from f's type *) let funcD f x exp = match f.it, x.it with | VarE _, VarE _ -> - let sharing, t1, t2 = match typ f with - | T.Func(sharing, _, _, ts1, ts2) -> sharing, T.seq ts1, T.seq ts2 - | _ -> assert false in - let cc = Value.call_conv_of_typ (typ f) in - { it = FuncD (cc, - (id_of_exp f), - [], - { it = VarP (id_of_exp x); at = no_region; note = t1 }, - (* TODO: Assert invariant: t2 has no free (unbound) DeBruijn indices -- Claudio *) - t2, - exp); - at = no_region; - note = f.note - } + letD f (funcE (id_of_exp f).it (typ f) x exp) | _ -> failwith "Impossible: funcD" (* Mono-morphic, n-ary function declaration *) let nary_funcD f xs exp = - match f.it, typ f with - | VarE _, - T.Func(sharing,_,_,_,ts2) -> - let cc = Value.call_conv_of_typ (typ f) in - let t2 = T.seq ts2 in - { it = FuncD (cc, - id_of_exp f, - [], - seqP (List.map varP xs), - t2, - exp); - at = no_region; - note = f.note - } - | _,_ -> failwith "Impossible: funcD" + match f.it with + | VarE _ -> + letD f (nary_funcE (id_of_exp f).it (typ f) xs exp) + | _ -> failwith "Impossible: funcD" (* Continuation types *) @@ -340,29 +352,20 @@ let as_seqE e = (* Lambda abstraction *) (* local lambda *) -let (-->) x exp = - match x.it with - | VarE _ -> - let f = idE ("$lambda" @@ no_region) - (T.Func (T.Local, T.Returns, [], T.as_seq (typ x), T.as_seq (typ exp))) - in - decE (funcD f x exp) - | _ -> failwith "Impossible: -->" +let (-->) x exp = + let fun_ty = T.Func (T.Local, T.Returns, [], T.as_seq (typ x), T.as_seq (typ exp)) in + funcE "$lambda" fun_ty x exp (* n-ary local lambda *) let (-->*) xs exp = - let f = idE ("$lambda" @@ no_region) - (T.Func (T.Local, T.Returns, [], - List.map typ xs, T.as_seq (typ exp))) in - decE (nary_funcD f xs exp) + let fun_ty = T.Func (T.Local, T.Returns, [], List.map typ xs, T.as_seq (typ exp)) in + nary_funcE "$lambda" fun_ty xs exp (* n-ary shared lambda *) let (-@>*) xs exp = - let f = idE ("$lambda" @@ no_region) - (T.Func (T.Sharable, T.Returns, [], - List.map typ xs, T.as_seq (typ exp))) in - decE (nary_funcD f xs exp) + let fun_ty = T.Func (T.Sharable, T.Returns, [], List.map typ xs, T.as_seq (typ exp)) in + nary_funcE "$lambda" fun_ty xs exp (* Lambda application (monomorphic) *) diff --git a/src/desugar.ml b/src/desugar.ml index aefa6c9c5d8..58d58de30d4 100644 --- a/src/desugar.ml +++ b/src/desugar.ml @@ -56,9 +56,7 @@ and exp' at note = function | S.IdxE (e1, e2) -> I.IdxE (exp e1, exp e2) | S.FuncE (name, s, tbs, p, ty, e) -> let cc = Value.call_conv_of_typ note.S.note_typ in - (* TODO(joachim): Turn I.FuncD into I.FuncE *) - let i = {it = name; at; note = ()} in - I.BlockE [{it = I.FuncD (cc, i, typ_binds tbs, pat p, ty.note, exp e); at; note}] + I.FuncE (name, cc, typ_binds tbs, pat p, ty.note, exp e) | 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 @@ -71,7 +69,7 @@ and exp' at note = function begin match Type.is_unit note.S.note_typ, last.it with | _, I.ExpD _ -> I.BlockE (ds') | true, _ -> I.BlockE (ds' @ [expD (tupE [])]) - | false, (I.LetD ({it = I.VarP (x); _}, _) | I.FuncD (_, x, _, _, _, _)) -> + | false, (I.LetD ({it = I.VarP x; _}, _)) -> I.BlockE (ds' @ [expD (idE x note.S.note_typ)]) | false, I.LetD (p', e') -> let x = fresh_var note.S.note_typ in @@ -119,7 +117,7 @@ and build_obj at s self_id es obj_typ = match self_id with | None -> [ expD obj_e ] | Some id -> let self = idE id obj_typ in [ letD self obj_e; expD self ] - in I.BlockE (List.map (fun ef -> dec ef.it.S.dec) es @ ret_ds) + in I.BlockE (decs (List.map (fun ef -> ef.it.S.dec) es) @ ret_ds) and exp_fields fs = List.map exp_field fs @@ -173,10 +171,21 @@ and decs ds = S.note_eff = T.Triv } } in - typD :: phrase' dec' d :: decs ds - | _ -> phrase' dec' d :: decs ds + typD :: dec d :: decs ds + | _ -> dec d :: decs ds + +and dec d = + let ir_dec = phrase' dec' d in + (* In Source, LetD has a type, in IR not *) + match ir_dec.it with + | I.LetD _ -> { ir_dec with note = + { S.note_eff = ir_dec.note.S.note_eff + ; S.note_typ = T.unit + } + } + | _ -> ir_dec + -and dec d = phrase' dec' d and dec' at n d = match d with | S.ExpD e -> I.ExpD (exp e) | S.LetD (p, e) -> @@ -201,17 +210,24 @@ and dec' at n d = match d with | None -> assert false | Some c -> T.Con (c, [])) tbs in + let fun_typ = n.S.note_typ in let obj_typ = - match n.S.note_typ with + match fun_typ with | T.Func(s,c,bds,dom,[rng]) -> assert(List.length inst = List.length bds); T.promote (T.open_ inst rng) | _ -> assert false in - I.FuncD (cc, id', typ_binds tbs, pat p, obj_typ, (* TBR *) - { it = obj at s (Some self_id) es obj_typ; - at = at; - note = { S.note_typ = obj_typ; S.note_eff = T.Triv } }) + let varPat = {it = I.VarP id'; at = at; note = fun_typ } in + let fn = { + it = I.FuncE (id.it, cc, typ_binds tbs, pat p, obj_typ, + { it = obj at s (Some self_id) es obj_typ; + at = at; + note = { S.note_typ = obj_typ; S.note_eff = T.Triv } }); + at = at; + note = { S.note_typ = fun_typ; S.note_eff = T.Triv } + } in + I.LetD (varPat, fn) and cases cs = List.map case cs diff --git a/src/effect.ml b/src/effect.ml index 1bedc4e2b2d..d5583ecec93 100644 --- a/src/effect.ml +++ b/src/effect.ml @@ -169,6 +169,8 @@ module Ir = effect_exp exp1 | DefineE (_, _, exp1) -> effect_exp exp1 + | FuncE _ -> + T.Triv | NewObjE _ -> T.Triv @@ -192,7 +194,6 @@ module Ir = | LetD (_,e) | VarD (_, e) -> effect_exp e - | TypD _ - | FuncD _ -> + | TypD _ -> T.Triv end diff --git a/src/freevars.ml b/src/freevars.ml index a0d062866bb..b8d664af0e8 100644 --- a/src/freevars.ml +++ b/src/freevars.ml @@ -90,6 +90,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 + | FuncE (x, cc, tp, p, t, e) -> under_lambda (exp e /// pat p) | NewObjE (_, ids, _) -> unions id (List.map (fun (lab,id) -> id) ids) and exps es : f = unions exp es @@ -120,8 +121,6 @@ and dec d = match d.it with | LetD (p, e) -> pat p +++ exp e | VarD (i, e) -> (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 c -> (M.empty, S.empty) (* The variables captured by a function. May include the function itself! *) diff --git a/src/interpret_ir.ml b/src/interpret_ir.ml index 168989508f6..5949bd4dfa6 100644 --- a/src/interpret_ir.ml +++ b/src/interpret_ir.ml @@ -175,16 +175,13 @@ let make_async_message id v = (* assert (false) *) -let make_message id t v : V.value = - match t with - | T.Func (_, _, _, _, []) -> - make_unit_message id.it v - | T.Func (_, _, _, _, [T.Async _]) -> +let make_message x cc v : V.value = + match cc.V.control with + | T.Returns -> + make_unit_message x v + | T.Promises -> assert (not !Flags.async_lowering); - make_async_message id.it v - | _ -> - failwith (Printf.sprintf "actorfield: %s %s" id.it (T.string_of_typ t)) - (* assert false *) + make_async_message x v let extended_prim s typ at = @@ -434,6 +431,16 @@ and interpret_exp_mut env exp (k : V.value V.cont) = define_id env id v'; k V.unit ) + | FuncE (x, cc, _typbinds, pat, _typ, exp) -> + let f = interpret_func env x pat + (fun env' -> interpret_exp env' exp) in + let v = V.Func (cc, f) in + let v = + match cc.Value.sort with + | T.Sharable -> make_message x cc v + | _-> v + in + k v | NewObjE (sort, ids, _) -> let ve = List.fold_left @@ -607,7 +614,7 @@ and declare_dec dec : val_env = match dec.it with | ExpD _ | TypD _ -> V.Env.empty | LetD (pat, _) -> declare_pat pat - | VarD (id, _) | FuncD (_, id, _, _, _, _) -> declare_id id + | VarD (id, _) -> declare_id id and declare_decs decs ve : val_env = match decs with @@ -624,7 +631,7 @@ and interpret_dec env dec (k : V.value V.cont) = | LetD (pat, exp) -> interpret_exp env exp (fun v -> define_pat env pat v; - k v + k V.unit ) | VarD (id, exp) -> interpret_exp env exp (fun v -> @@ -633,17 +640,6 @@ and interpret_dec env dec (k : V.value V.cont) = ) | TypD _ -> k V.unit - | FuncD (cc, id, _typbinds, pat, _typ, exp) -> - let f = interpret_func env id pat - (fun env' -> interpret_exp env' exp) in - let v = V.Func (V.call_conv_of_typ dec.note.Syntax.note_typ, f) in - let v = - match cc.Value.sort with - | T.Sharable -> make_message id dec.note.Syntax.note_typ v - | _-> v - in - define_id env id v; - k v and interpret_decs env decs (k : V.value V.cont) = match decs with @@ -653,8 +649,8 @@ and interpret_decs env decs (k : V.value V.cont) = interpret_dec env dec (fun _v -> interpret_decs env decs' k) -and interpret_func env id pat f v (k : V.value V.cont) = - if !Flags.trace then trace "%s%s" id.it (string_of_arg v); +and interpret_func env x pat f v (k : V.value V.cont) = + if !Flags.trace then trace "%s%s" x (string_of_arg v); match match_pat pat v with | None -> trap pat.at "argument value %s does not match parameter list" diff --git a/src/ir.ml b/src/ir.ml index e339675bb6e..9eb11bb7ee7 100644 --- a/src/ir.ml +++ b/src/ir.ml @@ -58,6 +58,8 @@ and exp' = | AssertE of exp (* assertion *) | DeclareE of id * Type.typ * exp (* local promise *) | DefineE of id * mut * exp (* promise fulfillment *) + | FuncE of (* function *) + string * Value.call_conv * typ_bind list * pat * Type.typ * exp | NewObjE of (* make an object, preserving mutable identity *) Type.obj_sort * (name * id) list * Type.typ @@ -78,8 +80,6 @@ and dec' = | ExpD of exp (* plain expression *) | LetD of pat * exp (* immutable *) | VarD of id * exp (* mutable *) - | FuncD of (* function *) - Value.call_conv * id * typ_bind list * pat * Type.typ * exp | TypD of Type.con (* type *) diff --git a/src/rename.ml b/src/rename.ml index 83eecc5ba38..68f9d2ab5ce 100644 --- a/src/rename.ml +++ b/src/rename.ml @@ -60,6 +60,10 @@ and exp' rho e = match e with | DeclareE (i, t, e) -> let i',rho' = id_bind rho i in DeclareE (i', t, exp rho' e) | DefineE (i, m, e) -> DefineE (id rho i, m, exp rho e) + | FuncE (x, s, tp, p, t, e) -> + let p', rho' = pat rho p in + let e' = exp rho' e in + FuncE (x, s, tp, p', t, e') | NewObjE (s, is, t) -> NewObjE (s, List.map (fun (l,i) -> (l,id rho i)) is, t) and exps rho es = List.map (exp rho) es @@ -138,13 +142,6 @@ and dec' rho d = match d with let i', rho = id_bind rho i in (fun rho' -> VarD (i',exp rho' e)), rho - | FuncD (s, i, tp, p, t, e) -> - let i', rho = id_bind rho i in - (fun rho' -> - let p', rho'' = pat rho' p in - let e' = exp rho'' e in - FuncD (s, i', tp, p', t, e')), - rho | TypD c -> (* we don't rename type names *) (fun rho -> d), rho diff --git a/src/tailcall.ml b/src/tailcall.ml index 44aac551d1e..441206edb67 100644 --- a/src/tailcall.ml +++ b/src/tailcall.ml @@ -121,6 +121,10 @@ and exp' env e : exp' = match e.it with | DeclareE (i, t, e) -> let env1 = bind env i None in DeclareE (i, t, tailexp env1 e) | DefineE (i, m, e) -> DefineE (i, m, exp env e) + | FuncE (x, cc, tbs, p, typT, exp0) -> + let env1 = pat {tail_pos = true; info = None} p in + let exp0' = tailexp env1 exp0 in + FuncE (x, cc, tbs, p, typT, exp0') | NewObjE (s,is,t) -> NewObjE (s, is, t) and exps env es = List.map (exp env) es @@ -184,20 +188,11 @@ and dec env d = and dec' env d = match d.it with - | ExpD e -> - (fun env1 -> ExpD (tailexp env1 e)), - env - | LetD (p, e) -> - let env = pat env p in - (fun env1 -> LetD(p,exp env1 e)), - env - | VarD (i, e) -> - let env = bind env i None in - (fun env1 -> VarD(i,exp env1 e)), - env - | FuncD ({ Value.sort = Local; _} as cc, id, tbs, p, typT, exp0) -> + (* A local let bound function, this is what we are looking for *) + | LetD (({it = VarP id;_} as id_pat), + ({it = FuncE (x, ({ Value.sort = Local; _} as cc), tbs, p, typT, exp0);_} as funexp)) -> let env = bind env id None in - (fun env1 -> + begin fun env1 -> let temp = fresh_var (Mut p.note) in let l = fresh_id () in let tail_called = ref false in @@ -212,7 +207,7 @@ and dec' env d = let exp0' = tailexp env3 exp0 in let cs = List.map (fun (tb : typ_bind) -> Con (tb.it.con, [])) tbs in if !tail_called then - let ids = match typ d with + let ids = match typ funexp with | Func( _, _, _, dom, _) -> List.map (fun t -> fresh_var (open_ cs t)) dom | _ -> assert false in @@ -225,18 +220,21 @@ and dec' env d = (blockE [letP p temp; expD (retE exp0')])) None) ] in - FuncD (cc, id, tbs, args, typT, body) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, args, typT, body)}) else - FuncD (cc, id, tbs, p, typT, exp0')), - env - | FuncD (cc, i, tbs, p, t, e) -> - (* don't optimize self-tail calls for shared functions otherwise - we won't go through the scheduler *) + LetD (id_pat, {funexp with it = FuncE (x, cc, tbs, p, typT, exp0')}) + end, + env + | ExpD e -> + (fun env1 -> ExpD (tailexp env1 e)), + env + | LetD (p, e) -> + let env = pat env p in + (fun env1 -> LetD(p,exp env1 e)), + env + | VarD (i, e) -> let env = bind env i None in - (fun env1 -> - let env2 = pat {tail_pos = true; info = None} p in - let e' = tailexp env2 e in - FuncD(cc, i, tbs, p, t, e')), + (fun env1 -> VarD(i,exp env1 e)), env | TypD _ -> (fun env -> d.it), diff --git a/test/fail/ok/use-before-define5.wasm.stderr.ok b/test/fail/ok/use-before-define5.wasm.stderr.ok index 473a0223e65..7817040f3c6 100644 --- a/test/fail/ok/use-before-define5.wasm.stderr.ok +++ b/test/fail/ok/use-before-define5.wasm.stderr.ok @@ -2,14 +2,12 @@ non-closed actor: (ActorE a (foo foo - (BlockE - (FuncD - (shared 0 -> 0) - foo - (TupP) - () - (AssertE (RelE Nat (VarE x) EqOp (LitE (NatLit 1)))) - ) + (FuncE + foo + (shared 0 -> 0) + (TupP) + () + (AssertE (RelE Nat (VarE x) EqOp (LitE (NatLit 1)))) ) Const Public diff --git a/test/run-dfinity/ok/counter-class.dvm-run.ok b/test/run-dfinity/ok/counter-class.dvm-run.ok new file mode 100644 index 00000000000..3292a97eddf --- /dev/null +++ b/test/run-dfinity/ok/counter-class.dvm-run.ok @@ -0,0 +1 @@ +W, hypervisor: call failed with trap message: Uncaught RuntimeError: unreachable diff --git a/test/run-dfinity/ok/counter-class.wasm.stderr.ok b/test/run-dfinity/ok/counter-class.wasm.stderr.ok index 713a66528d2..4214b6821dc 100644 --- a/test/run-dfinity/ok/counter-class.wasm.stderr.ok +++ b/test/run-dfinity/ok/counter-class.wasm.stderr.ok @@ -3,16 +3,14 @@ non-closed actor: (ActorE (c c (VarE i) Var Private) (dec dec - (BlockE - (FuncD - (shared 0 -> 0) - dec - (TupP) - () - (BlockE - (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) - (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) - ) + (FuncE + dec + (shared 0 -> 0) + (TupP) + () + (BlockE + (ExpD (CallE ( 1 -> 0) (VarE show) (VarE c))) + (ExpD (AssignE (VarE c) (BinE Int (VarE c) SubOp (LitE (IntLit 1))))) ) ) Const @@ -20,35 +18,29 @@ non-closed actor: (ActorE ) (read read - (BlockE - (FuncD - (shared 1 -> 0) - read - (VarP $1) - () - (BlockE - (LetD (TupP) (TupE)) - (ExpD - (CallE + (FuncE + read + (shared 1 -> 0) + (VarP $1) + () + (BlockE + (LetD (TupP) (TupE)) + (ExpD + (CallE + ( 1 -> 0) + (FuncE + $lambda + ( 1 -> 0) + (VarP $0) + () + (CallE ( 1 -> 0) (VarE $0) (VarE c)) + ) + (FuncE + $lambda ( 1 -> 0) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $0) - () - (CallE ( 1 -> 0) (VarE $0) (VarE c)) - ) - ) - (BlockE - (FuncD - ( 1 -> 0) - $lambda - (VarP $2) - () - (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) - ) - ) + (VarP $2) + () + (CallE (shared 1 -> 0) (VarE $1) (VarE $2)) ) ) ) diff --git a/test/run/last-dec-val.as b/test/run/last-dec-val.as new file mode 100644 index 00000000000..6a1a05536b5 --- /dev/null +++ b/test/run/last-dec-val.as @@ -0,0 +1,2 @@ +assert ({let x = 5} == 5); +assert (({let (x,y) = (1,2)}).1 == 2);