Skip to content

Commit

Permalink
standarize constructor names
Browse files Browse the repository at this point in the history
  • Loading branch information
@butterunderflow
butterunderflow committed Aug 17, 2024
1 parent a3e34a7 commit fcb26c8
Show file tree
Hide file tree
Showing 23 changed files with 1,791 additions and 1,688 deletions.
62 changes: 32 additions & 30 deletions lib/back/closure_translator.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -122,8 +122,8 @@ let get_all_member_names (mems : object_field list) =
mems
|> List.map (fun mem ->
match mem with
| FSimple (x, _) -> [ x ]
| FLetRec (_, binds) -> fst (List.split binds))
| Field_simple (x, _) -> [ x ]
| Field_letrec (_, binds) -> fst (List.split binds))
|> List.flatten

let rec trans_main_expr buf (_e : expr) =
Expand All @@ -141,11 +141,11 @@ int main()

and trans_expr ctx e =
match e with
| EVar x -> (List.assoc x ctx.dict, [])
| EExt ff_name ->
| Exp_var x -> (List.assoc x ctx.dict, [])
| Exp_external ff_name ->
( ff_name (* assume we can access an ff object by its external name*),
[] )
| ELet (x, e0, e1) ->
| Exp_let (x, e0, e1) ->
let e0_v, e0_stmts = trans_expr ctx e0 in
let result_stmt = e0_stmts in
let x, ctx = create_var ~need_decl:true x ctx in
Expand All @@ -155,10 +155,10 @@ and trans_expr ctx e =
let e1_v, e1_stmts = trans_expr ctx e1 in
let result_stmt = result_stmt @ e1_stmts in
(e1_v, result_stmt)
| EConst c ->
| Exp_const c ->
let ret_v = create_decl "temp" ctx in
(ret_v, [ make_assign (VARIABLE ret_v) (trans_const c) ])
| ETuple es ->
| Exp_tuple es ->
let es_v, stmts_list = List.split (List.map (trans_expr ctx) es) in
let stmts = List.flatten stmts_list in
let tu = create_decl "tu" ctx in
Expand All @@ -180,7 +180,7 @@ and trans_expr ctx e =
]
in
(tu, stmts)
| EIf (e0, e1, e2) ->
| Exp_if (e0, e1, e2) ->
let ifel_v = create_decl "ifel_res" ctx in
let e0_v, e0_stmts = trans_expr ctx e0 in
let e1_v, e1_stmts = trans_expr ctx e1 in
Expand All @@ -198,7 +198,7 @@ and trans_expr ctx e =
(e2_stmts
@ [ make_assign (VARIABLE ifel_v) (VARIABLE e2_v) ]) ));
] )
| EApp (e0, e1s) ->
| Exp_app (e0, e1s) ->
let app_v = create_decl "app_res" ctx in
let e0_v, e0_stmts = trans_expr ctx e0 in
let e1_vs, e1_stmts = List.(split (map (trans_expr ctx) e1s)) in
Expand All @@ -211,21 +211,21 @@ and trans_expr ctx e =
( ff_apply,
VARIABLE e0_v :: List.map (fun x -> C.VARIABLE x) e1_vs ));
] )
| ECons i ->
| Exp_constr i ->
let constr_v = create_decl (Printf.sprintf "constr%d" i) ctx in
( constr_v,
[
make_assign (VARIABLE constr_v)
(CALL (ff_constr_np, [ CONSTANT (CONST_INT (string_of_int i)) ]));
] )
| EConsWith i ->
| Exp_payload_constr i ->
let constr_v = create_decl (Printf.sprintf "constr%d" i) ctx in
( constr_v,
[
make_assign (VARIABLE constr_v)
(CALL (ff_constr_p, [ CONSTANT (CONST_INT (string_of_int i)) ]));
] )
| EField (e, name) ->
| Exp_field (e, name) ->
let field = create_decl "field" ctx in
let e_v, e_stmts = trans_expr ctx e in
( field,
Expand All @@ -235,7 +235,7 @@ and trans_expr ctx e =
(CALL
(ff_get_mem, [ VARIABLE e_v; CONSTANT (CONST_STRING name) ]));
] )
| EClosure (fvs, cfunc) ->
| Exp_closure (fvs, cfunc) ->
let clos_v = create_decl "clos" ctx in
let fvs_c = List.map (fun fv -> List.assoc fv ctx.dict) fvs in
let cfn_name = to_c_ident_fn cfunc in
Expand All @@ -250,23 +250,23 @@ and trans_expr ctx e =
CAST (ff_erased_fptr_typename, VARIABLE cfn_name);
] ));
] )
| ELetRec ((fvs, binds), body) ->
| Exp_letrec ((fvs, binds), body) ->
let _binds_c, letrec_init, ctx = trans_letrec fvs binds ctx in
let body_c, body_stmts = trans_expr ctx body in
(body_c, letrec_init @ body_stmts)
| EModObject members ->
| Exp_mod_obj members ->
let stmts, mems_c, ctx =
List.fold_left
(fun (stmts_acc, mems_c_acc, ctx) mem ->
match mem with
| FSimple (x, e) ->
| Field_simple (x, e) ->
let e_c, e_stmts = trans_expr ctx e in
let x_c, ctx = create_var ~need_decl:true x ctx in
( stmts_acc @ e_stmts
@ [ make_assign (VARIABLE x_c) (VARIABLE e_c) ],
mems_c_acc @ [ x_c ],
ctx )
| FLetRec (fvs, binds) ->
| Field_letrec (fvs, binds) ->
let binds_c, bind_stmts, ctx = trans_letrec fvs binds ctx in
(stmts_acc @ bind_stmts, mems_c_acc @ binds_c, ctx))
([], [], ctx) members
Expand All @@ -288,7 +288,7 @@ and trans_expr ctx e =
make_compound (List.map (fun x -> C.VARIABLE x) mems_c);
] ));
] )
| ESwitch (e, bs) ->
| Exp_switch (e, bs) ->
(* match x with | Cons[1](y, z, w) -> e
*
=>
Expand All @@ -313,7 +313,7 @@ and trans_expr ctx e =
C.DOWHILE
(C.CONSTANT (C.CONST_INT "0"), make_stmt_seq (e_stmts @ branches));
] )
| ECmp (op, e0, e1) ->
| Exp_cmp (op, e0, e1) ->
let is_eq_v = create_decl "is_eq" ctx in
let e0_v, e0_stmts = trans_expr ctx e0 in
let e1_v, e1_stmts = trans_expr ctx e1 in
Expand All @@ -328,26 +328,28 @@ and trans_expr ctx e =
make_assign (VARIABLE is_eq_v)
(CALL (eq_fn, [ VARIABLE e0_v; VARIABLE e1_v ]));
] )
| ESeq (e0, e1) ->
| Exp_seq (e0, e1) ->
let _e0_v, e0_stmts = trans_expr ctx e0 in
let e1_v, e1_stmts = trans_expr ctx e1 in
(e1_v, e0_stmts @ e1_stmts)
| EStruct _ -> ("todo", [])
| Exp_struct _ -> ("todo", [])

