imiel/retroid
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
imiel
2026-05-03 02:25:30 +00:00
commit b193cece66
14 changed files with 1391 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+3
View File
@@ -0,0 +1,3 @@
_build/
*.install
*.merlin
README.md
+3
View File
@@ -0,0 +1,3 @@
# retroid
small compiler pipeline for a restricted OCaml language
src/cfg.ml
+221
View File
@@ -0,0 +1,221 @@
open Ir
type block_id = int
type block = {
bid: block_id;
label: string;
stmts: ir list;
terminator: terminator;
}
and terminator =
| TJump of block_id
| TCondJump of ir * block_id * block_id
| TReturn of ir
| TLabel of string
| TNone
type cfg = {
blocks: block list;
edges: (block_id * block_id) list;
entry: block_id;
}
let fresh_bid =
let c = ref 0 in
fun () -> incr c; !c
let string_of_ir_node ir =
let effs = string_of_effects !(ir.effects) in
let n = match ir.node with
| Var x -> Printf.sprintf "%%%s" x
| Lit (LInt n) -> string_of_int n
| Lit (LBool b) -> string_of_bool b
| Lam (x, _) -> Printf.sprintf "(fun %s -> ...)" x
| App (_, _) -> "(app ...)"
| Let (x, _, _) -> Printf.sprintf "(let %s = ...)" x
| If (_, _, _) -> "(if ...)"
| Prim (PAdd, _) -> "(+ ...)"
| Prim (PSub, _) -> "(- ...)"
| Prim (PMul, _) -> "(* ...)"
| Prim (PDiv, _) -> "(/ ...)"
| Prim (PEq, _) -> "(= ...)"
| Prim (PNeq, _) -> "(<> ...)"
| Prim (PLt, _) -> "(< ...)"
| Prim (PLe, _) -> "(<= ...)"
| Prim (PGt, _) -> "(> ...)"
| Prim (PGe, _) -> "(>= ...)"
| Prim (PAnd, _) -> "(&& ...)"
| Prim (POr, _) -> "(|| ...)"
| Fix (_, _) -> "(fix ...)"
| Phi (x, _) -> Printf.sprintf "(phi %s ...)" x
| Jump (l, _) -> Printf.sprintf "(jump %s)" l
| CondJump (_, l1, l2, _) -> Printf.sprintf "(cjump %s %s)" l1 l2
| Label l -> Printf.sprintf "[%s]" l
| Halt _ -> "(halt)"
in
Printf.sprintf "%s [%s]" n effs
let string_of_ir_full ir =
let buf = Buffer.create 256 in
let rec go indent ir =
let effs = string_of_effects !(ir.effects) in
let pad = String.make (indent * 2) ' ' in
begin match ir.node with
| Var x ->
Buffer.add_string buf (Printf.sprintf "%svar %s : %s\n" pad x effs)
| Lit (LInt n) ->
Buffer.add_string buf (Printf.sprintf "%slit %d : %s\n" pad n effs)
| Lit (LBool b) ->
Buffer.add_string buf (Printf.sprintf "%slit %b : %s\n" pad b effs)
| Lam (x, body) ->
Buffer.add_string buf (Printf.sprintf "%slam %s : %s\n" pad x effs);
go (indent + 1) body
| App (f, a) ->
Buffer.add_string buf (Printf.sprintf "%sapp : %s\n" pad effs);
go (indent + 1) f;
go (indent + 1) a
| Let (x, rhs, body) ->
Buffer.add_string buf (Printf.sprintf "%slet %s : %s\n" pad x effs);
go (indent + 1) rhs;
go indent body
| If (c, t, f) ->
Buffer.add_string buf (Printf.sprintf "%sif : %s\n" pad effs);
go (indent + 1) c;
Buffer.add_string buf (Printf.sprintf "%sthen : %s\n" pad effs);
go (indent + 1) t;
Buffer.add_string buf (Printf.sprintf "%selse : %s\n" pad effs);
go (indent + 1) f
| Prim (op, args) ->
let op_s = match op with
| PAdd -> "+" | PSub -> "-" | PMul -> "*" | PDiv -> "/"
| PEq -> "=" | PNeq -> "<>" | PLt -> "<" | PLe -> "<="
| PGt -> ">" | PGe -> ">=" | PAnd -> "&&" | POr -> "||"
in
Buffer.add_string buf (Printf.sprintf "%sprim %s : %s\n" pad op_s effs);
List.iter (fun a -> go (indent + 1) a) args
| Fix (defs, body) ->
Buffer.add_string buf (Printf.sprintf "%sfix : %s\n" pad effs);
List.iter (fun (f, x, d) ->
Buffer.add_string buf (Printf.sprintf "%s rec %s(%s) : %s\n" pad f x effs);
go (indent + 2) d
) defs;
go indent body
| Phi (x, choices) ->
let cs = String.concat ", " (List.map (fun (l, _) -> l) choices) in
Buffer.add_string buf (Printf.sprintf "%sphi %s <- (%s) : %s\n" pad x cs effs)
| Jump (l, _args) ->
Buffer.add_string buf (Printf.sprintf "%sjump %s : %s\n" pad l effs)
| CondJump (_, l1, l2, _) ->
Buffer.add_string buf (Printf.sprintf "%scjump %s %s : %s\n" pad l1 l2 effs)
| Label l ->
Buffer.add_string buf (Printf.sprintf "%slabel %s : %s\n" pad l effs)
| Halt e ->
Buffer.add_string buf (Printf.sprintf "%shalt : %s\n" pad effs);
go (indent + 1) e
end
in
go 0 ir; Buffer.contents buf
let flatten_to_blocks ir =
let blocks = ref [] in
let edges = ref [] in
let rec flatten cur_bid stmts ir =
match ir.node with
| Var _ | Lit _ ->
let ret = fresh_bid () in
blocks := {bid=ret; label=""; stmts=List.rev (ir::stmts); terminator=TReturn ir} :: !blocks;
edges := (cur_bid, ret) :: !edges;
ret
| Lam (_x, _body) ->
let ret = fresh_bid () in
blocks := {bid=ret; label=""; stmts=List.rev (ir::stmts); terminator=TReturn ir} :: !blocks;
edges := (cur_bid, ret) :: !edges;
ret
| App (_, _) ->
let fn_bid = fresh_bid () in
blocks := {bid=fn_bid; label=""; stmts=[]; terminator=TNone} :: !blocks;
edges := (cur_bid, fn_bid) :: !edges;
let arg_bid = fresh_bid () in
blocks := {bid=arg_bid; label=""; stmts=[]; terminator=TNone} :: !blocks;
edges := (fn_bid, arg_bid) :: !edges;
let ret = fresh_bid () in
blocks := {bid=ret; label=""; stmts=List.rev (ir::stmts); terminator=TReturn ir} :: !blocks;
edges := (arg_bid, ret) :: !edges;
ret
| Let (_x, rhs, body) ->
let rhs_bid = flatten cur_bid stmts rhs in
flatten rhs_bid [ir] body
| If (c, t, f) ->
let cond_bid = flatten cur_bid stmts c in
let then_bid = fresh_bid () in
blocks := {bid=then_bid; label="then"; stmts=[]; terminator=TNone} :: !blocks;
let else_bid = fresh_bid () in
blocks := {bid=else_bid; label="else"; stmts=[]; terminator=TNone} :: !blocks;
let join_bid = fresh_bid () in
blocks := {bid=join_bid; label="join"; stmts=[]; terminator=TNone} :: !blocks;
let then_end = flatten then_bid [] t in
let else_end = flatten else_bid [] f in
edges := (then_end, join_bid) :: (else_end, join_bid) :: !edges;
blocks := {bid=cond_bid; label=""; stmts=[]; terminator=TCondJump(c, then_bid, else_bid)} :: !blocks;
join_bid
| Prim (_, _) ->
let ret = fresh_bid () in
blocks := {bid=ret; label=""; stmts=List.rev (ir::stmts); terminator=TReturn ir} :: !blocks;
edges := (cur_bid, ret) :: !edges;
ret
| Fix (defs, body) ->
let fix_bid = fresh_bid () in
blocks := {bid=fix_bid; label=""; stmts=List.rev (ir::stmts); terminator=TNone} :: !blocks;
let def_bids = List.map (fun (f, _, d) ->
let def_bid = fresh_bid () in
blocks := {bid=def_bid; label=f; stmts=[]; terminator=TNone} :: !blocks;
edges := (fix_bid, def_bid) :: !edges;
let end_bid = flatten def_bid [] d in
(f, end_bid)
) defs in
List.iter (fun (_, bid) -> edges := (bid, fix_bid) :: !edges) def_bids;
let body_end = flatten fix_bid [] body in
body_end
| Phi _ | Jump _ | CondJump _ | Label _ | Halt _ ->
let ret = fresh_bid () in
blocks := {bid=ret; label=""; stmts=List.rev (ir::stmts); terminator=TNone} :: !blocks;
edges := (cur_bid, ret) :: !edges;
ret
in
let entry = fresh_bid () in
let _exit = flatten entry [] ir in
let block_table = Hashtbl.create 64 in
List.iter (fun b -> Hashtbl.add block_table b.bid b) !blocks;
let blocks_sorted = Hashtbl.fold (fun _ b acc -> b :: acc) block_table [] in
{ blocks = blocks_sorted; edges = !edges; entry }
let emit_dot (cfg : cfg) (filename : string) =
let oc = open_out filename in
let pp = Printf.fprintf in
pp oc "digraph CFG {\n";
pp oc " rankdir=TB;\n";
pp oc " node [shape=box, fontname=\"monospace\", fontsize=10];\n";
pp oc " edge [fontname=\"monospace\", fontsize=9];\n";
pp oc " entry [shape=oval, label=\"entry\"];\n";
pp oc " entry -> n%d;\n" cfg.entry;
List.iter (fun b ->
let label = String.concat "\\l" (
(if b.label <> "" then [Printf.sprintf "[%s]" b.label] else []) @
List.map (fun s -> String.escaped (string_of_ir_node s)) b.stmts @
[match b.terminator with
| TJump tgt -> Printf.sprintf "jump n%d" tgt
| TCondJump (_, t, f) -> Printf.sprintf "cjump n%d, n%d" t f
| TReturn _ -> "ret"
| TLabel l -> Printf.sprintf "label %s" l
| TNone -> "fallthrough"])
^ "\\l"
in
pp oc " n%d [label=\"%s\"];\n" b.bid label
) cfg.blocks;
List.iter (fun (from_bid, to_bid) ->
pp oc " n%d -> n%d;\n" from_bid to_bid
) cfg.edges;
pp oc "}\n";
close_out oc
src/cps.ml
+111
View File
@@ -0,0 +1,111 @@
open Ir
open Effects
let gensym =
let c = ref 0 in
fun prefix -> incr c; Printf.sprintf "%s%d" prefix !c
let app f a = mk (App (f, a))
let var x = mk (Var x)
let cps_transform ir =
let rec cps ir k =
match ir.node with
| Var _ | Lit _ ->
app k ir
| Lam (x, body) ->
let k' = gensym "k" in
let body_cps = cps body (var k') in
app k (mk (Lam (x, mk (Lam (k', body_cps)))))
| App (f, a) ->
let vf = gensym "f" in
let va = gensym "a" in
let vr = gensym "r" in
cps f (mk (Lam (vf,
cps a (mk (Lam (va,
app (app (var vf) (var va))
(mk (Lam (vr, app k (var vr))))))))))
| Let (x, rhs, body) ->
cps rhs (mk (Lam (x, cps body k)))
| If (c, t, f) ->
let vc = gensym "c" in
cps c (mk (Lam (vc,
mk (If (var vc, cps t k, cps f k)))))
| Prim (op, args) ->
cps_prim args k (fun vs ->
let prim_args = List.map (fun v -> var v) vs in
app k (mk (Prim (op, prim_args))))
| Fix (defs, body) ->
let defs_cps = List.map (fun (f_name, x, d) ->
let k' = gensym "k" in
let d_cps = cps d (var k') in
(f_name, x, mk (Lam (k', d_cps)))
) defs in
app k (mk (Fix (defs_cps, cps body (var (gensym "k")))))
| Phi _ | Jump _ | CondJump _ | Label _ | Halt _ ->
app k ir
and cps_prim args _k cont =
let vs = List.map (fun _ -> gensym "v") args in
let rec bind i =
if i >= List.length args then cont vs
else
cps (List.nth args i) (mk (Lam (List.nth vs i, bind (i + 1))))
in
bind 0
in
let k = gensym "halt" in
let identity = mk (Lam (k, var k)) in
let result = cps ir identity in
analyse result;
result
let inline_conts ir =
let rec go ir =
let n = match ir.node with
| App ({node=Lam(x,body);_}, arg) when is_small body ->
let n' = subst x arg body in n'.node
| _ -> ir.node
in
let ir' = copy_node_with_uid ir n in
map_children go ir'
and is_small ir = match ir.node with
| Var _ | Lit _ -> true
| App (f, a) -> is_small f && is_small a
| _ -> false
and subst x v ir =
let n = match ir.node with
| Var y when y = x -> v.node
| Var _ -> ir.node
| Lit _ -> ir.node
| Lam (y, body) when y <> x -> Lam (y, subst x v body)
| Lam _ -> ir.node
| App (f, a) -> App (subst x v f, subst x v a)
| Let (y, rhs, body) when y <> x -> Let (y, subst x v rhs, subst x v body)
| Let _ -> ir.node
| If (c, t, f) -> If (subst x v c, subst x v t, subst x v f)
| Prim (op, args) -> Prim (op, List.map (subst x v) args)
| Fix (defs, body) -> Fix (
List.map (fun (a,b,d) -> if a = x then (a,b,d) else (a,b,subst x v d)) defs,
subst x v body)
| _ -> ir.node
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
and map_children f ir =
let n = match ir.node with
| Var _ | Lit _ | Label _ -> ir.node
| Lam (x, body) -> Lam (x, f body)
| App (fn, arg) -> App (f fn, f arg)
| Let (x, rhs, body) -> Let (x, f rhs, f body)
| If (c, t, fl) -> If (f c, f t, f fl)
| Prim (op, args) -> Prim (op, List.map f args)
| Fix (defs, body) -> Fix (List.map (fun (a,b,d) -> (a,b,f d)) defs, f body)
| Phi (x, choices) -> Phi (x, List.map (fun (l,ir) -> (l, f ir)) choices)
| Jump (l, args) -> Jump (l, List.map f args)
| CondJump (c, l1, l2, args) -> CondJump (f c, l1, l2, List.map f args)
| Halt e -> Halt (f e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
in
go ir
src/diff.ml
+144
View File
@@ -0,0 +1,144 @@
open Ir
type diff_op = Add | Remove | Change
type diff_entry = {
op: diff_op;
path: string;
before: string;
after: string;
}
let string_of_op = function
| Add -> "+"
| Remove -> "-"
| Change -> "~"
let node_summary ir =
match ir.node with
| Var x -> Printf.sprintf "var(%s)" x
| Lit (LInt n) -> Printf.sprintf "int(%d)" n
| Lit (LBool b) -> Printf.sprintf "bool(%b)" b
| Lam (x, _) -> Printf.sprintf "lam(%s)" x
| App _ -> "app"
| Let (x, _, _) -> Printf.sprintf "let(%s)" x
| If _ -> "if"
| Prim (PAdd, _) -> "prim(+)"
| Prim (PSub, _) -> "prim(-)"
| Prim (PMul, _) -> "prim(*)"
| Prim (PDiv, _) -> "prim(/)"
| Prim (PEq, _) -> "prim(=)"
| Prim (PNeq, _) -> "prim(<>)"
| Prim (PLt, _) -> "prim(<)"
| Prim (PLe, _) -> "prim(<=)"
| Prim (PGt, _) -> "prim(>)"
| Prim (PGe, _) -> "prim(>=)"
| Prim (PAnd, _) -> "prim(&&)"
| Prim (POr, _) -> "prim(||)"
| Fix _ -> "fix"
| Phi (x, _) -> Printf.sprintf "phi(%s)" x
| Jump (l, _) -> Printf.sprintf "jump(%s)" l
| CondJump (_, l1, l2, _) -> Printf.sprintf "cjump(%s,%s)" l1 l2
| Label l -> Printf.sprintf "label(%s)" l
| Halt _ -> "halt"
let structural_diff before after =
let diffs = ref [] in
let node_count ir =
let rec go i ir =
let i' = i + 1 in
match ir.node with
| Var _ | Lit _ | Label _ -> i'
| Lam (_, body) -> go i' body
| App (f, a) -> go (go i' f) a
| Let (_, rhs, body) -> go (go i' rhs) body
| If (c, t, f) -> go (go (go i' c) t) f
| Prim (_, args) -> List.fold_left go i' args
| Fix (defs, body) ->
let i'' = List.fold_left (fun i (_, _, d) -> go i d) i' defs in
go i'' body
| Phi (_, choices) -> List.fold_left (fun i (_, ir) -> go i ir) i' choices
| Jump (_, args) -> List.fold_left go i' args
| CondJump (c, _, _, args) -> go (List.fold_left go i' args) c
| Halt e -> go i' e
in
go 0 ir
in
let effects_str ir =
string_of_effects !(ir.effects)
in
let rec walk path a b =
let a_sum = node_summary a in
let b_sum = node_summary b in
let a_eff = effects_str a in
let b_eff = effects_str b in
if a_sum <> b_sum then
diffs := {op=Change; path; before=a_sum ^ "[" ^ a_eff ^ "]";
after=b_sum ^ "[" ^ b_eff ^ "]"} :: !diffs
else if a_eff <> b_eff then
diffs := {op=Change; path; before="effects: " ^ a_eff;
after="effects: " ^ b_eff} :: !diffs;
match a.node, b.node with
| Lam (_, a_b), Lam (_, b_b) -> walk (path ^ "/body") a_b b_b
| App (a_f, a_a), App (b_f, b_a) ->
walk (path ^ "/fn") a_f b_f; walk (path ^ "/arg") a_a b_a
| Let (_, a_r, a_b), Let (_, b_r, b_b) ->
walk (path ^ "/rhs") a_r b_r; walk (path ^ "/body") a_b b_b
| If (a_c, a_t, a_f), If (b_c, b_t, b_f) ->
walk (path ^ "/cond") a_c b_c;
walk (path ^ "/then") a_t b_t;
walk (path ^ "/else") a_f b_f
| Prim (_, a_args), Prim (_, b_args) ->
if List.length a_args = List.length b_args then
List.iteri (fun i (aa, bb) -> walk (Printf.sprintf "%s/arg%d" path i) aa bb)
(List.combine a_args b_args)
else
diffs := {op=Change; path=path ^ "/args";
before=string_of_int (List.length a_args);
after=string_of_int (List.length b_args)} :: !diffs
| Fix (a_defs, a_b), Fix (b_defs, b_b) ->
if List.length a_defs = List.length b_defs then
List.iteri (fun i ((_,_,ad),(_,_,bd)) ->
walk (Printf.sprintf "%s/def%d" path i) ad bd)
(List.combine a_defs b_defs)
else
diffs := {op=Change; path=path ^ "/defs";
before=string_of_int (List.length a_defs);
after=string_of_int (List.length b_defs)} :: !diffs;
walk (path ^ "/body") a_b b_b
| Phi (_, a_c), Phi (_, b_c) ->
if List.length a_c = List.length b_c then
List.iteri (fun i ((_,ai),(_,bi)) ->
walk (Printf.sprintf "%s/choice%d" path i) ai bi)
(List.combine a_c b_c)
| Jump (_, a_args), Jump (_, b_args) ->
List.iteri (fun i (aa, bb) ->
walk (Printf.sprintf "%s/arg%d" path i) aa bb)
(List.combine a_args b_args)
| CondJump (a_c, _, _, a_args), CondJump (b_c, _, _, b_args) ->
walk (path ^ "/cond") a_c b_c;
List.iteri (fun i (aa, bb) ->
walk (Printf.sprintf "%s/arg%d" path i) aa bb)
(List.combine a_args b_args)
| Halt a_e, Halt b_e -> walk (path ^ "/val") a_e b_e
| Var _, Var _ | Lit _, Lit _ | Label _, Label _ -> ()
| _ ->
diffs := {op=Change; path; before=a_sum; after=b_sum} :: !diffs
in
let nodes_a = node_count before in
let nodes_b = node_count after in
walk "/" before after;
if nodes_a <> nodes_b then
diffs := {op=Change; path="/node_count";
before=string_of_int nodes_a;
after=string_of_int nodes_b} :: !diffs;
List.rev !diffs
let format_diff (diffs : diff_entry list) : string =
let buf = Buffer.create 256 in
List.iter (fun d ->
Printf.sprintf " %s %-30s | %-30s -> %-30s\n"
(string_of_op d.op) d.path d.before d.after
|> Buffer.add_string buf
) diffs;
Buffer.contents buf
src/dune
+3
View File
@@ -0,0 +1,3 @@
(executable
(name main)
(modules syntax ir effects parser lower ssa cps passes cfg diff main))
src/effects.ml
+67
View File
@@ -0,0 +1,67 @@
open Ir
let bottom_up ir =
let effs = match ir.node with
| Var _ | Lit _ -> [Pure]
| Lam (_, body) -> !(body.effects)
| App (f, arg) ->
let fe = !(f.effects) in
let ae = !(arg.effects) in
merge_effects (merge_effects fe ae) [MayDiverge]
| Let (_, rhs, body) ->
merge_effects !(rhs.effects) !(body.effects)
| If (cond, t, f) ->
merge_effects (merge_effects !(cond.effects) !(t.effects)) !(f.effects)
| Prim (_, args) ->
List.fold_left (fun acc a -> merge_effects acc !(a.effects)) [Pure] args
| Fix (defs, body) ->
let deffs = List.fold_left (fun acc (_, _, d) ->
merge_effects acc !(d.effects)) [Pure] defs
in
merge_effects deffs !(body.effects)
| Phi (_, choices) ->
List.fold_left (fun acc (_, ir) -> merge_effects acc !(ir.effects)) [Pure] choices
| Jump (_, args) ->
List.fold_left (fun acc a -> merge_effects acc !(a.effects)) [MayDiverge] args
| CondJump (c, _, _, args) ->
let ce = !(c.effects) in
let ae = List.fold_left (fun acc a -> merge_effects acc !(a.effects)) [Pure] args in
merge_effects ce ae
| Label _ -> [Pure]
| Halt e -> merge_effects !(e.effects) [MayDiverge]
in
ir.effects := effs
let rec analyse ir =
bottom_up ir;
(match ir.node with
| Lam (_, body) -> analyse body
| App (f, a) -> analyse f; analyse a
| Let (_, rhs, body) -> analyse rhs; analyse body
| If (c, t, f) -> analyse c; analyse t; analyse f
| Prim (_, args) -> List.iter analyse args
| Fix (defs, body) ->
List.iter (fun (_, _, d) -> analyse d) defs; analyse body
| Phi (_, choices) -> List.iter (fun (_, ir) -> analyse ir) choices
| Jump (_, args) -> List.iter analyse args
| CondJump (c, _, _, args) -> analyse c; List.iter analyse args
| Halt e -> analyse e
| Var _ | Lit _ | Label _ -> ())
let rec propagate ir parent_effs =
let merged = merge_effects parent_effs !(ir.effects) in
ir.effects := merged;
match ir.node with
| Lam (_, body) -> propagate body merged
| App (f, a) -> propagate f merged; propagate a merged
| Let (_, rhs, body) -> propagate rhs merged; propagate body merged
| If (c, t, f) -> propagate c merged; propagate t merged; propagate f merged
| Prim (_, args) -> List.iter (fun a -> propagate a merged) args
| Fix (defs, body) ->
List.iter (fun (_, _, d) -> propagate d merged) defs;
propagate body merged
| Phi (_, choices) -> List.iter (fun (_, ir) -> propagate ir merged) choices
| Jump (_, args) -> List.iter (fun a -> propagate a merged) args
| CondJump (c, _, _, args) -> propagate c merged; List.iter (fun a -> propagate a merged) args
| Halt e -> propagate e merged
| Var _ | Lit _ | Label _ -> ()
src/ir.ml
+72
View File
@@ -0,0 +1,72 @@
type id = int
let fresh_id =
let counter = ref 0 in
fun () -> incr counter; !counter
type fx =
| Pure
| MayDiverge
| Reads
| Writes
| Alloc
type effects = fx list
let string_of_fx = function
| Pure -> "pure"
| MayDiverge -> "div"
| Reads -> "read"
| Writes -> "write"
| Alloc -> "alloc"
let string_of_effects effs =
match effs with
| [] -> "pure"
| _ -> String.concat "," (List.map string_of_fx effs)
let merge_effects a b =
let merged = List.sort_uniq compare (a @ b) in
if List.length merged > 1 && List.mem Pure merged then
List.filter ((<>) Pure) merged
else merged
let has_effect eff effs = List.mem eff effs
type lit =
| LInt of int
| LBool of bool
type primop =
| PAdd | PSub | PMul | PDiv
| PEq | PNeq | PLt | PLe | PGt | PGe
| PAnd | POr
type ir_node =
| Var of string
| Lit of lit
| Lam of string * ir
| App of ir * ir
| Let of string * ir * ir
| If of ir * ir * ir
| Prim of primop * ir list
| Fix of (string * string * ir) list * ir
| Phi of string * (string * ir) list
| Jump of string * ir list
| CondJump of ir * string * string * ir list
| Label of string
| Halt of ir
and ir = {
node: ir_node;
id: id;
effects: effects ref;
}
let mk node =
{ node; id = fresh_id (); effects = ref [] }
let tag effs ir = ir.effects := effs; ir
let copy_node_with_uid ir node =
{ node; id = ir.id; effects = ref !(ir.effects) }
src/lower.ml
+57
View File
@@ -0,0 +1,57 @@
open Syntax
open Ir
open Effects
let primop_of_binop = function
| Add -> PAdd | Sub -> PSub | Mul -> PMul | Div -> PDiv
| Eq -> PEq | Neq -> PNeq | Lt -> PLt | Le -> PLe
| Gt -> PGt | Ge -> PGe | And -> PAnd | Or -> POr
let gensym =
let counter = ref 0 in
fun () -> incr counter; Printf.sprintf "v_%d" !counter
let rec lower (e : expr) : ir =
let ir = match e with
| Var x -> mk (Var x)
| Int n -> mk (Lit (LInt n))
| Bool b -> mk (Lit (LBool b))
| Binop (op, e1, e2) ->
let args = [lower e1; lower e2] in
mk (Prim (primop_of_binop op, args))
| If (c, t, f) ->
mk (If (lower c, lower t, lower f))
| Let (x, e1, e2) ->
mk (Let (x, lower e1, lower e2))
| LetRec (f, x, body, cont) ->
mk (Fix ([(f, x, lower body)], lower cont))
| Fun (x, body) ->
mk (Lam (x, lower body))
| App (e1, e2) ->
mk (App (lower e1, lower e2))
| Match (scrut, cases) ->
lower_match (lower scrut) cases
| Seq (e1, e2) ->
let x = gensym () in
mk (Let (x, lower e1, lower e2))
in
analyse ir;
ir
and lower_match scr cases =
match cases with
| [] -> mk (Lit (LInt 0))
| (pat, body) :: rest ->
let body_ir = lower body in
let fail = lower_match scr rest in
match pat with
| PWildcard -> body_ir
| PVar x -> mk (Let (x, scr, body_ir))
| PInt n ->
let cond = mk (Prim (PEq, [scr; mk (Lit (LInt n))])) in
analyse cond;
mk (If (cond, body_ir, fail))
| PBool b ->
let cond = mk (Prim (PEq, [scr; mk (Lit (LBool b))])) in
analyse cond;
mk (If (cond, body_ir, fail))
src/main.ml
+135
View File
@@ -0,0 +1,135 @@
open Ir
open Cfg
let dump_ir label ir =
Printf.printf "%s\n%s\n" label (string_of_ir_full ir)
let dump_dot label ir filename =
let cfg = flatten_to_blocks ir in
emit_dot cfg filename;
Printf.printf "dot: %s -> %s (%d blocks, %d edges)\n"
label filename (List.length cfg.blocks) (List.length cfg.edges)
let run_pipeline prog_name src =
Printf.printf "\npipeline: %s\n" prog_name;
Printf.printf "source:\n%s\n" src;
let ast = Parser.parse src in
Printf.printf "parse ok\n%!";
let ir0 = Lower.lower ast in
Printf.printf "lower ok, effects: %s\n%!"
(string_of_effects !(ir0.effects));
dump_ir "initial ir:" ir0;
dump_dot "initial" ir0 (prog_name ^ "_0_initial.dot");
let passes = [
Passes.const_fold_pass;
Passes.dce_pass;
Passes.beta_reduce_pass;
Passes.const_fold_pass;
Passes.dce_pass;
] in
let pass_results = Passes.run_passes passes ir0 in
List.iteri (fun i (name, ir) ->
let label = Printf.sprintf "pass %d (%s):" (i+1) name in
dump_ir label ir;
dump_dot name ir (Printf.sprintf "%s_%d_%s.dot" prog_name (i+1) name)
) pass_results;
let diffs = ref [] in
let prev = ref ir0 in
List.iter (fun (name, ir) ->
let d = Diff.structural_diff !prev ir in
if d <> [] then begin
Printf.printf "diff initial -> %s:\n%s\n" name (Diff.format_diff d);
diffs := (name, d) :: !diffs
end;
prev := ir
) pass_results;
let ir_after = snd (List.hd (List.rev pass_results)) in
Printf.printf "ssa transform:\n";
let ir_ssa = Ssa.ssa_transform ir_after in
dump_ir "ssa:" ir_ssa;
dump_dot "ssa" ir_ssa (prog_name ^ "_ssa.dot");
let ssa_diff = Diff.structural_diff ir_after ir_ssa in
if ssa_diff <> [] then
Printf.printf "ssa diff:\n%s\n" (Diff.format_diff ssa_diff);
Printf.printf "cps transform:\n";
let ir_cps = Cps.cps_transform ir_after in
dump_ir "cps raw:" ir_cps;
let ir_cps_opt = Cps.inline_conts ir_cps in
dump_ir "cps inlined:" ir_cps_opt;
dump_dot "cps" ir_cps_opt (prog_name ^ "_cps.dot");
let cps_diff = Diff.structural_diff ir_after ir_cps_opt in
if cps_diff <> [] then
Printf.printf "cps diff:\n%s\n" (Diff.format_diff cps_diff);
Printf.printf "ssa vs cps:\n";
let sc_diff = Diff.structural_diff ir_ssa ir_cps_opt in
if sc_diff <> [] then begin
Printf.printf "structural differences found:\n%s\n" (Diff.format_diff sc_diff);
Printf.printf "ssa makes data flow explicit through phi nodes and versioned variables. cps makes control flow explicit through continuations, sequentialising evaluation. the classic result (jfp 2003) shows ssa is equivalent to cps plus administrative reductions.\n"
end else
Printf.printf "ssa and cps produced identical structure.\n";
Printf.printf "dot files written:\n";
let files = Sys.readdir "." |> Array.to_list
|> List.filter (fun f -> Filename.check_suffix f ".dot")
|> List.sort String.compare
in
List.iter (fun f -> Printf.printf " %s\n" f) files;
Printf.printf "%!"
let () =
let test1 = {|
let x = 1 + 2 * 3 in
let y = x + 5 in
let z = y * 2 in
z
|} in
let test2 = {|
let x = 5 in
let y = x + 1 in
let unused = 10 * 20 in
let z = y * y in
z
|} in
let test3 = {|
let id = fun x -> x in
let f = id 42 in
let g = id true in
if g then f else 0
|} in
let test4 = {|
let rec fact = fun n ->
if n <= 1 then 1 else n * fact (n - 1)
in
fact 5
|} in
let test5 = {|
let a = (1 + 2) * 4 in
let b = if true then a else 0 in
let c = b + 1 in
c
|} in
let tests = [
("arithmetic", test1);
("deadcode", test2);
("beta", test3);
("factorial", test4);
("if_fold", test5);
] in
List.iter (fun (name, src) -> ignore (run_pipeline name src)) tests;
Printf.printf "done\n"
src/parser.ml
+277
View File
@@ -0,0 +1,277 @@
open Syntax
type token =
| TInt of int | TBool of bool
| TId of string
| TKLet | TKRec | TKIn | TKFun | TKIf | TKThen | TKElse | TKMatch | TKWith
| TLParen | TRParen | TArrow | TEq | TSemi | TPipe | TUnderscore
| TPlus | TMinus | TStar | TSlash
| TLt | TGt | TLe | TGe | TNeq
| TAnd | TOr
| TEnd
let string_of_token = function
| TInt n -> string_of_int n
| TBool b -> string_of_bool b
| TId s -> s
| TKLet -> "let" | TKRec -> "rec" | TKIn -> "in" | TKFun -> "fun"
| TKIf -> "if" | TKThen -> "then" | TKElse -> "else"
| TKMatch -> "match" | TKWith -> "with"
| TLParen -> "(" | TRParen -> ")" | TArrow -> "->" | TEq -> "="
| TSemi -> ";" | TPipe -> "|" | TUnderscore -> "_"
| TPlus -> "+" | TMinus -> "-" | TStar -> "*" | TSlash -> "/"
| TLt -> "<" | TGt -> ">" | TLe -> "<=" | TGe -> ">=" | TNeq -> "<>"
| TAnd -> "&&" | TOr -> "||"
| TEnd -> "<eof>"
let is_keyword = function
| "let" | "rec" | "in" | "fun" | "if" | "then" | "else"
| "match" | "with" | "true" | "false" -> true
| _ -> false
type lexer = {
src: string;
mutable pos: int;
}
let make_lexer src = { src; pos = 0 }
let peek l = if l.pos >= String.length l.src then '\x00' else l.src.[l.pos]
let advance l =
if l.pos < String.length l.src then (l.pos <- l.pos + 1; l.src.[l.pos - 1]) else '\x00'
let skip_whitespace l =
while peek l = ' ' || peek l = '\t' || peek l = '\n' || peek l = '\r' do
ignore (advance l)
done
let skip_line_comment l =
if peek l = '/' && l.pos + 1 < String.length l.src && l.src.[l.pos + 1] = '/' then
while peek l <> '\n' && peek l <> '\x00' do ignore (advance l) done
let lex l =
skip_whitespace l;
skip_line_comment l;
skip_whitespace l;
if l.pos >= String.length l.src then TEnd
else
let c = peek l in
match c with
| '(' -> ignore (advance l); TLParen
| ')' -> ignore (advance l); TRParen
| '+' -> ignore (advance l); TPlus
| '*' -> ignore (advance l); TStar
| '/' -> ignore (advance l); TSlash
| ';' -> ignore (advance l); TSemi
| '_' -> ignore (advance l); TUnderscore
| '-' ->
ignore (advance l);
if peek l = '>' then (ignore (advance l); TArrow) else TMinus
| '=' ->
ignore (advance l); TEq
| '<' ->
ignore (advance l);
if peek l = '=' then (ignore (advance l); TLe)
else if peek l = '>' then (ignore (advance l); TNeq)
else TLt
| '>' ->
ignore (advance l);
if peek l = '=' then (ignore (advance l); TGe) else TGt
| '&' ->
ignore (advance l);
if peek l = '&' then (ignore (advance l); TAnd)
else failwith "expected && after &"
| '|' ->
ignore (advance l);
if peek l = '|' then (ignore (advance l); TOr)
else TPipe
| '0'..'9' ->
let n = ref 0 in
while peek l >= '0' && peek l <= '9' do
n := !n * 10 + (Char.code (advance l) - Char.code '0')
done;
TInt !n
| 'a'..'z' | 'A'..'Z' ->
let buf = Buffer.create 16 in
while (peek l >= 'a' && peek l <= 'z') || (peek l >= 'A' && peek l <= 'Z')
|| (peek l >= '0' && peek l <= '9') || peek l = '_' || peek l = '\'' do
Buffer.add_char buf (advance l)
done;
let id = Buffer.contents buf in
begin match id with
| "let" -> TKLet | "rec" -> TKRec | "in" -> TKIn
| "fun" -> TKFun
| "if" -> TKIf | "then" -> TKThen | "else" -> TKElse
| "match" -> TKMatch | "with" -> TKWith
| "true" -> TBool true | "false" -> TBool false
| _ -> TId id
end
| _ -> failwith (Printf.sprintf "unexpected character: %c" c)
type parser = {
lexer: lexer;
mutable cur: token;
}
let make_parser src =
let l = make_lexer src in
{ lexer = l; cur = lex l }
let advance p = p.cur <- lex p.lexer
let expect p tok =
if p.cur = tok then advance p
else failwith (Printf.sprintf "expected %s, got %s"
(string_of_token tok) (string_of_token p.cur))
let rec parse_expr p = parse_sequence p
and parse_sequence p =
let e = parse_binop p in
if p.cur = TSemi then (advance p; let e2 = parse_sequence p in Seq (e, e2))
else e
and parse_binop p = parse_and p
and parse_and p =
let e = parse_comparison p in
if p.cur = TAnd then (advance p; Binop (And, e, parse_and p))
else e
and parse_or p =
let e = parse_and p in
if p.cur = TOr then (advance p; Binop (Or, e, parse_or p))
else e
and parse_comparison p =
let e = parse_add p in
match p.cur with
| TEq -> advance p; Binop (Eq, e, parse_comparison p)
| TNeq -> advance p; Binop (Neq, e, parse_comparison p)
| TLt -> advance p; Binop (Lt, e, parse_comparison p)
| TGt -> advance p; Binop (Gt, e, parse_comparison p)
| TLe -> advance p; Binop (Le, e, parse_comparison p)
| TGe -> advance p; Binop (Ge, e, parse_comparison p)
| _ -> e
and parse_add p =
let e = parse_mul p in
let rec loop acc = match p.cur with
| TPlus -> advance p; loop (Binop (Add, acc, parse_mul p))
| TMinus -> advance p; loop (Binop (Sub, acc, parse_mul p))
| _ -> acc
in loop e
and parse_mul p =
let e = parse_apply p in
let rec loop acc = match p.cur with
| TStar -> advance p; loop (Binop (Mul, acc, parse_apply p))
| TSlash -> advance p; loop (Binop (Div, acc, parse_apply p))
| _ -> acc
in loop e
and parse_apply p =
let e = parse_simple p in
let rec loop acc = match p.cur with
| TInt _ | TBool _ | TId _ | TLParen | TKFun | TKLet | TKIf | TKMatch ->
loop (App (acc, parse_simple p))
| _ -> acc
in loop e
and parse_simple p =
match p.cur with
| TInt n -> advance p; Int n
| TBool b -> advance p; Bool b
| TId s -> advance p; Var s
| TLParen ->
advance p;
let e = parse_expr p in
expect p TRParen;
e
| TKFun ->
advance p;
begin match p.cur with
| TId x -> advance p; expect p TArrow; Fun (x, parse_expr p)
| _ -> failwith "expected parameter name after fun"
end
| TKIf ->
advance p;
let cond = parse_expr p in
expect p TKThen;
let then_br = parse_expr p in
expect p TKElse;
let else_br = parse_expr p in
If (cond, then_br, else_br)
| TKLet ->
advance p;
let is_rec = p.cur = TKRec in
if is_rec then advance p;
begin match p.cur with
| TId x ->
advance p;
if is_rec then begin
match p.cur with
| TId param -> advance p; expect p TEq;
let rhs = parse_expr p in
let cont = parse_continuation p in
LetRec (x, param, rhs, cont)
| _ -> expect p TEq;
let rhs = parse_expr p in
let cont = parse_continuation p in
LetRec (x, "arg", rhs, cont)
end else begin
expect p TEq;
let rhs = parse_expr p in
let cont = parse_continuation p in
Let (x, rhs, cont)
end
| _ -> failwith "expected identifier after let"
end
| TKMatch ->
advance p;
let scrut = parse_expr p in
expect p TKWith;
let cases = parse_cases p in
Match (scrut, cases)
| _ -> failwith (Printf.sprintf "unexpected token: %s" (string_of_token p.cur))
and parse_continuation p =
if p.cur = TKIn then (advance p; parse_expr p)
else failwith (Printf.sprintf "expected 'in' after let binding, got %s" (string_of_token p.cur))
and parse_cases p =
let rec loop acc =
let leading_pipe = if p.cur = TPipe then (advance p; true) else true in
if not leading_pipe then acc
else begin
let pat = parse_pattern p in
expect p TArrow;
let body = parse_expr p in
let acc' = (pat, body) :: acc in
if p.cur = TPipe then loop acc'
else acc'
end
in
if p.cur = TPipe then loop [] |> List.rev
else
let pat = parse_pattern p in
expect p TArrow;
let b = parse_expr p in
if p.cur = TPipe then ((pat,b) :: parse_cases p |> List.rev)
else [(pat,b)]
and parse_pattern p =
match p.cur with
| TUnderscore -> advance p; PWildcard
| TInt n -> advance p; PInt n
| TBool b -> advance p; PBool b
| TId s -> advance p; PVar s
| _ -> failwith (Printf.sprintf "expected pattern, got %s" (string_of_token p.cur))
let parse src =
let p = make_parser src in
let e = parse_expr p in
if p.cur <> TEnd then
failwith (Printf.sprintf "trailing tokens starting with %s" (string_of_token p.cur));
e
src/passes.ml
+192
View File
@@ -0,0 +1,192 @@
open Ir
open Effects
type pass = {
name: string;
run: ir -> ir;
}
let run_passes (passes : pass list) (ir : ir) : (string * ir) list =
let rec loop acc ir = function
| [] -> List.rev acc
| p :: rest ->
let result = p.run ir in
loop ((p.name, result) :: acc) result rest
in
loop [] ir passes
let const_fold_pass : pass =
let rec fold ir =
let n = match ir.node with
| Prim (PAdd, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LInt (a + b)))
| Prim (PSub, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LInt (a - b)))
| Prim (PMul, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LInt (a * b)))
| Prim (PDiv, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) when b <> 0 ->
Some (Lit (LInt (a / b)))
| Prim (PEq, [{node=Lit a;_}; {node=Lit b;_}]) ->
Some (Lit (LBool (a = b)))
| Prim (PNeq, [{node=Lit a;_}; {node=Lit b;_}]) ->
Some (Lit (LBool (a <> b)))
| Prim (PLt, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LBool (a < b)))
| Prim (PLe, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LBool (a <= b)))
| Prim (PGt, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LBool (a > b)))
| Prim (PGe, [{node=Lit(LInt a);_}; {node=Lit(LInt b);_}]) ->
Some (Lit (LBool (a >= b)))
| Prim (PAnd, [{node=Lit(LBool a);_}; {node=Lit(LBool b);_}]) ->
Some (Lit (LBool (a && b)))
| Prim (POr, [{node=Lit(LBool a);_}; {node=Lit(LBool b);_}]) ->
Some (Lit (LBool (a || b)))
| If ({node=Lit(LBool true);_}, t, _) ->
Some t.node
| If ({node=Lit(LBool false);_}, _, f) ->
Some f.node
| App ({node=Lam(x,body);_}, arg) ->
Some (Let (x, arg, body))
| _ -> None
in
match n with
| Some node ->
let ir' = copy_node_with_uid ir node in
analyse ir'; ir'
| None -> map_children fold ir
and map_children f ir =
let n = match ir.node with
| Var _ | Lit _ | Label _ -> ir.node
| Lam (x, body) -> Lam (x, f body)
| App (fn, arg) -> App (f fn, f arg)
| Let (x, rhs, body) -> Let (x, f rhs, f body)
| If (c, t, fl) -> If (f c, f t, f fl)
| Prim (op, args) -> Prim (op, List.map f args)
| Fix (defs, body) -> Fix (List.map (fun (a,b,d) -> (a,b,f d)) defs, f body)
| Phi (x, choices) -> Phi (x, List.map (fun (l,ir) -> (l, f ir)) choices)
| Jump (l, args) -> Jump (l, List.map f args)
| CondJump (c, l1, l2, args) -> CondJump (f c, l1, l2, List.map f args)
| Halt e -> Halt (f e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
in
{ name = "const-fold"; run = fold }
let dce_pass : pass =
let used_vars ir =
let used = ref [] in
let rec go ir = match ir.node with
| Var x -> used := x :: !used
| Lit _ | Label _ -> ()
| Lam (x, body) -> go body; used := x :: !used
| App (f, a) -> go f; go a
| Let (x, rhs, body) -> go rhs; go body; used := x :: !used
| If (c, t, f) -> go c; go t; go f
| Prim (_, args) -> List.iter go args
| Fix (defs, body) ->
List.iter (fun (f, x, d) -> go d; used := f :: !used; used := x :: !used) defs;
go body
| Phi (x, choices) -> used := x :: !used; List.iter (fun (_, ir) -> go ir) choices
| Jump (_, args) -> List.iter go args
| CondJump (c, _, _, args) -> go c; List.iter go args
| Halt e -> go e
in
go ir; !used
in
let rec eliminate ir =
let used = used_vars ir in
let n = match ir.node with
| Let (x, _, body) when not (List.mem x used) -> body.node
| _ -> ir.node
in
let ir' = copy_node_with_uid ir n in
map_children eliminate ir'
and map_children f ir =
let n = match ir.node with
| Var _ | Lit _ | Label _ -> ir.node
| Lam (x, body) -> Lam (x, f body)
| App (fn, arg) -> App (f fn, f arg)
| Let (x, rhs, body) -> Let (x, f rhs, f body)
| If (c, t, fl) -> If (f c, f t, f fl)
| Prim (op, args) -> Prim (op, List.map f args)
| Fix (defs, body) -> Fix (List.map (fun (a,b,d) -> (a,b,f d)) defs, f body)
| Phi (x, choices) -> Phi (x, List.map (fun (l,ir) -> (l, f ir)) choices)
| Jump (l, args) -> Jump (l, List.map f args)
| CondJump (c, l1, l2, args) -> CondJump (f c, l1, l2, List.map f args)
| Halt e -> Halt (f e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
in
{ name = "dead-code-elim"; run = eliminate }
let beta_reduce_pass : pass =
let rec reduce ir =
let n = match ir.node with
| App ({node=Lam(x,body);_}, arg) when is_value arg ->
(subst x arg body).node
| Let (x, rhs, body) when is_value rhs ->
(subst x rhs body).node
| _ -> ir.node
in
let ir' = copy_node_with_uid ir n in
map_children reduce ir'
and is_value ir = match ir.node with
| Lit _ | Lam _ -> true
| Var _ -> true
| _ -> false
and subst x v ir =
let n = match ir.node with
| Var y when y = x -> v.node
| Var _ -> ir.node
| Lit _ | Label _ -> ir.node
| Lam (y, body) when y <> x -> Lam (y, subst x v body)
| Lam _ -> ir.node
| App (f, a) -> App (subst x v f, subst x v a)
| Let (y, rhs, body) when y <> x -> Let (y, subst x v rhs, subst x v body)
| Let _ -> ir.node
| If (c, t, f) -> If (subst x v c, subst x v t, subst x v f)
| Prim (op, args) -> Prim (op, List.map (subst x v) args)
| Fix (defs, body) ->
let defs' = List.map (fun (f,y,d) ->
if f = x || y = x then (f, y, d)
else (f, y, subst x v d)
) defs in
Fix (defs', subst x v body)
| Phi (y, choices) ->
Phi (y, List.map (fun (l,ir) -> (l, subst x v ir)) choices)
| Jump (l, args) -> Jump (l, List.map (subst x v) args)
| CondJump (c, l1, l2, args) ->
CondJump (subst x v c, l1, l2, List.map (subst x v) args)
| Halt e -> Halt (subst x v e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
and map_children f ir =
let n = match ir.node with
| Var _ | Lit _ | Label _ -> ir.node
| Lam (x, body) -> Lam (x, f body)
| App (fn, arg) -> App (f fn, f arg)
| Let (x, rhs, body) -> Let (x, f rhs, f body)
| If (c, t, fl) -> If (f c, f t, f fl)
| Prim (op, args) -> Prim (op, List.map f args)
| Fix (defs, body) -> Fix (List.map (fun (a,b,d) -> (a,b,f d)) defs, f body)
| Phi (x, choices) -> Phi (x, List.map (fun (l,ir) -> (l, f ir)) choices)
| Jump (l, args) -> Jump (l, List.map f args)
| CondJump (c, l1, l2, args) -> CondJump (f c, l1, l2, List.map f args)
| Halt e -> Halt (f e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
in
{ name = "beta-reduce"; run = reduce }
let default_passes = [
const_fold_pass;
dce_pass;
beta_reduce_pass;
const_fold_pass;
dce_pass;
]
src/ssa.ml
+81
View File
@@ -0,0 +1,81 @@
open Ir
open Effects
let gensym =
let c = ref 0 in
fun prefix -> incr c; Printf.sprintf "%s%d" prefix !c
let versioned x v = Printf.sprintf "%s_%d" x v
let ssa_transform ir =
let versions = Hashtbl.create 16 in
let get_version x =
match Hashtbl.find_opt versions x with
| Some v -> v
| None -> 0
in
let bump x =
let v = get_version x + 1 in
Hashtbl.replace versions x v;
versioned x v
in
let rec rename ir =
let n = match ir.node with
| Var x ->
let v = get_version x in
Var (versioned x v)
| Lit _ -> ir.node
| Lam (x, body) ->
let vx = bump x in
Lam (vx, rename body)
| App (f, a) -> App (rename f, rename a)
| Let (x, rhs, body) ->
let vx = bump x in
Let (vx, rename rhs, rename body)
| If (c, t, f) ->
let cond = rename c in
let saved_versions = Hashtbl.copy versions in
let t_ir = rename t in
let t_versions = Hashtbl.copy versions in
Hashtbl.clear versions;
Hashtbl.iter (fun k v -> Hashtbl.replace versions k v) saved_versions;
let f_ir = rename f in
let join_phis = ref [] in
Hashtbl.iter (fun x fv ->
let tv = Hashtbl.find_opt t_versions x in
match tv with
| Some tv when tv <> fv ->
let fresh = bump x in
join_phis := (fresh, [("then", mk (Var (versioned x tv)));
("else", mk (Var (versioned x fv)))]) :: !join_phis
| _ -> ()
) versions;
if !join_phis = [] then If (cond, t_ir, f_ir)
else begin
let body = ref f_ir in
List.iter (fun (fresh, choices) ->
body := mk (Let (fresh, mk (Phi (fresh, choices)), !body))
) !join_phis;
If (cond, t_ir, !body)
end
| Prim (op, args) -> Prim (op, List.map rename args)
| Fix (defs, body) ->
let defs' = List.map (fun (f, x, d) ->
let vf = bump f in
let vx = bump x in
(vf, vx, rename d)
) defs in
Fix (defs', rename body)
| Phi (x, choices) ->
let vx = bump x in
Phi (vx, List.map (fun (l, ir) -> (l, rename ir)) choices)
| Jump (l, args) -> Jump (l, List.map rename args)
| CondJump (c, l1, l2, args) ->
CondJump (rename c, l1, l2, List.map rename args)
| Label _ -> ir.node
| Halt e -> Halt (rename e)
in
let ir' = copy_node_with_uid ir n in
analyse ir'; ir'
in
rename ir
src/syntax.ml
+25
View File
@@ -0,0 +1,25 @@
type binop =
| Add | Sub | Mul | Div
| Eq | Neq | Lt | Le | Gt | Ge
| And | Or
type pattern =
| PWildcard
| PVar of string
| PInt of int
| PBool of bool
type expr =
| Var of string
| Int of int
| Bool of bool
| Binop of binop * expr * expr
| If of expr * expr * expr
| Let of string * expr * expr
| LetRec of string * string * expr * expr
| Fun of string * expr
| App of expr * expr
| Match of expr * (pattern * expr) list
| Seq of expr * expr
type prog = expr