Ext-value inlining pass.

compiler/global/types.ml

@@ -30,7 +30,7 @@ and static_exp_desc =
 
 and ty =
   | Tprod of ty list (** Product type used for tuples *)
-  | Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial]) *)
+  | Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial])*)
   | Tarray of ty * static_exp (** [base_type] * [size] *) (* ty should not be prod *)
   | Tinvalid
 

compiler/minils/main/mls_compiler.ml

@@ -34,6 +34,7 @@ let compile_program p =
 
   let p =
     let call_tomato = !tomato or (List.length !tomato_nodes > 0) in
+    let p = pass "Extended value inlining" call_tomato Inline_extvalues.program p pp in
     pass "Data-flow minimization" call_tomato Tomato.program p pp in
 
 (** TODO: re enable when ported to the new AST

compiler/minils/minils.ml

@@ -78,10 +78,10 @@ and edesc =
                        (** map f <<n>> <(extvalue)> (extvalue) reset ident *)
 
 and app = { a_op: op;
-	    a_params: static_exp list;
-	    a_unsafe: bool;
-	    a_id: ident option;
-	    a_inlined: bool }
+            a_params: static_exp list;
+            a_unsafe: bool;
+            a_id: ident option;
+            a_inlined: bool }
     (** Unsafe applications could have side effects
         and be delicate about optimizations, !be careful! *)
 

compiler/minils/mls_utils.ml

@@ -215,10 +215,19 @@ module AllDep = Dep.Make
 
 let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq))
 
-
 let ident_list_of_pat pat =
   let rec f acc pat = match pat with
     | Evarpat id -> id::acc
     | Etuplepat pat_l -> List.fold_left f acc pat_l
   in
   List.rev (f [] pat)
+
+let remove_eqs_from_node nd ids =
+  let walk_vd vd vd_list = if IdentSet.mem vd.v_ident ids then vd_list else vd :: vd_list in
+  let walk_eq eq eq_list =
+    let defs = ident_list_of_pat eq.eq_lhs in
+    if List.for_all (fun v -> IdentSet.mem v ids) defs then eq_list else eq :: eq_list
+  in
+  let vd_list = List.fold_right walk_vd nd.n_local [] in
+  let eq_list = List.fold_right walk_eq nd.n_equs [] in
+  { nd with n_local = vd_list; n_equs = eq_list; }

compiler/minils/transformations/inline_extvalues.ml