and trans_const (c : S.constant) =
match c with
| CBool b ->
| Const_bool b ->
C.CALL (ff_make_bool, [ CONSTANT (CONST_INT (if b then "1" else "0")) ])
| CInt i -> C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ])
| CString s ->
| Const_int i ->
C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int i)) ])
| Const_string s ->
C.CALL
( ff_make_str,
[
CONSTANT
(CONST_STRING
(Scanf.unescaped (String.sub s 1 (String.length s - 2))));
] )
| CUnit -> C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int 0)) ])
| Const_unit ->
C.CALL (ff_make_int, [ CONSTANT (CONST_INT (string_of_int 0)) ])

and trans_switch res cond p e ctx =
let match_seq, ctx = analyze_match_sequence cond p ctx in
Expand All @@ -366,16 +368,16 @@ and trans_switch res cond p e ctx =
and analyze_match_sequence (cond_var : string) (p : pattern) ctx :
match_operation list * context =
match p with
| PVar x ->
| Pat_var x ->
let x, ctx = create_var ~need_decl:true x ctx in
([ Bind C.(BINARY (ASSIGN, VARIABLE x, VARIABLE cond_var)) ], ctx)
| PVal c ->
| Pat_val c ->
( [
CheckPat
(C.CALL (ff_is_equal_aux, [ VARIABLE cond_var; trans_const c ]));
],
ctx )
| PCons (id, None) ->
| Pat_constr (id, None) ->
( [
CheckPat
(C.CALL
Expand All @@ -385,7 +387,7 @@ and analyze_match_sequence (cond_var : string) (p : pattern) ctx :
] ));
],
ctx )
| PCons (id, Some p) ->
| Pat_constr (id, Some p) ->
let pat_var = create_decl "pat_var" ctx in
let check =
CheckPat
Expand All @@ -399,7 +401,7 @@ and analyze_match_sequence (cond_var : string) (p : pattern) ctx :
in
let match_seq, ctx = analyze_match_sequence pat_var p ctx in
(check :: match_seq, ctx)
| PTuple ps ->
| Pat_tuple ps ->
let pat_vars =
List.mapi
(fun index _ -> create_decl (Printf.sprintf "tu_%dth" index) ctx)
Expand Down
38 changes: 19 additions & 19 deletions lib/clos/closure.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,31 +5,31 @@ module L = Lam.Tree
type constant = T.constant [@@deriving sexp]

