jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Correction of Inline pass

Browse source 
- correction of Hept_mapfold : inclusion of mapfold for b_defnames (blocks)
- Inlining : deep replacement of idents
This commit is contained in:
Gwenal Delaval 2012-06-13 15:06:05 +02:00
parent cf22ba3989
commit 352bad4735
2 changed files with 61 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
compiler/heptagon/hept_mapfold.ml
View file

@ -194,10 +194,18 @@ and eqdesc funs acc eqd = match eqd with
and block_it funs acc b = funs.block funs acc b
and block funs acc b =
(* TODO defnames ty ?? *)
let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in
let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in
{ b with b_local = b_local; b_equs = b_equs }, acc
let b_defnames, acc =
Idents.Env.fold
(fun v v_dec (env,acc) ->
let v, acc = var_ident_it funs.global_funs acc v in
let v_dec, acc = var_dec_it funs acc v_dec in
let env = Idents.Env.add v v_dec env in
env, acc)
b.b_defnames
(Idents.Env.empty, acc) in
{ b with b_local = b_local; b_equs = b_equs; b_defnames = b_defnames }, acc
and state_handler_it funs acc s = funs.state_handler funs acc s

79
compiler/heptagon/transformations/inline.ml
View file

@ -24,38 +24,61 @@ let mk_unique_node nd =
let mk_bind vd =
let id = fresh (Idents.name vd.v_ident) in
(vd.v_ident, { vd with v_ident = id; v_clock = Clocks.fresh_clock () }) in
let subst = List.map mk_bind (nd.n_block.b_local
@ nd.n_input @ nd.n_output) in
let subst =
List.fold_left
(fun subst vd ->
let id, vd = mk_bind vd in
Env.add id vd.v_ident subst)
Env.empty
(nd.n_input @ nd.n_output) in
let subst_var_dec _ () vd = (List.assoc vd.v_ident subst, ()) in
(* let subst_var_dec _ () vd = (List.assoc vd.v_ident subst, ()) in *)
let subst_edesc funs () ed =
let ed, () = Hept_mapfold.edesc funs () ed in
let find vn = (List.assoc vn subst).v_ident in
(match ed with
| Evar vn -> Evar (find vn)
| Elast vn -> Elast (find vn)
| Ewhen (e, cn, vn) -> Ewhen (e, cn, find vn)
| Emerge (vn, e_l) -> Emerge (find vn, e_l)
| _ -> ed), ()
in
(* let subst_edesc funs () ed = *)
(* let ed, () = Hept_mapfold.edesc funs () ed in *)
(* let find vn = (List.assoc vn subst).v_ident in *)
(* (match ed with *)
(* | Evar vn -> Evar (find vn) *)
(* | Elast vn -> Elast (find vn) *)
(* | Ewhen (e, cn, vn) -> Ewhen (e, cn, find vn) *)
(* | Emerge (vn, e_l) -> Emerge (find vn, e_l) *)
(* | _ -> ed), () *)
(* in *)
let subst_eqdesc funs () eqd =
let (eqd, ()) = Hept_mapfold.eqdesc funs () eqd in
match eqd with
| Eeq (pat, e) ->
let rec subst_pat pat = match pat with
| Evarpat vn -> Evarpat (try (List.assoc vn subst).v_ident
with Not_found -> vn)
| Etuplepat patl -> Etuplepat (List.map subst_pat patl) in
(Eeq (subst_pat pat, e), ())
| _ -> raise Errors.Fallback in
(* let subst_eqdesc funs () eqd = *)
(* let (eqd, ()) = Hept_mapfold.eqdesc funs () eqd in *)
(* match eqd with *)
(* | Eeq (pat, e) -> *)
(* let rec subst_pat pat = match pat with *)
(* | Evarpat vn -> Evarpat (try (List.assoc vn subst).v_ident *)
(* with Not_found -> vn) *)
(* | Etuplepat patl -> Etuplepat (List.map subst_pat patl) in *)
(* (Eeq (subst_pat pat, e), ()) *)
(* | _ -> raise Errors.Fallback in *)
let funs = { defaults with
var_dec = subst_var_dec;
eqdesc = subst_eqdesc;
edesc = subst_edesc; } in
fst (Hept_mapfold.node_dec funs () nd)
let subst_var_ident _funs subst v =
let v = Env.find v subst in
v, subst in
let subst_block funs subst b =
let b_local, subst' =
mapfold
(fun subst vd ->
let id, vd = mk_bind vd in
vd, (Env.add id vd.v_ident subst))
subst b.b_local in
let b, _ = Hept_mapfold.block funs subst' b in
{ b with b_local = b_local }, subst in
(* let funs = { defaults with *)
(* var_dec = subst_var_dec; *)
(* eqdesc = subst_eqdesc; *)
(* edesc = subst_edesc; } in *)
let funs = { Hept_mapfold.defaults with
block = subst_block;
global_funs = { Global_mapfold.defaults with
Global_mapfold.var_ident = subst_var_ident } } in
fst (Hept_mapfold.node_dec funs subst nd)
let exp funs (env, newvars, newequs) exp =
let exp, (env, newvars, newequs) = Hept_mapfold.exp funs (env, newvars, newequs) exp in