From 352bad4735859cf4f54dc99ba69b10f3c0a58d99 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Gwena=EBl=20Delaval?= <gwenael.delaval@inria.fr>
Date: Wed, 13 Jun 2012 15:06:05 +0200
Subject: [PATCH] Correction of Inline pass

- correction of Hept_mapfold : inclusion of mapfold for b_defnames (blocks)
- Inlining : deep replacement of idents
---
 compiler/heptagon/hept_mapfold.ml           | 12 +++-
 compiler/heptagon/transformations/inline.ml | 79 +++++++++++++--------
 2 files changed, 61 insertions(+), 30 deletions(-)

diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml
index 7306d13..1c80888 100644
--- a/compiler/heptagon/hept_mapfold.ml
+++ b/compiler/heptagon/hept_mapfold.ml
@@ -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
diff --git a/compiler/heptagon/transformations/inline.ml b/compiler/heptagon/transformations/inline.ml
index 07db4dc..ab6e36a 100644
--- a/compiler/heptagon/transformations/inline.ml
+++ b/compiler/heptagon/transformations/inline.ml
@@ -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