initial commit
This commit is contained in:
commit
59db3dd956
2 changed files with 353 additions and 0 deletions
132
bak.ml
Normal file
132
bak.ml
Normal file
|
@ -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
|
Loading…
Add table
Add a link
Reference in a new issue