81 lines
2.3 KiB
OCaml
81 lines
2.3 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* Heptagon *)
|
|
(* *)
|
|
(* Author : Marc Pouzet *)
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
(* control optimisation *)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Minils
|
|
open Ident
|
|
open Misc
|
|
|
|
let var_from_name map x =
|
|
begin try
|
|
Env.find x map
|
|
with
|
|
_ -> assert false
|
|
end
|
|
|
|
let rec find c = function
|
|
| [] -> raise Not_found
|
|
| (c1, s1) :: h ->
|
|
if c = c1 then s1, h else let s, h = find c h in s, (c1, s1) :: h
|
|
|
|
let rec control map ck s =
|
|
match ck with
|
|
| Cbase | Cvar { contents = Cindex _ } -> s
|
|
| Cvar { contents = Clink ck } -> control map ck s
|
|
| Con(ck, c, n) ->
|
|
let e = var_from_name map n in
|
|
control map ck (Obc.Case(Obc.Lhs e, [(c, s)]))
|
|
|
|
let rec simplify act =
|
|
match act with
|
|
| Obc.Assgn (lhs, e) ->
|
|
(match e with
|
|
| Obc.Lhs l when l = lhs -> Obc.Nothing
|
|
| _ -> act
|
|
)
|
|
| Obc.Case(lhs, h) ->
|
|
(match simplify_handlers h with
|
|
| [] -> Obc.Nothing
|
|
| h -> Obc.Case(lhs, h)
|
|
)
|
|
| _ -> act
|
|
|
|
and simplify_handlers = function
|
|
| [] -> []
|
|
| (n,a)::h ->
|
|
let h = simplify_handlers h in
|
|
(match simplify a with
|
|
| Obc.Nothing -> h
|
|
| a -> (n,a)::h
|
|
)
|
|
|
|
let rec join s1 s2 =
|
|
match simplify s1, simplify s2 with
|
|
| Obc.Case(Obc.Lhs(n), h1), Obc.Case(Obc.Lhs(m), h2) when n = m ->
|
|
Obc.Case(Obc.Lhs(n), joinhandlers h1 h2)
|
|
| s1, Obc.Nothing -> s1
|
|
| Obc.Nothing, s2 -> s2
|
|
| s1, Obc.Comp(s2, s3) -> Obc.Comp(join s1 s2, s3)
|
|
| s1, s2 -> Obc.Comp(s1, s2)
|
|
|
|
and joinhandlers h1 h2 =
|
|
match h1 with
|
|
| [] -> h2
|
|
| (c1, s1) :: h1' ->
|
|
let s1', h2' =
|
|
try let s2, h2'' = find c1 h2 in join s1 s2, h2''
|
|
with Not_found -> simplify s1, h2 in
|
|
(c1, s1') :: joinhandlers h1' h2'
|
|
|
|
let rec joinlist = function
|
|
| [] -> Obc.Nothing
|
|
| s :: l -> join s (joinlist l)
|