type expr =
| ETuple of expr list
| EModObject of object_field list
| Exp_tuple of expr list
| Exp_mod_obj of object_field list
(** 1. An object can cast to another when possible ;
2. Field of an object is visible in the scope following its declaration. *)
| EStruct of (string * expr) list
| EVar of string
| EExt of string
| ECons of int
| EConsWith of int
| EConst of constant
| EApp of expr * expr list
| ESwitch of expr * branch list
| ELet of string * expr * expr
| EIf of expr * expr * expr
| EClosure of closure
| ELetRec of closure_rec * expr
| EField of expr * string
| ECmp of T.cmp_op * expr * expr
| ESeq of expr * expr
| Exp_struct of (string * expr) list
| Exp_var of string
| Exp_external of string
| Exp_constr of int
| Exp_payload_constr of int
| Exp_const of constant
| Exp_app of expr * expr list
| Exp_switch of expr * branch list
| Exp_let of string * expr * expr
| Exp_if of expr * expr * expr
| Exp_closure of closure
| Exp_letrec of closure_rec * expr
| Exp_field of expr * string
| Exp_cmp of T.cmp_op * expr * expr
| Exp_seq of expr * expr

and pattern = L.pattern

and object_field =
| FSimple of string * expr
| FLetRec of closure_rec
| Field_simple of string * expr
| Field_letrec of closure_rec

and closure = string list * Ident.ident

