From 36bfa81b1721c5a2affc009d8ca0691dc5ef1f86 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= <cedric.pasteur@ens.fr>
Date: Fri, 14 Sep 2012 16:08:26 +0200
Subject: [PATCH] Fix for memalloc

Take the simplified versions of types (i.e.
with constants instantiated) to check the
equality of types
---
 compiler/global/static.ml                |  5 +++++
 compiler/heptagon/analysis/typing.ml     | 13 ++++---------
 compiler/minils/analysis/interference.ml |  8 ++++++--
 3 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/compiler/global/static.ml b/compiler/global/static.ml
index 4dd8f38..2096ed8 100644
--- a/compiler/global/static.ml
+++ b/compiler/global/static.ml
@@ -186,6 +186,11 @@ let simplify env se =
   try eval_core true env se
   with exn -> message exn
 
+let rec simplify_type env ty = match ty with
+  | Tarray(ty, e) -> Tarray(simplify_type env ty, simplify env e)
+  | Tprod l -> Tprod (List.map (simplify_type env) l)
+  | t -> t
+
 (** [eval env e] does the same as [simplify]
     but if it returns, there are no variables nor op left.
     @raise [Errors.Error] when it cannot fully evaluate. *)
diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml
index cd48382..a7c2f49 100644
--- a/compiler/heptagon/analysis/typing.ml
+++ b/compiler/heptagon/analysis/typing.ml
@@ -299,11 +299,6 @@ let build_subst names values =
   List.fold_left2 (fun m n v -> QualEnv.add n v m)
     QualEnv.empty names values
 
-let rec subst_type_vars m = function
-  | Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e)
-  | Tprod l -> Tprod (List.map (subst_type_vars m) l)
-  | t -> t
-
 let add_distinct_env id vd env =
   if Env.mem id env then
     error (Ealready_defined(name id))
@@ -640,8 +635,8 @@ let rec typing cenv h e =
             List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
           let m = build_subst node_params params in
           let expected_ty_list =
-            List.map (subst_type_vars m) expected_ty_list in
-          let result_ty_list = List.map (subst_type_vars m) result_ty_list in
+            List.map (simplify_type m) expected_ty_list in
+          let result_ty_list = List.map (simplify_type m) result_ty_list in
           let typed_n_list = List.map (expect_static_exp cenv (Tid Initial.pint)) n_list in
           (*typing of partial application*)
           let p_ty_list, expected_ty_list =
@@ -776,9 +771,9 @@ and typing_app cenv h app e_list =
         let op, expected_ty_list, result_ty_list = kind f ty_desc in
         let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
         let m = build_subst node_params app.a_params in
-        let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
+        let expected_ty_list = List.map (simplify_type m) expected_ty_list in
         let typed_e_list = typing_args cenv h expected_ty_list e_list in
-        let result_ty_list = List.map (subst_type_vars m) result_ty_list in
+        let result_ty_list = List.map (simplify_type m) result_ty_list in
         (* Type static parameters and generate constraints *)
         let typed_params = typing_node_params cenv ty_desc.node_params app.a_params in
         let constrs = List.map (simplify m) ty_desc.node_param_constraints in
diff --git a/compiler/minils/analysis/interference.ml b/compiler/minils/analysis/interference.ml
index a976a5f..d03cfb4 100644
--- a/compiler/minils/analysis/interference.ml
+++ b/compiler/minils/analysis/interference.ml
@@ -132,7 +132,7 @@ module InterfRead = struct
     in
       List.fold_left tr_one [] wl
 
-  let read_extvalue funs acc w =
+  let read_extvalue _ acc w =
     (* recursive call *)
     (*let _, acc = Mls_mapfold.extvalue funs acc w in*)
     let acc =
@@ -386,10 +386,14 @@ let should_interfere = Misc.memoize_couple should_interfere
     variable declaration list vds. It just creates one graph per type
     and one node per declaration. *)
 let init_interference_graph () =
+  let add_tyenv env iv =
+    let ty = Static.simplify_type Names.QualEnv.empty (World.ivar_type iv) in
+    TyEnv.add_element ty (mk_node iv) env
+  in
   (** Adds a node for the variable and all fields of a variable. *)
   let rec add_ivar env iv ty =
     let ivars = all_ivars [] iv None ty in
-      List.fold_left (fun env iv -> TyEnv.add_element (World.ivar_type iv) (mk_node iv) env) env ivars
+      List.fold_left add_tyenv env ivars
   in
   let env = Env.fold
     (fun _ vd env -> add_ivar env (Ivar vd.v_ident) vd.v_type) !World.vds TyEnv.empty in