From be28156de988449424f1c7bba8c817cc4f72d1f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= <leonard.gerard@ens.fr>
Date: Thu, 17 Nov 2011 15:28:46 +0100
Subject: [PATCH] Add a simplify pass to Obc

---
 compiler/obc/main/obc_compiler.ml             |  6 +++
 compiler/obc/transformations/simplify.ml      | 50 +++++++++++++++++++
 compiler/utilities/global/compiler_options.ml |  1 +
 compiler/utilities/misc.ml                    |  6 +++
 compiler/utilities/misc.mli                   |  4 ++
 5 files changed, 67 insertions(+)
 create mode 100644 compiler/obc/transformations/simplify.ml

diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml
index 65bf8a3..afb0c9a 100644
--- a/compiler/obc/main/obc_compiler.ml
+++ b/compiler/obc/main/obc_compiler.ml
@@ -19,6 +19,12 @@ let compile_program p =
   let p = pass "Application of Memory Allocation"
     (!do_mem_alloc or !do_linear_typing) Memalloc_apply.program p pp in
 
+  (*Scalarize for wanting backends*)
+  let p = pass "Scalarize" (!do_scalarize) Scalarize.program p pp in
+
+  (*Simplify*)
+  let p = pass "Simplify" (!do_simplify) Simplify.program p pp in
+
   (*Dead code removal*)
   let p = pass "Dead code removal"
     (!do_mem_alloc or !do_linear_typing) Deadcode.program p pp in
diff --git a/compiler/obc/transformations/simplify.ml b/compiler/obc/transformations/simplify.ml
new file mode 100644
index 0000000..d9c910c
--- /dev/null
+++ b/compiler/obc/transformations/simplify.ml
@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** This module simplify static expression of the program and deal with :
+    (0^n)[3] ==> 0
+    [3,4,5][2] ==> 5
+ *)
+
+
+
+open Names
+open Types
+open Static
+open Obc
+open Obc_mapfold
+
+let extvaluedesc funs acc evd = match evd with
+  | Wconst se ->
+      Wconst (simplify QualEnv.empty se), acc
+  | Warray (ev,e) ->
+      let ev, acc = extvalue_it funs acc ev in
+      (match ev.w_desc with
+        | Wconst { se_desc = Sarray_power (sv, [_]) } ->
+            Wconst sv, acc
+        | Wconst ({ se_desc = Sarray_power (sv, _::idx) } as arr) ->
+            Wconst {arr with se_desc = Sarray_power (sv, idx)}, acc
+        | Wconst { se_desc = Sarray sv_l } ->
+            (match e.e_desc with
+              | Eextvalue { w_desc = Wconst i } ->
+                  (try
+                    let indice = int_of_static_exp QualEnv.empty i in
+                    Wconst (Misc.nth_of_list (indice+1) sv_l), acc
+                  with _ -> raise Errors.Fallback)
+              | _ -> raise Errors.Fallback
+            )
+        | _ -> raise Errors.Fallback
+      )
+  | _ -> raise Errors.Fallback
+
+let program p =
+  let funs = { defaults with evdesc = extvaluedesc } in
+  let p, _ = program_it funs [] p in
+  p
+
diff --git a/compiler/utilities/global/compiler_options.ml b/compiler/utilities/global/compiler_options.ml
index 6c13bd1..25bbe8c 100644
--- a/compiler/utilities/global/compiler_options.ml
+++ b/compiler/utilities/global/compiler_options.ml
@@ -104,6 +104,7 @@ let add_tomato_check s = tomato_check := s :: !tomato_check
 let do_iterator_fusion = ref false
 
 let do_scalarize = ref false
+let do_simplify = ref true
 
 let do_mem_alloc = ref false
 let do_linear_typing = ref false
diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml
index bc76fa4..b892ab2 100644
--- a/compiler/utilities/misc.ml
+++ b/compiler/utilities/misc.ml
@@ -109,6 +109,12 @@ let rec take n l = match n, l with
   | n, h :: t -> take (n - 1) t
   | _ -> invalid_arg "take: list is too short"
 
+let rec nth_of_list n l = match n, l with
+  | 1, h::t -> h
+  | n, h::t -> nth_of_list (n-1) t
+  | _ -> raise List_too_short
+
+
 let remove x l =
   List.filter (fun y -> x <> y) l
 
diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli
index 95e3263..1ff8192 100644
--- a/compiler/utilities/misc.mli
+++ b/compiler/utilities/misc.mli
@@ -53,6 +53,10 @@ val split_at : int -> 'a list -> 'a list * 'a list
 (** [take n l] returns the [n] first elements of the list [l] *)
 val take : int -> 'a list -> 'a list
 
+(** [nth_of_list n l] @return the [n] element of the list [l] (1 is the first)
+    @raise List_too_short exception if the list is too short.*)
+val nth_of_list : int -> 'a list -> 'a
+
 (** [remove x l] removes all occurrences of x from list l.*)
 val remove : 'a -> 'a list -> 'a list