Skip to content

Commit

Permalink
WIP: undo most IR and backend, compiles
Browse files Browse the repository at this point in the history
  • Loading branch information
@ggreif
ggreif committed Feb 14, 2025
1 parent 84d93fd commit e7f9027
Show file tree
Hide file tree
Showing 19 changed files with 273 additions and 581 deletions.
320 changes: 52 additions & 268 deletions src/codegen/compile_classical.ml
View file

Large diffs are not rendered by default.

4 changes: 2 additions & 2 deletions src/codegen/compile_enhanced.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12256,7 +12256,7 @@ and compile_prim_invocation (env : E.t) ae p es at =
| ICCallerPrim, [] ->
SR.Vanilla, IC.caller env

| ICCallPrim _FIXME, [f;e;k;r;c] ->
| ICCallPrim, [f;e;k;r;c] ->
SR.unit, begin
(* TBR: Can we do better than using the notes? *)
let _, _, _, ts1, _ = Type.as_func f.note.Note.typ in
Expand Down Expand Up @@ -12492,7 +12492,7 @@ and compile_exp_with_hint (env : E.t) ae sr_hint exp =
let return_arity = List.length return_tys in
let mk_body env1 ae1 = compile_exp_as env1 ae1 (StackRep.of_arity return_arity) e in
FuncDec.lit env ae x sort control captured args mk_body return_tys exp.at
| SelfCallE (cyc_FIXME, ts, exp_f, exp_k, exp_r, exp_c) ->
| SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
SR.unit,
let (set_future, get_future) = new_local env "future" in
let (set_k, get_k) = new_local env "k" in
Expand Down
27 changes: 9 additions & 18 deletions src/ir_def/arrange_ir.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,15 +22,14 @@ let rec exp e = match e.it with
| SwitchE (e, cs) -> "SwitchE" $$ [exp e] @ List.map case cs
| LoopE e1 -> "LoopE" $$ [exp e1]
| LabelE (i, t, e) -> "LabelE" $$ [id i; typ t; exp e]
| AsyncE (None, Type.Fut, tb, e, t) -> "AsyncE" $$ [typ_bind tb; exp e; typ t]
| AsyncE (Some par, Type.Fut, tb, e, t) -> "AsyncE()" $$ [exp par; typ_bind tb; exp e; typ t]
| AsyncE (_, Type.Cmp, tb, e, t) -> "AsyncE*" $$ [typ_bind tb; exp e; typ t]
| AsyncE (Type.Fut, tb, e, t) -> "AsyncE" $$ [typ_bind tb; exp e; typ t]
| AsyncE (Type.Cmp, tb, e, t) -> "AsyncE*" $$ [typ_bind tb; exp e; typ t]
| DeclareE (i, t, e1) -> "DeclareE" $$ [id i; exp e1]
| DefineE (i, m, e1) -> "DefineE" $$ [id i; mut m; exp e1]
| FuncE (x, s, c, tp, as_, ts, e) ->
"FuncE" $$ [Atom x; func_sort s; control c] @ List.map typ_bind tp @ args as_ @ [ typ (Type.seq ts); exp e]
| SelfCallE (par, ts, exp_f, exp_k, exp_r, exp_c) ->
"SelfCallE" $$ [exp par; typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r; exp exp_c]
| SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
"SelfCallE" $$ [typ (Type.seq ts); exp exp_f; exp exp_k; exp exp_r; exp exp_c]
| ActorE (ds, fs, u, t) -> "ActorE" $$ List.map dec ds @ fields fs @ [system u; typ t]
| NewObjE (s, fs, t) -> "NewObjE" $$ (Arrange_type.obj_sort s :: fields fs @ [typ t])
| TryE (e, cs, None) -> "TryE" $$ [exp e] @ List.map case cs
Expand Down Expand Up @@ -62,8 +61,7 @@ and args = function
and arg a = Atom a.it

