initial commit

.gitignore

@@ -0,0 +1,3 @@
+_build/
+*.install
+*.merlin

README.md

@@ -0,0 +1,3 @@
+# retroid
+
+small compiler pipeline for a restricted OCaml language

src/cfg.ml

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,3 @@
+(executable
+ (name main)
+ (modules syntax ir effects parser lower ssa cps passes cfg diff main))

src/effects.ml

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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