commit 59db3dd956350b6bb0d8dded955e8ad16a2a6b8b
Author: Quentin Carbonneaux <quentin.carbonneaux@yale.edu>
Date: Fri, 19 Dec 2014 08:57:56 -0500
initial commit
Diffstat:
| A | bak.ml | | | 132 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | lo.ml | | | 221 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 353 insertions(+), 0 deletions(-)
diff --git a/bak.ml b/bak.ml
@@ -0,0 +1,132 @@
+type id = int
+type ty =
+ | TInt of bool * int
+ | TArr of int * ty
+ | TPtr of ty
+ | TVoid
+type con = CInt of int
+type cnd = Ge | Le | Gt | Lt | Ne | Eq
+type ins =
+ | IAlloc of ty
+ | IMem of id
+ | ISto of id * id
+ | IAdd of id * id
+ | ISub of id * id
+ | ICon of ty * con
+ | IBr of id * cnd * id * id
+ | IJmp of id
+ | IPhi of ty * id * id
+
+let isint = function TInt _ -> true | _ -> false
+let isbranch = function IBr _ | IJmp _ -> true | _ -> false
+
+exception Type of string
+let tychk blk =
+ let typs = Array.make (Array.length blk) TVoid in
+ let blks = ref [] in
+ let jmp src dst =
+ let rec f = function
+ | (blk, srcs) :: tl when blk = dst ->
+ (blk, src :: srcs) :: tl
+ | b :: tl when fst b < dst -> b :: f tl
+ | l ->
+ let srcs =
+ if dst = 0 then [src] else
+ if isbranch blk.(dst-1)
+ then [src] else [dst-1; src] in
+ (dst, srcs) :: l in
+ blks := f !blks in
+ let f i = (* do easy type checks *)
+ let chn n =
+ if n >= i || n < 0 then
+ raise (Type "broken data dependency") in
+ function
+ | IPhi (ty, _, _) ->
+ if ty = TVoid then
+ raise (Type "invalid void phi");
+ typs.(i) <- ty
+ | ICon (ty, _) -> typs.(i) <- ty
+ | IAlloc ty ->
+ if ty = TVoid then
+ raise (Type "invalid void alloc");
+ typs.(i) <- TPtr ty
+ | IMem n ->
+ chn n;
+ (match typs.(n) with
+ | TPtr ty -> typs.(i) <- ty
+ | _ -> raise (Type "invalid dereference")
+ )
+ | ISto (a, b) ->
+ chn a; chn b;
+ if typs.(a) <> TPtr typs.(b) then
+ raise (Type "invalid store")
+ | IAdd (a, b) ->
+ chn a; chn b;
+ if not (isint typs.(b)) then
+ raise (Type "second add operand not integral");
+ (match typs.(a) with
+ | (TPtr _) as t -> typs.(i) <- t
+ | (TInt _) as t ->
+ if t <> typs.(b) then
+ raise (Type "invalid heterogeneous addition");
+ typs.(i) <- t
+ | _ -> raise (Type "invalid type for addition")
+ )
+ | ISub (a, b) ->
+ chn a; chn b;
+ (match typs.(a), typs.(b) with
+ | (TPtr _ as ta), (TPtr _ as tb) ->
+ if ta <> tb then
+ raise (Type "substracted pointers have different types");
+ typs.(i) <- TInt (true, 64)
+ | (TInt _ as ta), (TInt _ as tb) ->
+ if ta <> tb then
+ raise (Type "invalid heterogeneous substraction");
+ typs.(i) <- ta
+ | _ -> raise (Type "invalid type for substraction")
+ )
+ | IBr (_, _, _, dst) -> jmp i dst; jmp i (i+1)
+ | IJmp dst -> jmp i dst in
+ Array.iteri f blk;
+ let f = function (* check types at phi nodes *)
+ | IPhi (_, a, b) ->
+ if typs.(a) <> typs.(b) then
+ raise (Type "ill-typed phi node")
+ | _ -> () in
+ Array.iter f blk;
+ let bbase i =
+ let rec f base = function
+ | [] -> base
+ | (b, _) :: _ when b > i -> base
+ | (b, _) :: tl -> f b tl in
+ f 0 !blks in
+ let f i = function (* check validity of ssa *)
+ | IPhi (_, a, b) ->
+ let callers =
+ List.map bbase (List.assoc (bbase i) !blks) in
+ let ba = bbase a and bb = bbase b in
+ if ba = bb
+ || not (List.mem ba callers)
+ || not (List.mem bb callers)
+ then
+ raise (Type "invalid phi node");
+ | IAdd (a, b) | ISub (a, b) | ISto (a, b) | IBr (a, _, b, _) ->
+ let bi = bbase i in
+ if bbase a <> bi || bbase b <> bi then
+ raise (Type "operands of non-phy not in current block")
+ | IMem a ->
+ if bbase a <> bbase i then
+ raise (Type "operands of non-phy not in current block")
+ | IJmp _ | ICon _ | IAlloc _ -> () in
+ Array.iteri f blk
+
+ (* tests *)
+let _ =
+ let int = TInt (true, 32) in
+ let p0 = [|
+ (* 0 *) ICon (int, CInt 1);
+ (* 1 *) ICon (int, CInt 42);
+ (* 2 *) IPhi (int, 0, 2);
+ (* 3 *) IAdd (1, 2);
+ (* 4 *) IJmp 1
+ |] in tychk p0
diff --git a/lo.ml b/lo.ml
@@ -0,0 +1,221 @@
+type id = int
+module ISet = Set.Make
+ (struct
+ type t = id
+ let compare = compare
+ end)
+
+type unop = Not
+type binop =
+ | Add | Sub
+ | Le | Ge | Lt | Gt | Eq | Ne
+
+type phi = { pjmp: id; pvar: int }
+
+type instr =
+ | INop
+ | ICon of int
+ | IUop of unop * id
+ | IBop of id * binop * id
+ | IBrz of id * id * id
+ | IJmp of id
+ | IPhi of phi list
+
+(* Phi nodes must be at the join of branches
+ in the control flow graph, if n branches
+ join, the phi node must have n elements in
+ its list that indicate the value to merge
+ from each of the branches.
+ The id given in each of
+*)
+
+type prog = instr array
+
+
+(* Here, we analyze a program backwards to
+ compute the liveness of all variables.
+ We assume that all phi nodes are placed
+ correctly.
+*)
+let liveness p =
+ (* The idea is now to reach a fixpoint
+ by applying the same backward liveness
+ propagation a sufficient number of
+ times.
+ The [changed] variable will tell us
+ when we reached the fixpoint, it is
+ reset to false at each iteration.
+ *)
+ let changed = ref true in
+ let liveout = Array.make (Array.length p) ISet.empty in
+
+ let setlive v l =
+ (* Extend the liveness of v to l. *)
+ if not (ISet.mem v liveout.(l)) then begin
+ changed := true;
+ liveout.(l) <- ISet.add v liveout.(l);
+ end in
+
+ let succs i =
+ (* Retreive the successor nodes of i. *)
+ if i = Array.length p -1 then [] else
+ match p.(i) with
+ | IBrz (_, i1, i2) -> [i1; i2]
+ | IJmp i1 -> [i1]
+ | _ -> [i+1] in
+
+ let gen i = ISet.of_list
+ (* Get the Gen set of i. *)
+ begin match p.(i) with
+ | IUop (_, i1) -> [i1]
+ | IBop (i1, _, i2) -> [i1; i2]
+ | IPhi l ->
+ List.iter (fun {pjmp; pvar} ->
+ setlive pvar pjmp
+ ) l; []
+ | _ -> []
+ end in
+
+ let livein i =
+ (* Get the live In set of i. *)
+ let s = liveout.(i) in
+ let s = ISet.union s (gen i) in
+ ISet.remove i s in
+
+ (* The fixpoint computation. *)
+ while !changed do
+ changed := false;
+ for i = Array.length p -1 downto 0 do
+ (* Collect live Ins of all successor blocks. *)
+ let live = List.fold_left (fun live i' ->
+ ISet.union live (livein i')
+ ) ISet.empty (succs i) in
+ ISet.iter (fun i' ->
+ setlive i' i
+ ) live
+ done
+ done;
+ liveout
+
+
+
+
+(*
+
+ Non-reducible control flow graph, these
+ cfgs are problematic when implementing
+ the naive backwards liveness analysis.
+
+ +--i
+ | |
+ y x--+
+ | | |
+ +--a |
+ | |
+ b--+
+ |
+ c
+
+*)
+
+
+
+
+
+
+
+
+
+(* Testing. *)
+
+let parse src =
+ let blocks = Hashtbl.create 31 in
+ let src = List.mapi (fun idx l ->
+ let l = String.trim l in
+ try
+ let il = String.index l ':' in
+ let lbl = String.sub l 0 il in
+ Hashtbl.add blocks lbl idx;
+ String.sub l (il+1)
+ (String.length l -(il+1)) ^ " "
+ with Not_found -> l ^ " "
+ ) src in
+ let p = Array.make (List.length src) INop in
+ List.iteri (fun idx l ->
+ let fail s =
+ failwith
+ (Printf.sprintf "line %d: %s" (idx+1) s) in
+ let tok =
+ let p = ref 0 in fun () ->
+ try
+ while l.[!p] = ' ' do incr p done;
+ let p0 = !p in
+ while l.[!p] <> ' ' do incr p done;
+ String.sub l p0 (!p - p0)
+ with _ -> fail "token expected" in
+ let id () =
+ let v = tok () in
+ try Hashtbl.find blocks v
+ with _ -> fail ("unknown variable " ^ v) in
+ let instr =
+ if l = " " then INop else
+ let bop o =
+ let i1 = id () in
+ let i2 = id () in
+ IBop (i1, o, i2) in
+ match tok () with
+ | "con" -> ICon (int_of_string (tok ()))
+ | "not" -> IUop (Not, id ())
+ | "add" -> bop Add
+ | "sub" -> bop Sub
+ | "cle" -> bop Le
+ | "cge" -> bop Ge
+ | "clt" -> bop Lt
+ | "cgt" -> bop Gt
+ | "ceq" -> bop Eq
+ | "cne" -> bop Ne
+ | "phi" ->
+ let exp t =
+ let t' = tok () in
+ if t' <> t then
+ fail ("unexpected " ^ t') in
+ let rec f () =
+ match tok () with
+ | "[" ->
+ let pjmp = id () in
+ let pvar = id () in
+ exp "]";
+ {pjmp; pvar} :: f ()
+ | "." -> []
+ | t -> fail ("unexpected " ^ t) in
+ IPhi (f ())
+ | "brz" ->
+ let v = id () in
+ let bz = id () in
+ let bn = id () in
+ IBrz (v, bz, bn)
+ | "jmp" -> IJmp (id ())
+ | i -> fail ("invalid " ^ i) in
+ p.(idx) <- instr
+ ) src;
+ p
+
+let t_fact = parse
+ [ "start:"
+ ; " ni: con 1234"
+ ; " k1: con 1"
+ ; "loop:"
+ ; " n0: phi [ back n1 ] [ k1 ni ] ."
+ ; " n1: sub n0 k1"
+ ; "back: brz n1 pend loop"
+ ; "pend:"
+ ]
+
+let _ =
+ let open Printf in
+ let s = liveness t_fact in
+ for i = 0 to Array.length s-1 do
+ printf "%04d:" i;
+ ISet.iter (printf " %04d") s.(i);
+ printf "\n";
+ done