Expand Down
68 changes: 34 additions & 34 deletions lib/clos/lift.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,27 +4,27 @@ module L = Lam.Tree
let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) :
C.expr * C.func list =
match e with
| L.ETuple es ->
| L.Exp_tuple es ->
es
|> List.map (fun e -> lift e vars ~hint)
|> List.split
|> fun (es, fns) -> (C.ETuple es, List.flatten fns)
| L.EModObject mems ->
|> fun (es, fns) -> (C.Exp_tuple es, List.flatten fns)
| L.Exp_mod_obj mems ->
let _, mems, fns =
List.fold_left
(fun (vars, mem_acc, fn_acc) mem ->
match mem with
| L.FSimple (x, e) ->
| L.Field_simple (x, e) ->
let e, fns = lift ~hint:x e vars in
(x :: vars, C.FSimple (x, e) :: mem_acc, fns @ fn_acc)
| L.FLetRec binds ->
(x :: vars, C.Field_simple (x, e) :: mem_acc, fns @ fn_acc)
| L.Field_letrec binds ->
let xs, _ = List.split binds in
let binds, fns = lift_letrec binds vars in
(xs @ vars, C.FLetRec binds :: mem_acc, fns @ fn_acc))
(xs @ vars, C.Field_letrec binds :: mem_acc, fns @ fn_acc))
(vars, [], []) mems
in
(C.EModObject (List.rev mems), fns)
| L.EStruct mems ->
(C.Exp_mod_obj (List.rev mems), fns)
| L.Exp_struct mems ->
let mems, fns =
List.fold_left
(fun (acc_mems, acc_fns) (name, e) ->
Expand All @@ -33,28 +33,28 @@ let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) :
([], []) mems
in
let mems = List.rev mems in
(C.EStruct mems, fns)
| L.EVar x ->
(C.Exp_struct mems, fns)
| L.Exp_var x ->
assert (List.mem x vars);
(C.EVar x, [])
| L.EExt x -> (C.EExt x, [])
| L.ECons i -> (C.ECons i, [])
| L.EConsWith i -> (C.EConsWith i, [])
| L.EConst c -> (C.EConst c, [])
| L.EApp (e0, e1s) ->
(C.Exp_var x, [])
| L.Exp_external x -> (C.Exp_external x, [])
| L.Exp_constr i -> (C.Exp_constr i, [])
| L.Exp_payload_constr i -> (C.Exp_payload_constr i, [])
| L.Exp_const c -> (C.Exp_const c, [])
| L.Exp_app (e0, e1s) ->
let e0, fns0 = lift e0 vars in
let e1s, fns1 = List.(split (map (fun e1 -> lift e1 vars) e1s)) in
let fns1 = List.flatten fns1 in
(C.EApp (e0, e1s), fns0 @ fns1)
| L.ECmp (op, e0, e1) ->
(C.Exp_app (e0, e1s), fns0 @ fns1)
| L.Exp_cmp (op, e0, e1) ->
let e0, fns0 = lift e0 vars in
let e1, fns1 = lift e1 vars in
(C.ECmp (op, e0, e1), fns0 @ fns1)
| L.ESeq (e0, e1) ->
(C.Exp_cmp (op, e0, e1), fns0 @ fns1)
| L.Exp_seq (e0, e1) ->
let e0, fns0 = lift e0 vars in
let e1, fns1 = lift e1 vars in
(C.ESeq (e0, e1), fns0 @ fns1)
| L.ESwitch (e0, bs) ->
(C.Exp_seq (e0, e1), fns0 @ fns1)
| L.Exp_switch (e0, bs) ->
let e0, fns0 = lift e0 vars in
let es, fns1 =
bs
Expand All @@ -64,29 +64,29 @@ let rec lift ?(hint = "temp") (e : L.expr) (vars : string list) :
|> fun (e, fns) -> (e, List.flatten fns)
in
let ps, _ = List.split bs in
(C.ESwitch (e0, List.combine ps es), fns0 @ fns1)
| L.ELet (x, e0, e1) ->
(C.Exp_switch (e0, List.combine ps es), fns0 @ fns1)
| L.Exp_let (x, e0, e1) ->
let e0, fns0 = lift ~hint:x e0 vars in
let e1, fns1 = lift e1 (x :: vars) ~hint in
(C.ELet (x, e0, e1), fns0 @ fns1)
| L.EIf (e0, e1, e2) ->
(C.Exp_let (x, e0, e1), fns0 @ fns1)
| L.Exp_if (e0, e1, e2) ->
let e0, fns0 = lift ~hint e0 vars in
let e1, fns1 = lift ~hint e1 vars in
let e2, fns2 = lift ~hint e2 vars in
(C.EIf (e0, e1, e2), fns0 @ fns1 @ fns2)
| L.ELam (xs, e, fvs) ->
(C.Exp_if (e0, e1, e2), fns0 @ fns1 @ fns2)
| L.Exp_lam (xs, e, fvs) ->
let fn_id = Ident.create ~hint in
let e', fns = lift e (xs @ vars) ~hint in
let new_fn = (fn_id, !fvs, xs, e') in
(C.EClosure (!fvs, fn_id), new_fn :: fns)
| L.ELetRec (binds, e) ->
(C.Exp_closure (!fvs, fn_id), new_fn :: fns)
| L.Exp_letrec (binds, e) ->
let xs, _ = List.split binds in
let cls, fns = lift_letrec binds vars in
let e, fns' = lift e (xs @ vars) ~hint in
(C.ELetRec (cls, e), fns' @ fns)
| L.EField (e, name) ->
(C.Exp_letrec (cls, e), fns' @ fns)
| L.Exp_field (e, name) ->
let e', fns = lift e vars ~hint in
(C.EField (e', name), fns)
(C.Exp_field (e', name), fns)

and lift_letrec binds vars =
let xs = List.map fst binds in
Expand Down
Loading

0 comments on commit fcb26c8

Please sign in to comment.