and prim = function
| CallPrim (ts, par) when empty par -> "CallPrim" $$ List.map typ ts
| CallPrim (ts, par) -> "CallPrim()" $$ [exp par] @ List.map typ ts
| CallPrim ts -> "CallPrim" $$ List.map typ ts
| UnPrim (t, uo) -> "UnPrim" $$ [typ t; Arrange_ops.unop uo]
| BinPrim (t, bo) -> "BinPrim" $$ [typ t; Arrange_ops.binop bo]
| RelPrim (t, ro) -> "RelPrim" $$ [typ t; Arrange_ops.relop ro]
Expand Down Expand Up @@ -97,41 +95,34 @@ and prim = function
| ActorOfIdBlob t -> "ActorOfIdBlob" $$ [typ t]
| BlobOfIcUrl -> Atom "BlobOfIcUrl"
| IcUrlOfBlob -> Atom "IcUrlOfBlob"
| SelfRef t -> "SelfRef" $$ [typ t]
| SelfRef t -> "SelfRef" $$ [typ t]
| SystemTimePrim -> Atom "SystemTimePrim"
| SystemTimeoutPrim -> Atom "SystemTimeoutPrim"
| SystemCyclesAddPrim -> Atom "SystemCyclesAddPrim"
| SystemCyclesAcceptPrim -> Atom "SystemCyclesAcceptPrim"
| SystemCyclesAvailablePrim -> Atom "SystemCyclesAvailablePrim"
| SystemCyclesBalancePrim -> Atom "SystemCyclesBalancePrim"
| SystemCyclesRefundedPrim -> Atom "SystemCyclesRefundedPrim"
| SystemCyclesBurnPrim -> Atom "SystemCyclesBurnPrim"
| ICCallAttrsPrim -> Atom "ICCallAttrsPrim"
| SetCertifiedData -> Atom "SetCertifiedData"
| GetCertificate -> Atom "GetCertificate"
| OtherPrim s -> Atom s
| CPSAwait (Type.Fut, t) -> "CPSAwait" $$ [typ t]
| CPSAwait (Type.Cmp, t) -> "CPSAwait*" $$ [typ t]
| CPSAsync (Type.Fut, t, par) -> "CPSAsync" $$ [exp par] @ [typ t]
| CPSAsync (Type.Cmp, t, _) -> "CPSAsync*" $$ [typ t]
| CPSAsync (Type.Fut, t) -> "CPSAsync" $$ [typ t]
| CPSAsync (Type.Cmp, t) -> "CPSAsync*" $$ [typ t]
| ICArgDataPrim -> Atom "ICArgDataPrim"
| ICStableSize t -> "ICStableSize" $$ [typ t]
| ICPerformGC -> Atom "ICPerformGC"
| ICReplyPrim ts -> "ICReplyPrim" $$ List.map typ ts
| ICRejectPrim -> Atom "ICRejectPrim"
| ICCallerPrim -> Atom "ICCallerPrim"
| ICCallPrim e -> "ICCallPrim" $$ [exp e]
| ICCallPrim -> Atom "ICCallPrim"
| ICCallRawPrim -> Atom "ICCallRawPrim"
| ICMethodNamePrim -> Atom "ICMethodNamePrim"
| ICReplyDeadlinePrim -> Atom "ICReplyDeadlinePrim"
| ICStableWrite t -> "ICStableWrite" $$ [typ t]
| ICStableRead t -> "ICStableRead" $$ [typ t]

and empty exp =
Type.(is_obj exp.note.Note.typ
&& (let (s, fls) = as_obj exp.note.Note.typ in
s = Object && fls = []))

