diff options
| -rw-r--r-- | bak.ml | 132 | ||||
| -rw-r--r-- | lo.ml | 221 |
2 files changed, 353 insertions, 0 deletions
diff --git a/bak.ml b/bak.ml new file mode 100644 index 0000000..cd1aff2 --- /dev/null +++ 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 new file mode 100644 index 0000000..84c874d --- /dev/null +++ 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 |