Permalink
Browse files

Merge branch 'master' of github.com:raphael-proust/cps-ssa

  • Loading branch information...
2 parents 68a59a4 + 924ea42 commit 3ccefb26a94083c85b146bc165f7dd89f0006e29 @raphael-proust committed Aug 24, 2012
Showing with 119 additions and 120 deletions.
  1. +15 −15 src/CPS_gvn.ml
  2. +53 −53 src/CPS_gvn_conversions.ml
  3. +34 −34 src/CPS_gvn_terms.ml
  4. +6 −6 src/env.ml
  5. +6 −7 src/env.mli
  6. +5 −5 src/prim.ml
View
@@ -43,14 +43,14 @@ let trivial_bind_removal g =
(*FIXME: sometimes require re-ranking*)
let (subs, _, revbs) =
List.fold_left (* this fold is over the (rank, bindings) list *)
- (fun (subs, env, bsacc) (r, bs) ->
- let (subs, env, bs) =
+ (fun (subs, e, bsacc) (r, bs) ->
+ let (subs, e, bs) =
List.fold_left (* this fold is over the bindings *)
- (fun (subs, env, bs) (x,v) ->
+ (fun (subs, e, bs) (x,v) ->
let open Prim in
match v with
- | VVar _ -> ((x, v) :: subs, env, bs)
- | VRead _ -> (subs, env, (x,v) :: bs)
+ | VVar _ -> ((x, v) :: subs, e, bs)
+ | VRead _ -> (subs, e, (x,v) :: bs)
| VConst _
| VNull | VUndef | VDummy _ | VZero
| VStruct _
@@ -60,18 +60,18 @@ let trivial_bind_removal g =
| VCast _
| VShl _ | VLShr _ | VAShr _ ->
try
- let y = Env.teg ~env v in
- ((x, VVar y) :: subs, env, bs)
+ let y = Env.teg ~e v in
+ ((x, VVar y) :: subs, e, bs)
(* because we substitute directly here, there is no need
* for fixpointing this function *)
with
| Not_found ->
- (subs, Env.add1 ~env x v, (x,v) :: bs)
+ (subs, Env.add1 ~e x v, (x,v) :: bs)
)
- (subs, env, [])
+ (subs, e, [])
bs
in
- (subs, env, (r, bs) :: bsacc)
+ (subs, e, (r, bs) :: bsacc)
)
([], Env.empty, [])
bs
@@ -98,16 +98,16 @@ let movable rk binds =
try
let (_, bs, revbinds) =
List.fold_left (*TODO: optimisation*)
- (fun (env, bs, binds) ((rrk, bbs) as rbs) ->
+ (fun (e, bs, binds) ((rrk, bbs) as rbs) ->
if rk < rrk then begin (*before rank*)
assert (bs = []);
- (Env.add ~env bbs, bs, rbs :: binds)
+ (Env.add ~e bbs, bs, rbs :: binds)
end else if rk = rrk then begin (*on the rank*)
assert (bs = []);
let (movables, nonmovables) =
List.partition
(fun (_, v) ->
- List.for_all (Env.hasnt ~env) (Prim.vars_of_value v)
+ List.for_all (Env.hasnt ~e) (Prim.vars_of_value v)
)
bbs
in
@@ -119,8 +119,8 @@ let movable rk binds =
in
(Env.empty, movables, binds)
end else begin (*after the rank*)
- assert (env = Env.empty);
- (env, bs, rbs :: binds)
+ assert (e = Env.empty);
+ (e, bs, rbs :: binds)
end
)
(Env.empty, [], binds)
View
@@ -184,109 +184,109 @@ let rank g =
(*TODO: clean up environments (based on scope) to improve performance*)
- let rank_value env v =
+ let rank_value e v =
(* the succ of the maximum of the rank of all the variables used in v *)
- succ (List.fold_left max 0 (List.map (Env.get ~env) (Prim.vars_of_value v)))
+ succ (List.fold_left max 0 (List.map (Env.get ~e) (Prim.vars_of_value v)))
in
- let rank_values env vs = List.map (rank_value env) vs in
+ let rank_values e vs = List.map (rank_value e) vs in
- let update_callenv env k rs =
+ let update_callenv e k rs =
(* update or add the rank of the k's call-site arguments*)
- Env.add1 ~env k (
- if Env.has ~env k then
- List.map2 max rs (Env.get ~env k)
+ Env.add1 ~e k (
+ if Env.has ~e k then
+ List.map2 max rs (Env.get ~e k)
else
rs
)
in
- let rec rank_g env cenv = function
- (* env: (variable, rank) environment
- * cenv: (function, arguments' ranks) environment
+ let rec rank_g e ce = function
+ (* e: (variable, rank) environment
+ * ce: (function, arguments' ranks) environment
*)
(* App: external call, nothing to do *)
- | GP.GAppCont _ as g -> (cenv, g)
+ | GP.GAppCont _ as g -> (ce, g)
- (* Continuations: update cenv for superterms (return a new cenv) *)
+ (* Continuations: update ce for superterms (return a new ce) *)
| GP.GCont (k, vs) as g ->
- (update_callenv cenv k (rank_values env vs), g)
+ (update_callenv ce k (rank_values e vs), g)
| GP.GCond (v, (k1, vs1), (k2, vs2)) as g ->
- let cenv = update_callenv cenv k1 (rank_values env vs1) in
- let cenv = update_callenv cenv k2 (rank_values env vs2) in
- (cenv, g)
+ let ce = update_callenv ce k1 (rank_values e vs1) in
+ let ce = update_callenv ce k2 (rank_values e vs2) in
+ (ce, g)
- (* Binds: fix update env for subterms *)
+ (* Binds: fix update e for subterms *)
| GP.GAppBind (v, vs, (x, g)) ->
- let rk = List.fold_left max 0 (rank_values env vs) in
- let (cenv, g) = rank_g (Env.add1 ~env x rk) cenv g in
- (cenv, GP.GAppBind (v, vs, (x, g)))
+ let rk = List.fold_left max 0 (rank_values e vs) in
+ let (ce, g) = rank_g (Env.add1 ~e x rk) ce g in
+ (ce, GP.GAppBind (v, vs, (x, g)))
| GP.GBind (_, GP.GBind _) -> assert false
- | GP.GBind ([-1, bs], g) -> rank_gbind env cenv bs g
+ | GP.GBind ([-1, bs], g) -> rank_gbind e ce bs g
| GP.GBind _ -> assert false
- (* Lambdas: fix subterm and then bodies, do not send env 'up', only cenv *)
+ (* Lambdas: fix subterm and then bodies, do not send e 'up', only ce *)
| GP.GLoop (v, vs, ls, g1, g2) ->
- let (cenv, g2) = rank_g env cenv g2 in
- let (cenv, g1) = rank_g env cenv g1 in
- let (cenv, ls) =
+ let (ce, g2) = rank_g e ce g2 in
+ let (ce, g1) = rank_g e ce g1 in
+ let (ce, ls) =
List.fold_left
- (fun (cenv, ls) (l, (vs, g)) ->
+ (fun (ce, ls) (l, (vs, g)) ->
let (ncenv, nl) =
- let env = Env.add ~env (List.combine vs (Env.get ~env:cenv l)) in
- (*TODO: don't add ls's calls to cenv*)
- let (ncenv, g) = rank_g env cenv g in
+ let e = Env.add ~e (List.combine vs (Env.get ~e:ce l)) in
+ (*TODO: don't add ls's calls to ce*)
+ let (ncenv, g) = rank_g e ce g in
(ncenv, (l, (vs, g)))
in
- (Env.merge ncenv cenv, nl :: ls)
+ (Env.merge ncenv ce, nl :: ls)
)
- (cenv, [])
+ (ce, [])
ls
in
- (cenv, GP.GLoop (v, vs, ls, g1, g2))
+ (ce, GP.GLoop (v, vs, ls, g1, g2))
| GP.GLambda (ls, g) ->
(*all the calls to the lambdas of ls are in g*)
(* we start by fixing ranks in g*)
- let (cenv, g) = rank_g env cenv g in
+ let (ce, g) = rank_g e ce g in
(* we then go in each of the lambdas bodies *)
- let (cenv, ls) =
+ let (ce, ls) =
List.fold_left
- (fun (cenv, ls) (l, (vs, g)) ->
+ (fun (ce, ls) (l, (vs, g)) ->
let (ncenv, nl) =
- let env = Env.add ~env (List.combine vs (Env.get ~env:cenv l)) in
- let (ncenv, g) = rank_g env cenv g in
+ let e = Env.add ~e (List.combine vs (Env.get ~e:ce l)) in
+ let (ncenv, g) = rank_g e ce g in
(ncenv, (l, (vs, g)))
in
- (Env.merge ncenv cenv, nl :: ls)
+ (Env.merge ncenv ce, nl :: ls)
)
- (cenv, [])
+ (ce, [])
ls
in
- (cenv, GP.GLambda (ls, g))
+ (ce, GP.GLambda (ls, g))
- and rank_gbind env cenv bs g =
- let rec aux env ranked nonranked = match nonranked with
- | [] -> (env, ranked)
+ and rank_gbind e ce bs g =
+ let rec aux e ranked nonranked = match nonranked with
+ | [] -> (e, ranked)
| _::_ ->
let (rankable, nonrankable) =
List.partition
- (fun (x, v) -> List.for_all (Env.has ~env) (Prim.vars_of_value v))
+ (fun (x, v) -> List.for_all (Env.has ~e) (Prim.vars_of_value v))
nonranked
in
assert (not (rankable = [])); (*replaces stack-overflow*)
- let (env, ranked) =
+ let (e, ranked) =
List.fold_left
- (fun (env, r) (x, v) ->
- let rk = rank_value env v in
- (Env.add1 ~env x rk, (rk, (x, v)) :: ranked)
+ (fun (e, r) (x, v) ->
+ let rk = rank_value e v in
+ (Env.add1 ~e x rk, (rk, (x, v)) :: ranked)
)
- (env, ranked)
+ (e, ranked)
rankable
in
- aux env ranked nonrankable
+ aux e ranked nonrankable
in
- let (env, ranked) = aux env [] bs in
- let (cenv, g) = rank_g env cenv g in
- (cenv, GP.GBind (L.classes ranked, g))
+ let (e, ranked) = aux e [] bs in
+ let (ce, g) = rank_g e ce g in
+ (ce, GP.GBind (L.classes ranked, g))
in
rank_g Env.empty Env.empty g
View
@@ -120,9 +120,9 @@ let rec apply_subs subs = function
GLambda (map_bodys (apply_subs subs) ls, apply_subs subs g)
-let assert_value env v = assert (Prim.closed env v)
+let assert_value e v = assert (Prim.closed e v)
-let assert_values env vs = List.iter (assert_value env) vs
+let assert_values e vs = List.iter (assert_value e) vs
let nits xs = List.map (fun x -> (x, ())) xs
@@ -133,69 +133,69 @@ let rec assert_dispatch = function
| GLambda _ -> assert false
let assert_g g =
- let rec aux env lenv g =
+ let rec aux e le g =
match g with
| GAppCont (v, vs, k) ->
- assert (Env.has ~env v);
- assert_values env vs;
- assert (Env.has ~env:lenv k)
+ assert (Env.has ~e v);
+ assert_values e vs;
+ assert (Env.has ~e:le k)
| GAppBind (v, vs, (x, g)) ->
- assert (Env.hasnt ~env:env x);
- assert (Env.has ~env:lenv v);
- assert_values env vs;
- aux (Env.add1 ~env x ()) lenv g
+ assert (Env.hasnt ~e:e x);
+ assert (Env.has ~e:le v);
+ assert_values e vs;
+ aux (Env.add1 ~e x ()) le g
| GCont (k, vs) ->
- assert (Env.has ~env:lenv k);
- assert_values env vs
+ assert (Env.has ~e:le k);
+ assert_values e vs
| GCond (v, (k1, vs1), (k2, vs2)) ->
- assert_value env v;
- assert (Env.has ~env:lenv k1); assert_values env vs1;
- assert (Env.has ~env:lenv k2); assert_values env vs2
+ assert_value e v;
+ assert (Env.has ~e:le k1); assert_values e vs1;
+ assert (Env.has ~e:le k2); assert_values e vs2
| GBind (_, GBind _) -> assert false
| GBind (bs, g) ->
- let (env, _) =
+ let (e, _) =
List.fold_left
- (fun (env, r) (rank, bs) ->
+ (fun (e, r) (rank, bs) ->
assert (r < rank);
let (vars, values) = List.split bs in
- List.iter (fun v -> assert (Env.hasnt ~env v)) vars;
- List.iter (assert_value env) values;
- (Env.add ~env (nits vars), rank)
+ List.iter (fun v -> assert (Env.hasnt ~e v)) vars;
+ List.iter (assert_value e) values;
+ (Env.add ~e (nits vars), rank)
)
- (env, -1)
+ (e, -1)
bs
in
- aux env lenv g
+ aux e le g
| GLoop (v, vs, ls, g1, g2) ->
assert_dispatch g1;
(*TODO: check ls's call graph*)
- assert (Env.hasnt ~env:lenv v);
- List.iter (fun v -> assert (Env.hasnt ~env v)) vs;
+ assert (Env.hasnt ~e:le v);
+ List.iter (fun v -> assert (Env.hasnt ~e v)) vs;
(*DO NOT: add ls to g2's environment (calls should go through v) *)
- aux env (Env.add1 ~env:lenv v ()) g2;
+ aux e (Env.add1 ~e:le v ()) g2;
(*TODO: deforest these iter*)
List.iter
(fun (v, (vs, g)) ->
- assert (Env.hasnt ~env:lenv v);
- List.iter (fun v -> assert (Env.hasnt ~env v)) vs;
+ assert (Env.hasnt ~e:le v);
+ List.iter (fun v -> assert (Env.hasnt ~e v)) vs;
)
ls;
let (names, lambdas) = List.split ls in
(*DO NOT: add v to g1's environment (g1 should dispatch to ls) *)
aux (Env.t_of_list (nits vs)) (Env.t_of_list (nits names)) g1;
- let lenv = Env.add ~env (nits names) in
- List.iter (fun (vs, g) -> aux (Env.add ~env (nits vs)) lenv g) lambdas
+ let le = Env.add ~e (nits names) in
+ List.iter (fun (vs, g) -> aux (Env.add ~e (nits vs)) le g) lambdas
| GLambda (ls, g) ->
List.iter
(fun (v, (vs, g)) ->
- assert (Env.hasnt ~env:lenv v);
- List.iter (fun v -> assert (Env.hasnt ~env v)) vs;
- (*DONT add v to g's env, (it's not under a GLoop!)*)
+ assert (Env.hasnt ~e:le v);
+ List.iter (fun v -> assert (Env.hasnt ~e v)) vs;
+ (*DONT add v to g's e, (it's not under a GLoop!)*)
(*DONT add v to the environment to force splitting of lambdas*)
- aux (Env.add ~env (nits vs)) lenv g
+ aux (Env.add ~e (nits vs)) le g
)
ls ;
- aux env (Env.add ~env (nits (heads ls))) g
+ aux e (Env.add ~e (nits (heads ls))) g
in
aux Env.empty (Env.one CPS.var_return ()) g
View
@@ -30,13 +30,13 @@ let t_of_list t = t
let disjoint e1 e2 = L.disjoint e1 e2
-let add1 ~env v d = (v, d) :: env
-let add ~env vds = vds @ env
+let add1 ~e v d = (v, d) :: e
+let add ~e vds = vds @ e
let merge e1 e2 = e1 @ e2
-let has ~env v = List.exists (fun vd -> fst vd = v) env
-let hasnt ~env v = not (has ~env v)
+let has ~e v = List.exists (fun vd -> fst vd = v) e
+let hasnt ~e v = not (has ~e v)
-let get ~env v = List.assoc v env
+let get ~e v = List.assoc v e
-let teg ~env d = fst (List.find (fun (_, dd) -> d = dd) env)
+let teg ~e d = fst (List.find (fun (_, dd) -> d = dd) e)
View
@@ -18,7 +18,6 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *
* }}} *)
-
type ('a, 'b) t
val empty : ('a, 'b) t
@@ -27,12 +26,12 @@ val t_of_list : ('a * 'b) list -> ('a, 'b) t
val disjoint: ('a, 'b) t -> ('a, 'b) t -> bool
-val add1 : env:(('a, 'b) t) -> 'a -> 'b -> ('a, 'b) t
-val add : env:(('a, 'b) t) -> ('a * 'b) list -> ('a, 'b) t
+val add1 : e:(('a, 'b) t) -> 'a -> 'b -> ('a, 'b) t
+val add : e:(('a, 'b) t) -> ('a * 'b) list -> ('a, 'b) t
val merge: ('a, 'b) t -> ('a, 'b) t -> ('a, 'b) t
-val has : env:(('a, 'b) t) -> 'a -> bool
-val hasnt : env:(('a, 'b) t) -> 'a -> bool
+val has : e:(('a, 'b) t) -> 'a -> bool
+val hasnt : e:(('a, 'b) t) -> 'a -> bool
-val get : env:(('a, 'b) t) -> 'a -> 'b
-val teg : env:(('a, 'b) t) -> 'b -> 'a
+val get : e:(('a, 'b) t) -> 'a -> 'b
+val teg : e:(('a, 'b) t) -> 'b -> 'a
Oops, something went wrong.

0 comments on commit 3ccefb2

Please sign in to comment.