and mut = function
| Const -> Atom "Const"
| Var -> Atom "Var"
Expand Down
28 changes: 9 additions & 19 deletions src/ir_def/check_ir.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -405,9 +405,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
| PrimE (p, es) ->
List.iter (check_exp env) es;
begin match p, es with
| CallPrim (insts, par), [exp1; exp2] ->
check_exp { env with async = None } par;
typ par <: T.(Obj (Object, []));
| CallPrim insts, [exp1; exp2] ->
begin match T.promote (typ exp1) with
| T.Func (sort, control, tbs, arg_tys, ret_tys) ->
check_inst_bounds env tbs insts exp.at;
Expand Down Expand Up @@ -558,8 +556,6 @@ let rec check_exp env (exp:Ir.exp) : unit =
check (T.shared (T.seq ots)) "DeserializeOpt is not defined for operand type";
typ exp1 <: T.blob;
T.Opt (T.seq ots) <: t
| ICCallAttrsPrim, [] ->
T.(Opt (Obj (Object, []))) <: t
| CPSAwait (s, cont_typ), [a; krb] ->
let (_, t1) =
try T.as_async_sub s T.Non (T.normalize (typ a))
Expand All @@ -578,9 +574,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
| _ -> error env exp.at "CPSAwait bad cont");
check (not (env.flavor.has_await)) "CPSAwait await flavor";
check (env.flavor.has_async_typ) "CPSAwait in post-async flavor";
| CPSAsync (s, t0, par), [exp] ->
check_exp { env with async = None } par;
typ par <: T.(Opt (Obj (Object, [])));
| CPSAsync (s, t0), [exp] ->
(match typ exp with
| T.Func (T.Local, T.Returns, [tb],
T.[Func (Local, Returns, [], ts1, []);
Expand All @@ -607,8 +601,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
T.Non <: t
| ICCallerPrim, [] ->
T.caller <: t
| ICCallPrim setup, [exp1; exp2; k; r; c] ->
typ setup <: T.unit;
| ICCallPrim, [exp1; exp2; k; r; c] ->
let t1 = T.promote (typ exp1) in
begin match t1 with
| T.Func (sort, T.Replies, _ (*TBR*), arg_tys, ret_tys) ->
Expand Down Expand Up @@ -691,9 +684,6 @@ let rec check_exp env (exp:Ir.exp) : unit =
| SystemCyclesAddPrim, [e1] ->
typ e1 <: T.nat;
T.unit <: t
| SystemTimeoutPrim, [e1] ->
typ e1 <: T.nat32;
T.unit <: t
(* Certified Data *)
| SetCertifiedData, [e1] ->
typ e1 <: T.blob;
Expand Down Expand Up @@ -734,6 +724,10 @@ let rec check_exp env (exp:Ir.exp) : unit =
| SwitchE (exp1, cases) ->
check_exp env exp1;
let t1 = T.promote (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
| TryE (exp1, cases, vt) ->
check env.flavor.has_await "try in non-await flavor";
Expand All @@ -752,9 +746,7 @@ let rec check_exp env (exp:Ir.exp) : unit =
check_exp (add_lab env id t0) exp1;
typ exp1 <: t0;
t0 <: t
| AsyncE (par, s, tb, exp1, t0) ->
Option.iter (check_exp { env with async = None }) par;
Option.iter (fun par -> typ par <: T.(Obj (Object, []))) par;
| AsyncE (s, tb, exp1, t0) ->
check env.flavor.has_await "async expression in non-await flavor";
check_typ env t0;
let c, tb, ce = check_open_typ_bind env tb in
Expand Down Expand Up @@ -813,15 +805,13 @@ let rec check_exp env (exp:Ir.exp) : unit =
, tbs, List.map (T.close cs) ts1, List.map (T.close cs) ret_tys
) in
fun_ty <: t
| SelfCallE (par, ts, exp_f, exp_k, exp_r, exp_c) ->
| SelfCallE (ts, exp_f, exp_k, exp_r, exp_c) ->
check (not env.flavor.Ir.has_async_typ) "SelfCallE in async flavor";
check_exp env par;
List.iter (check_typ env) ts;
check_exp { env with lvl = NotTopLvl } exp_f;
check_exp env exp_k;
check_exp env exp_r;
check_exp env exp_c;
typ par <: T.(Opt (Obj (Object, [])));
typ exp_f <: T.unit;
typ exp_k <: T.(Construct.contT (Tup ts) unit);
typ exp_r <: T.(Construct.err_contT unit);
Expand Down
Loading

0 comments on commit e7f9027

Please sign in to comment.