@@ -0,0 +1,170 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Misc
+open Names
+open Idents
+open Signature
+open Minils
+open Mls_utils
+open Mls_printer
+open Global_printer
+open Types
+open Clocks
+open Pp_tools
+open Mls_compare
+
+(*
+  Help tomato by inlining extended values.
+
+  1. Create an environment mapping x to w for each equation of the form "x = w" ;
+
+  2. Traverse the AST, replacing each use of x by its definition ;
+
+  3. Compute potential new formed extended values, e.g. when y = 1 + x becomes y = 1 + w ;
+
+  4. If no new extended value was formed, stop ; else, go back to 1.
+*)
+
+let gather_extvalues_node nd =
+  let gather_extvalues_eq _ env eq =
+    let env = match eq.eq_lhs, eq.eq_rhs.e_desc with
+      | Evarpat x, Eextvalue w -> Env.add x w env
+      | _ -> env
+    in
+    eq, env
+  in
+
+  let funs = { Mls_mapfold.defaults with Mls_mapfold.eq = gather_extvalues_eq; } in
+  let _, env = Mls_mapfold.node_dec funs Env.empty nd in
+  env
+
+let inline_extvalue_node env nd =
+  let inline_extvalue_desc env funs () w_d =
+    let w_d, () = Mls_mapfold.extvalue_desc funs () w_d in
+    (match w_d with
+      | Wvar x -> (try (Env.find x env).w_desc with Not_found -> w_d)
+      | _ -> w_d), ()
+  in
+
+  let env =
+    let funs =
+      { Mls_mapfold.defaults with
+        Mls_mapfold.extvalue_desc = inline_extvalue_desc env; } in
+
+    let tclose x w new_env =
+      let w, () = Mls_mapfold.extvalue funs () w in
+      Env.add x w new_env
+    in
+    Env.fold tclose env Env.empty
+  in
+
+  let funs = { Mls_mapfold.defaults with Mls_mapfold.extvalue_desc = inline_extvalue_desc env; } in
+
+  let nd, () = Mls_mapfold.node_dec funs () nd in
+  nd
+
+let form_new_extvalue_node nd =
+  let rec form_new_extvalue e =
+    try
+      let se = form_new_const e in
+      mk_extvalue ~ty:e.e_ty ~linearity:e.e_linearity ~clock:e.e_base_ck ~loc:e.e_loc (Wconst se)
+    with Errors.Fallback ->
+      let w_d = match e.e_desc with
+        | Eextvalue w -> w.w_desc
+        | Ewhen (e, v, x) -> Wwhen (form_new_extvalue e, v, x)
+        | _ -> raise Errors.Fallback
+      in
+      mk_extvalue ~ty:e.e_ty ~linearity:e.e_linearity ~clock:e.e_base_ck ~loc:e.e_loc w_d
+
+  and form_new_const e =
+    let se_d = match e.e_desc with
+      | Eextvalue { w_desc = Wconst c; } -> c.se_desc
+
+    (* | Eextvalue { w_desc = Wvar n; } -> *)
+    (*   (try Svar (Q (qualify_const local_const (ToQ n))) *)
+    (*    with Error.ScopingError _ -> raise Errors.Fallback) *)
+
+      | Eapp ({ a_op = Efun ({ qual = Names.Pervasives; } as funn); }, w_list, None) ->
+        Sop (funn, form_new_consts w_list)
+
+      | Eapp ({ a_op = Earray_fill; a_params = n_list; }, [w], None) ->
+        Sarray_power (form_new_const_w w, n_list)
+
+      | Eapp ({ a_op = Earray; }, w_list, None) ->
+        Sarray (form_new_consts w_list)
+
+      | Estruct w_list ->
+        Srecord (List.map (fun (f, w) -> f, form_new_const_w w) w_list)
+
+      | _ -> raise Errors.Fallback
+    in
+    mk_static_exp ~loc:e.e_loc e.e_ty se_d
+
+  and form_new_consts w_list = List.map form_new_const_w w_list
+
+  and form_new_const_w w =
+    let mk_exp w =
+      mk_exp w.w_ck w.w_ty ~linearity:w.w_linearity ~ck:w.w_ck ~ct:(Ck w.w_ck) (Eextvalue w) in
+    form_new_const (mk_exp w)
+
+  and form_new_extvalue_eq _ n eq = match eq.eq_rhs.e_desc with
+    | Eextvalue _ -> (eq, n)
+    | _ ->
+      try
+        let w = form_new_extvalue eq.eq_rhs in
+        let e = { eq.eq_rhs with e_desc = Eextvalue w; } in
+        { eq with eq_rhs = e; }, n + 1
+      with Errors.Fallback ->
+        eq, n
+  in
+
+  let funs = { Mls_mapfold.defaults with Mls_mapfold.eq = form_new_extvalue_eq; } in
+  let nd, n = Mls_mapfold.node_dec funs 0 nd in
+  nd, n > 0
+
+let compute_needed nd =
+  let compute_needed_edesc funs ids e_d =
+    let e_d, ids = Mls_mapfold.edesc funs ids e_d in
+    e_d,
+    (match e_d with
+      | Emerge (x, _) -> IdentSet.add x ids
+      | Ewhen (_, _, x) -> IdentSet.add x ids
+      | Eapp (_, _, Some x) -> IdentSet.add x ids
+      | _ -> ids)
+
+  and compute_needed_node funs ids nd =
+    let nd, ids = Mls_mapfold.node_dec funs ids nd in
+    nd, (List.fold_left (fun ids v -> IdentSet.add v.v_ident ids) ids nd.n_output) in
+
+  let funs =
+    { Mls_mapfold.defaults with
+      Mls_mapfold.node_dec = compute_needed_node;
+      Mls_mapfold.edesc = compute_needed_edesc; } in
+  snd (Mls_mapfold.node_dec_it funs IdentSet.empty nd)
+
+let id_set_of_env nd env =
+  let needed = compute_needed nd in
+  let add id _ ids = if IdentSet.mem id needed then ids else IdentSet.add id ids in
+  Env.fold add env IdentSet.empty
+
+let rec node funs () nd =
+  let env = gather_extvalues_node nd in
+  (* Format.eprintf "=> %d@." (Env.fold (fun _ _ n -> n + 1) env 0); *)
+  (* Env.fold (fun x w () -> Format.eprintf "%a => @[%a@]@." print_ident x print_extvalue w) env (); *)
+  let nd = inline_extvalue_node env nd in
+  let nd = remove_eqs_from_node nd (id_set_of_env nd env) in
+  (* IdentSet.iter (fun id -> Format.eprintf "%a@." print_ident id) (id_set_of_env nd env); *)
+  let nd, changed = form_new_extvalue_node nd in
+  if changed then node funs () nd else (nd, ())
+
+let program program =
+  let funs = { Mls_mapfold.defaults with Mls_mapfold.node_dec = node; } in
+  let program, () = Mls_mapfold.program funs () program in
+  program