From b97a966e76f00a50f6a9e6c247184ba0d55aba6a Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Tue, 18 Dec 2012 14:48:12 +0100
Subject: [PATCH] Plug back the array expansion.
---
Makefile | 6 +
src/compile.ml | 23 ++--
src/l2lAliasType.ml | 186 +++++++++++++--------------
src/l2lExpandArrays.ml | 259 +++++++++++++++++++------------------
src/l2lExpandArrays.mli | 4 +-
src/l2lRmPoly.ml | 29 ++---
src/l2lRmPoly.mli | 14 +-
src/l2lSplit.ml | 277 ++++++++++++++++++++--------------------
src/licPrg.ml | 45 ++++---
src/licPrg.mli | 6 +-
src/main.ml | 8 +-
src/mainArgs.ml | 2 +-
todo.org | 10 +-
13 files changed, 448 insertions(+), 421 deletions(-)
diff --git a/Makefile b/Makefile
index 9b917d59..1ae7f6aa 100644
--- a/Makefile
+++ b/Makefile
@@ -126,6 +126,10 @@ dot:
html:
ocamldoc -I $(OBJDIR) $(MLONLY_SOURCES) -d ocamldoc -html -keep-code
+nomli:
+ rm $(OBJDIR)/*.mli
+
+debug: nomli dc
ln: $(OBJDIR) $(SOURCES)
@@ -145,6 +149,8 @@ $(OBJDIR)/version.ml:
echo "let commit = \"$(shell utils/get_commit_number)\"" >> $@
echo "let sha_1 = \"$(shell utils/get_sha_1)"\">> $@
echo "let str = (branch ^ \".\" ^ commit)">> $@
+ echo "let maintainer = \"jahier@imag.fr\"">> $@
+
all: nc
diff --git a/src/compile.ml b/src/compile.ml
index 0d571867..09747369 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 16:51) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 14:39) by Erwan Jahier> *)
open Lxm
@@ -40,21 +40,16 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
LicTab.compile_node lic_tab main_node
in
let zelic = LicTab.to_lic_prg lic_tab in
-
(* élimination polymorphisme surcharge *)
let zelic = L2lRmPoly.doit zelic in
-
(* alias des types array *)
let zelic = L2lAliasType.doit zelic in
-
- (* split des equations (1 eq = 1 op) *)
- let zelic = if !Global.one_op_per_equation then L2lSplit.doit zelic else zelic in
-(* let zelic = *)
-(* if !Global.expand_structs *)
-(* then L2lExpandArrays.doit id_solver lenv zelic *)
-(* else zelic *)
-(* in *)
-
- (* XXX node et array expand ! *)
-
+ let zelic = if not !Global.one_op_per_equation then zelic else
+ (* Split des equations (1 eq = 1 op) *)
+ L2lSplit.doit zelic
+ in
+ let zelic = if not !Global.expand_structs then zelic else
+ (* Array and struct expansion: to do after polymorphism elimination *)
+ L2lExpandArrays.doit zelic
+ in
zelic
diff --git a/src/l2lAliasType.ml b/src/l2lAliasType.ml
index a0796720..bdf5403e 100644
--- a/src/l2lAliasType.ml
+++ b/src/l2lAliasType.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:48) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 10:10) by Erwan Jahier> *)
(**
Source 2 source transformation :
@@ -13,116 +13,116 @@ open Lic
let doit (inp : LicPrg.t) : LicPrg.t =
(* n.b. on fait un minumum d'effet de bord pour
pas avoir trop d'acummulateur ... *)
- let atab = Hashtbl.create 10 in
- let res = ref inp in
+ let atab = Hashtbl.create 10 in
+ let res = ref inp in
(** UTILE : nommage des alias d'array *)
- let array_ident ty sz =
- let tid = Lic.ident_of_type ty in
- let sfx = Printf.sprintf "%s_%d" (snd tid) sz in
- let id = LicPrg.fresh_type_id !res (fst tid) sfx in
- id
- in
+ let array_ident ty sz =
+ let tid = Lic.ident_of_type ty in
+ let sfx = Printf.sprintf "%s_%d" (snd tid) sz in
+ let id = LicPrg.fresh_type_id !res (fst tid) sfx in
+ id
+ in
(** UTILE : cherche/crée un alias de type *)
- let rec alias_type te =
- match te with
+ let rec alias_type te =
+ match te with
| Array_type_eff (ty, sz) -> (
- let ty = alias_type ty in
- let te = Array_type_eff (ty, sz) in
- try
- let ref_te = Hashtbl.find atab te in
-(*
-Verbose.printf "--> alias_type %s = %s ^ %d FOUND : %s\n"
-(LicDump.string_of_type_eff te)
-(LicDump.string_of_type_eff ty)
-sz
-(LicDump.string_of_type_eff ref_te);
-*)
- ref_te
- with Not_found -> (
- let id = array_ident ty sz in
- let ref_te = Abstract_type_eff (id, te) in
- res := LicPrg.add_type id ref_te !res;
- Hashtbl.add atab te ref_te;
-(*
-Verbose.printf "--> alias_type %s = %s ^ %d NOT FOUND, gives: %s\n"
-(LicDump.string_of_type_eff te)
-(LicDump.string_of_type_eff ty)
-sz
-(LicDump.string_of_type_eff ref_te);
-*)
- ref_te
- )
+ let ty = alias_type ty in
+ let te = Array_type_eff (ty, sz) in
+ try
+ let ref_te = Hashtbl.find atab te in
+ (*
+ Verbose.printf "--> alias_type %s = %s ^ %d FOUND : %s\n"
+ (LicDump.string_of_type_eff te)
+ (LicDump.string_of_type_eff ty)
+ sz
+ (LicDump.string_of_type_eff ref_te);
+ *)
+ ref_te
+ with Not_found -> (
+ let id = array_ident ty sz in
+ let ref_te = Abstract_type_eff (id, te) in
+ res := LicPrg.add_type id ref_te !res;
+ Hashtbl.add atab te ref_te;
+ (*
+ Verbose.printf "--> alias_type %s = %s ^ %d NOT FOUND, gives: %s\n"
+ (LicDump.string_of_type_eff te)
+ (LicDump.string_of_type_eff ty)
+ sz
+ (LicDump.string_of_type_eff ref_te);
+ *)
+ ref_te
+ )
) | _ -> te
- in
+ in
(** TRAITE LES TYPES *)
- let do_type k te =
- let te' = match te with
+ let do_type k te =
+ let te' = match te with
| Array_type_eff (tel, sz) ->
- let tel' = alias_type tel in
- Array_type_eff (tel', sz)
+ let tel' = alias_type tel in
+ Array_type_eff (tel', sz)
| Struct_type_eff (id, fields) ->
- let do_field (id, (tf, co)) =
- (id, (alias_type tf, co))
- in
- Struct_type_eff (id, List.map do_field fields)
+ let do_field (id, (tf, co)) =
+ (id, (alias_type tf, co))
+ in
+ Struct_type_eff (id, List.map do_field fields)
| _ -> te
- in
- if (te = te') then ()
- else
- res := LicPrg.add_type k te' !res
- in
- LicPrg.iter_types do_type inp;
+ in
+ if (te = te') then ()
+ else
+ res := LicPrg.add_type k te' !res
+ in
+ LicPrg.iter_types do_type inp;
(** TRAITE LES CONSTANTES *)
- let do_const k ec =
- let ec' = match ec with
- | Extern_const_eff (i, te) ->
- let te' = alias_type te in
- Extern_const_eff (i, te')
- | Abstract_const_eff (i, te, c, b) ->
- let te' = alias_type te in
- Abstract_const_eff (i, te', c, b)
- | Array_const_eff (cl, te) ->
- let te' = alias_type te in
- Array_const_eff (cl, te')
- | Bool_const_eff _
- | Int_const_eff _
- | Real_const_eff _
- | Enum_const_eff _
- | Struct_const_eff _
- | Tuple_const_eff _ -> ec
- in
- if (ec = ec') then ()
- else
+ let do_const k ec =
+ let ec' = match ec with
+ | Extern_const_eff (i, te) ->
+ let te' = alias_type te in
+ Extern_const_eff (i, te')
+ | Abstract_const_eff (i, te, c, b) ->
+ let te' = alias_type te in
+ Abstract_const_eff (i, te', c, b)
+ | Array_const_eff (cl, te) ->
+ let te' = alias_type te in
+ Array_const_eff (cl, te')
+ | Bool_const_eff _
+ | Int_const_eff _
+ | Real_const_eff _
+ | Enum_const_eff _
+ | Struct_const_eff _
+ | Tuple_const_eff _ -> ec
+ in
+ if (ec = ec') then ()
+ else
(* n.b. add=replace *)
- res := LicPrg.add_const k ec' !res
- in
- LicPrg.iter_consts do_const inp ;
+ res := LicPrg.add_const k ec' !res
+ in
+ LicPrg.iter_consts do_const inp ;
(** TRAITE LES NOEUDS *)
- let do_node k en =
+ let do_node k en =
(* n.b. les Lic.type_ apparraissent uniquement dans les var infos *)
- let do_var vi =
- let ty = alias_type vi.var_type_eff in
- {vi with var_type_eff = ty}
- in
- let en' = { en with
- inlist_eff = (List.map do_var en.inlist_eff);
- outlist_eff = (List.map do_var en.outlist_eff);
- loclist_eff = (
- match en.loclist_eff with
- | Some vl -> Some (List.map do_var vl)
- | None -> None
- )
- } in
+ let do_var vi =
+ let ty = alias_type vi.var_type_eff in
+ {vi with var_type_eff = ty}
+ in
+ let en' = { en with
+ inlist_eff = (List.map do_var en.inlist_eff);
+ outlist_eff = (List.map do_var en.outlist_eff);
+ loclist_eff = (
+ match en.loclist_eff with
+ | Some vl -> Some (List.map do_var vl)
+ | None -> None
+ )
+ } in
(* on fait pas dans la dentelle, on remplace ... *)
- res := LicPrg.add_node k en' !res
- in
- LicPrg.iter_nodes do_node inp;
- !res
+ res := LicPrg.add_node k en' !res
+ in
+ LicPrg.iter_nodes do_node inp;
+ !res
diff --git a/src/l2lExpandArrays.ml b/src/l2lExpandArrays.ml
index 56ae81f6..0be003de 100644
--- a/src/l2lExpandArrays.ml
+++ b/src/l2lExpandArrays.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 13/12/2012 (at 16:28) by Erwan Jahier> *)
+(** Time-stamp: <modified the 18/12/2012 (at 14:46) by Erwan Jahier> *)
(* Replace structures and arrays by as many variables as necessary.
Since structures can be recursive, it migth be a lot of new variables...
@@ -33,15 +33,23 @@ type acc =
* (Lic.eq_info srcflagged) list (* equations *)
* Lic.var_info list (* new local vars *)
+let dbg=Some (Verbose.get_flag "esa")
(********************************************************************************)
+(* pack useful info (while expanding nodes) into a single struct *)
+type local_ctx = {
+ idgen : LicPrg.id_generator;
+ node : Lic.node_exp;
+ prg : LicPrg.t;
+}
(* stuff to create fresh var names.
XXX code dupl. with Split.new_var
*)
-let new_var str node_env type_eff clock_eff =
+let new_var str lctx type_eff clock_eff =
let id = Ident.of_string (LicName.new_local_var str) in
+ let id = lctx.idgen str in (* XXX use which one ??? *)
let var =
{
var_name_eff = id;
@@ -52,20 +60,21 @@ let new_var str node_env type_eff clock_eff =
var_clock_eff = id, clock_eff;
}
in
- Hashtbl.add node_env.lenv_vars id var;
var
+(* for local use: polymorphic predef operators should not transformed; hence,
+ whenever we reach a Any/AnyNum type, we raise that exception and skip the
+ transformation of the current node.
+*)
+exception Polymorphic
+
(* returns a new var based on [vi] with type [type_eff]. *)
let clone_var node_env vi str type_eff =
let str = (Ident.to_string vi.var_name_eff) ^ str in
let id = Ident.of_string (str) in
let clk_id = Ident.of_string str in
let type_eff = match type_eff with
- TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error
- "L2lExpandArrays.clone" "should not have been called for a any(num) var";
- assert false
-
+ TypeVar Any | TypeVar AnyNum -> raise Polymorphic
| _ -> type_eff
in
let var =
@@ -84,10 +93,7 @@ let clone_var node_env vi str type_eff =
let rec (is_a_basic_type : Lic.type_ -> bool) =
function
| Array_type_eff _ | Struct_type_eff _ -> false
- | TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error
- "L2lExpandArrays.is_a_basic_type" "should not have been called for a any(num) var";
- assert false
+ | TypeVar Any | TypeVar AnyNum -> raise Polymorphic
| Abstract_type_eff(_, teff) -> is_a_basic_type teff
| External_type_eff(_)
| Enum_type_eff (_, _)
@@ -149,10 +155,7 @@ let rec (gen_var_trees :
fun make_leave prefix teff ->
let loop = gen_var_trees make_leave in
match teff with
- | TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error
- "L2lExpandArrays.gen_var_trees" "should not have been called for a any(num) var";
- assert false
+ | TypeVar Any | TypeVar AnyNum -> raise Polymorphic
| Bool_type_eff | Int_type_eff | Real_type_eff
| Enum_type_eff(_) | External_type_eff(_)
->
@@ -177,16 +180,16 @@ let rec (gen_var_trees :
)
fl)
-let (expand_left : Lic.local_env -> left -> left list) =
- fun nenv left ->
+let (expand_left : local_ctx -> left -> left list) =
+ fun lctx left ->
let rec (var_trees_of_left : left -> left var_tree) =
fun left ->
match left with
| LeftVarLic (vi,lxm) ->
- let make_left nenv lxm vi prefix teff =
- LeftVarLic (clone_var nenv vi prefix teff, lxm)
+ let make_left lctx lxm vi prefix teff =
+ LeftVarLic (clone_var lctx vi prefix teff, lxm)
in
- gen_var_trees (make_left nenv lxm vi) "" vi.var_type_eff
+ gen_var_trees (make_left lctx lxm vi) "" vi.var_type_eff
| LeftFieldLic (l,id,t) ->
(match var_trees_of_left l with
| S fl -> List.assoc id fl
@@ -218,23 +221,22 @@ let (expand_left : Lic.local_env -> left -> left list) =
(** build a new loc that will alias ve, and add its definition in the
set of equations (cf acc) *)
-let rec (make_new_loc : Lic.local_env -> Lic.id_solver -> Lxm.t -> acc ->
- Lic.val_exp -> acc * var_info) =
- fun nenv id_solver lxm acc ve ->
+let rec (make_new_loc : local_ctx -> Lxm.t -> acc -> Lic.val_exp
+ -> acc * var_info) =
+ fun lctx lxm acc ve ->
let teff = List.hd ve.ve_typ in
let ceff = List.hd ve.ve_clk in
- let nv = new_var "v" nenv teff ceff in
+ let nv = new_var "v" lctx teff ceff in
let neq = [LeftVarLic(nv,lxm)], ve in
let neq = flagit neq lxm in
- let nvl, (asserts,eqs,locs) = expand_var_info nenv id_solver ([],acc) nv in
+ let nvl, (asserts,eqs,locs) = expand_var_info lctx ([],acc) nv in
let acc = (asserts,eqs, List.rev_append nvl locs) in
- expand_eq nenv id_solver acc neq, nv
-
-and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
- -> acc * Lic.val_exp var_tree) =
- fun nenv id_solver acc ve ->
+ expand_eq lctx acc neq, nv
- let make_val_exp nenv lxm vi prefix teff =
+and (var_trees_of_val_exp :
+ local_ctx -> acc -> Lic.val_exp -> acc * Lic.val_exp var_tree) =
+ fun lctx acc ve ->
+ let make_val_exp lxm vi prefix teff =
let prefix = (Ident.to_string vi.var_name_eff) ^ prefix in
let id = prefix in
{
@@ -243,7 +245,7 @@ and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
ve_clk = [snd vi.var_clock_eff]
}
in
- let loop = var_trees_of_val_exp nenv id_solver acc in
+ let loop = var_trees_of_val_exp lctx acc in
match ve.ve_core with
| CallByPosLic (by_pos_op, OperLic vel) -> (
let lxm = by_pos_op.src in
@@ -272,24 +274,25 @@ and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
| _, (S _ | L _) -> assert false
)
| VAR_REF id -> (
- try
- let vi = UglyStuff.var_info_of_ident id_solver id lxm in
- (acc, gen_var_trees (make_val_exp nenv lxm vi) "" vi.var_type_eff)
- with _ ->
- let msg =
- "\n*** during Array expansion: '"^
- (id)^
- "': Unknown variable.\n"^
- "*** Current variables are: "^
- (Hashtbl.fold
- (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
- nenv.lenv_vars "")
- in
- raise (Errors.Compile_error(lxm, msg))
+ match LicPrg.find_var id lctx.node with
+ | Some vi ->
+ (acc, gen_var_trees (make_val_exp lxm vi) "" vi.var_type_eff)
+ | None ->
+ let msg =
+ "\n*** during Array expansion: '"^
+ (id)^
+ "': Unknown variable.\n"^
+ "*** Current variables are: "^
+ (List.fold_left
+ (fun acc v -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
+ ""
+ (match lctx.node.Lic.loclist_eff with None -> [] | Some v -> v))
+ in
+ raise (Errors.Compile_error(lxm, msg))
)
| CONST_REF idl -> (
try
- let const = UglyStuff.const_eff_of_item_key id_solver idl lxm in
+ let const = LicPrg.find_const lctx.prg idl in
let s, ve_const =
UnifyClock.const_to_val_eff lxm true UnifyClock.empty_subst const
in
@@ -299,17 +302,18 @@ and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
(* in order to avoid a potential infinite loop *)
(ve_const, acc)
- | _ -> expand_val_exp nenv id_solver acc ve_const
+ | _ -> expand_val_exp lctx acc ve_const
in (acc, L (ve_const))
with _ ->
let msg =
"\n*** during Array expansion: '"^
(Ident.string_of_long idl)^
- "': Unknown variable.\n"^
- "*** Current variables are: "^
- (Hashtbl.fold
- (fun i v acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_var_info v)))
- nenv.lenv_vars "")
+ "': Unknown constant.\n"^
+ "*** Current constants are: "^
+ (LicPrg.fold_consts
+ (fun k c acc -> acc^(Printf.sprintf "\n\t%s" (Lic.string_of_const c)))
+ lctx.prg
+ "")
in
raise (Errors.Compile_error(lxm, msg))
)
@@ -317,14 +321,14 @@ and (var_trees_of_val_exp : Lic.local_env -> Lic.id_solver -> acc -> Lic.val_exp
| PREDEF_CALL _ | CALL _ | MERGE _
| PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE -> (
(* Create a new loc var to alias such expressions *)
- let acc, nloc = make_new_loc nenv id_solver lxm acc ve in
- acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
+ let acc, nloc = make_new_loc lctx lxm acc ve in
+ acc, gen_var_trees (make_val_exp lxm nloc) "" nloc.var_type_eff
)
)
| CallByNameLic(by_name_op, fl) ->
let lxm = by_name_op.src in
- let acc, nloc = make_new_loc nenv id_solver lxm acc ve in
- acc, gen_var_trees (make_val_exp nenv lxm nloc) "" nloc.var_type_eff
+ let acc, nloc = make_new_loc lctx lxm acc ve in
+ acc, gen_var_trees (make_val_exp lxm nloc) "" nloc.var_type_eff
and (break_tuple : Lxm.t -> left list -> val_exp -> Lic.eq_info srcflagged list) =
fun lxm left_list ve ->
@@ -404,26 +408,25 @@ and (break_tuple : Lxm.t -> left list -> val_exp -> Lic.eq_info srcflagged list)
vel
and (expand_eq :
- Lic.local_env -> Lic.id_solver -> acc -> Lic.eq_info srcflagged -> acc) =
- fun nenv id_solver acc eqf ->
+ local_ctx -> acc -> Lic.eq_info srcflagged -> acc) =
+ fun lctx acc eqf ->
let { src = lxm_eq ; it = (left_list, ve) } = eqf in
- let left_list = List.flatten (List.map (expand_left nenv) left_list) in
- let ve,acc = expand_val_exp nenv id_solver acc ve in
+ let left_list = List.flatten (List.map (expand_left lctx) left_list) in
+ let ve,acc = expand_val_exp lctx acc ve in
let eq_list = break_tuple lxm_eq left_list ve in
let (asserts, eqs, locs) = acc in
(asserts, eq_list@eqs, locs)
-and expand_val_exp_list n_env id_solver acc vel =
+and expand_val_exp_list lctx acc vel =
List.fold_left
(fun (vel,acc) ve ->
- let ve,acc = expand_val_exp n_env id_solver acc ve in
+ let ve,acc = expand_val_exp lctx acc ve in
ve::vel, acc
)
([],acc) (List.rev vel)
-and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
- val_exp * acc) =
- fun n_env id_solver acc ve ->
+and (expand_val_exp: local_ctx -> acc -> val_exp -> val_exp * acc) =
+ fun lctx acc ve ->
match ve.ve_core with
| CallByPosLic (by_pos_op, OperLic vel) ->
let lxm = by_pos_op.src in
@@ -431,23 +434,23 @@ and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
let by_pos_op, acc, vel =
match by_pos_op with
| WITH(ve) ->
- let ve, acc = expand_val_exp n_env id_solver acc ve in
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ let ve, acc = expand_val_exp lctx acc ve in
+ let vel,acc = expand_val_exp_list lctx acc vel in
WITH(ve), acc, vel
| HAT(i,ve) ->
- let ve, acc = expand_val_exp n_env id_solver acc ve in
+ let ve, acc = expand_val_exp lctx acc ve in
let rec unfold cpt =
if cpt = 0 then [] else ve::(unfold (cpt-1))
in
TUPLE, acc, unfold i
| ARRAY(vel) ->
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ let vel,acc = expand_val_exp_list lctx acc vel in
TUPLE, acc, vel
| CONCAT | PREDEF_CALL _ | CALL _ | MERGE _
| PRE | ARROW | FBY | CURRENT | WHEN _ | TUPLE
->
- let vel,acc = expand_val_exp_list n_env id_solver acc vel in
+ let vel,acc = expand_val_exp_list lctx acc vel in
by_pos_op, acc, vel
| STRUCT_ACCESS (_)
@@ -455,7 +458,7 @@ and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
| ARRAY_SLICE (_)
| VAR_REF _
| CONST_REF _ ->
- let acc, vt = try var_trees_of_val_exp n_env id_solver acc ve
+ let acc, vt = try var_trees_of_val_exp lctx acc ve
with (Not_found | Failure _) ->
assert false (* just a defense against nth and assoc *)
in
@@ -482,7 +485,7 @@ and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
(fun (vel,acc) (id,(_,const_opt)) ->
try
let _,ve = List.find (fun (id2,_) -> id2.it = id) fl_val in
- let ve,acc = expand_val_exp n_env id_solver acc ve in
+ let ve,acc = expand_val_exp lctx acc ve in
ve::vel, acc
with Not_found ->
match const_opt with
@@ -494,7 +497,7 @@ and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
UnifyClock.empty_subst const
in
let ve_const,acc=
- expand_val_exp n_env id_solver acc ve_const
+ expand_val_exp lctx acc ve_const
in
ve_const::vel,acc
)
@@ -514,37 +517,29 @@ and (expand_val_exp: Lic.local_env -> Lic.id_solver -> acc -> val_exp ->
| _ -> assert false
-and (expand_val_exp_flag: Lic.local_env -> Lic.id_solver -> acc ->
+and (expand_val_exp_flag: local_ctx -> acc ->
val_exp srcflagged -> val_exp srcflagged * acc) =
- fun n_env id_solver acc { src = lxm ; it = ve } ->
- let ve,acc = expand_val_exp n_env id_solver acc ve in
+ fun lctx acc { src = lxm ; it = ve } ->
+ let ve,acc = expand_val_exp lctx acc ve in
{ src = lxm ; it = ve }, acc
-and (expand_assert:
- Lic.local_env -> Lic.id_solver -> acc -> val_exp srcflagged -> acc) =
- fun n_env id_solver acc ve ->
- let (ve, (asserts, eqs, locs)) = expand_val_exp_flag n_env id_solver acc ve in
+and (expand_assert: local_ctx -> acc -> val_exp srcflagged -> acc) =
+ fun lctx acc ve ->
+ let (ve, (asserts, eqs, locs)) = expand_val_exp_flag lctx acc ve in
(ve::asserts, eqs, locs)
-and (expand_var_info: Lic.local_env -> Lic.id_solver -> var_info list * acc ->
+and (expand_var_info: local_ctx -> var_info list * acc ->
var_info -> var_info list * acc) =
- fun nenv id_solver (vil, acc) vi ->
+ fun lctx (vil, acc) vi ->
let rec aux teff =
match teff with
| Abstract_type_eff (_, teff) -> aux teff
- | TypeVar Any | TypeVar AnyNum ->
- Errors.print_internal_error
- "L2lExpandArrays.expand_var_info" "should not have been called for a any(num) var";
- assert false
+ | TypeVar Any | TypeVar AnyNum -> raise Polymorphic
| Struct_type_eff (name, fl) ->
List.fold_left
(fun (vil,acc) (fn, (ft,_const_opt)) ->
- let new_var = clone_var nenv vi ("_" ^ Ident.to_string fn) ft in
- let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
- if new_vil = new_var::vil then (
- (* [new_var] type is not made of structure *)
- assert (is_a_basic_type ft);
- Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
+ let new_var = clone_var lctx vi ("_" ^ Ident.to_string fn) ft in
+ let new_vil, new_acc = expand_var_info lctx (vil,acc) new_var in
new_vil, new_acc
)
(vil, acc)
@@ -553,12 +548,14 @@ and (expand_var_info: Lic.local_env -> Lic.id_solver -> var_info list * acc ->
| Array_type_eff(at,size) ->
let rec aux i (vil,acc) =
if i=size then (vil,acc) else
- let new_var = clone_var nenv vi ("_" ^ soi i) at in
- let new_vil, new_acc = expand_var_info nenv id_solver (vil,acc) new_var in
+ let new_var = clone_var lctx vi ("_" ^ soi i) at in
+ let new_vil, new_acc = expand_var_info lctx (vil,acc) new_var in
if new_vil = new_var::vil then (
(* [new_var] type is not made of structure *)
assert (is_a_basic_type at);
- Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var);
+ (* XXX
+ Hashtbl.add nenv.lenv_vars new_var.var_name_eff new_var *)
+ );
aux (i+1) (new_vil, new_acc)
in
aux 0 (vil,acc)
@@ -572,46 +569,46 @@ and (expand_var_info: Lic.local_env -> Lic.id_solver -> var_info list * acc ->
in
aux vi.var_type_eff
-let rec (node : Lic.id_solver -> Lic.local_env -> Lic.node_exp -> Lic.node_exp) =
- fun is n_env n ->
-
- let inlist = n.inlist_eff in
- let outlist = n.outlist_eff in
- let acc = ([],[],[]) in
- let inlist, acc = List.fold_left (expand_var_info n_env is) ([],acc) inlist in
- let outlist, acc = List.fold_left (expand_var_info n_env is) ([],acc) outlist in
- let n =
- match n.def_eff with
- | ExternLic
- | MetaOpLic _
- | AbstractLic None -> n
- | AbstractLic (Some pn) ->
- { n with def_eff = AbstractLic (Some (node is n_env pn)) }
- | BodyLic b ->
+let rec (node : local_ctx -> Lic.node_exp -> Lic.node_exp) =
+ fun lctx n ->
+ try
+ let inlist = n.inlist_eff in
+ let outlist = n.outlist_eff in
+ let acc = ([],[],[]) in
+ let inlist, acc = List.fold_left (expand_var_info lctx) ([],acc) inlist in
+ let outlist, acc = List.fold_left (expand_var_info lctx) ([],acc) outlist in
+ let n =
+ match n.def_eff with
+ | ExternLic
+ | MetaOpLic _
+ | AbstractLic None -> n
+ | AbstractLic (Some pn) ->
+ { n with def_eff = AbstractLic (Some (node lctx pn)) }
+ | BodyLic b ->
let loclist = match n.loclist_eff with None -> [] | Some l -> l in
- let loclist, acc = List.fold_left (expand_var_info n_env is) ([],acc) loclist in
- let acc = List.fold_left (expand_eq n_env is) acc b.eqs_eff in
- let acc = List.fold_left (expand_assert n_env is) acc b.asserts_eff in
+ let loclist, acc = List.fold_left (expand_var_info lctx) ([],acc) loclist in
+ let acc = List.fold_left (expand_eq lctx) acc b.eqs_eff in
+ let acc = List.fold_left (expand_assert lctx) acc b.asserts_eff in
let (asserts,neqs, nv) = acc in
let nb = {
eqs_eff = neqs ;
asserts_eff = asserts
}
in
- { n with
- loclist_eff = Some (List.rev_append loclist nv);
- def_eff = BodyLic nb
- }
- in
+ { n with
+ loclist_eff = Some (List.rev_append loclist nv);
+ def_eff = BodyLic nb
+ }
+ in
{ n with
- inlist_eff = List.rev inlist;
- outlist_eff = List.rev outlist;
+ inlist_eff = List.rev inlist;
+ outlist_eff = List.rev outlist;
}
-
+ with Polymorphic -> n
(* exported *)
-let rec (doit : Lic.id_solver -> Lic.local_env -> LicPrg.t -> LicPrg.t) =
- fun id_solver lenv inprg ->
+let rec (doit : LicPrg.t -> LicPrg.t) =
+ fun inprg ->
let outprg = LicPrg.empty in
(** types and constants do not change *)
let outprg = LicPrg.fold_types LicPrg.add_type inprg outprg in
@@ -619,7 +616,15 @@ let rec (doit : Lic.id_solver -> Lic.local_env -> LicPrg.t -> LicPrg.t) =
(** transform nodes *)
let rec (do_node : Lic.node_key -> Lic.node_exp -> LicPrg.t -> LicPrg.t) =
fun nk ne outprg ->
- let ne = node id_solver lenv ne in
+ Verbose.printf ~flag:dbg "#DBG: L2lExpandArrays expands '%s'\n"
+ (Lic.string_of_node_key nk);
+ let lctx = {
+ idgen = LicPrg.fresh_var_id_generator inprg ne;
+ node = ne;
+ prg = outprg;
+ }
+ in
+ let ne = node lctx ne in
LicPrg.add_node nk ne outprg
in
let outprg = LicPrg.fold_nodes do_node inprg outprg in
diff --git a/src/l2lExpandArrays.mli b/src/l2lExpandArrays.mli
index d52a875a..97aa75ae 100644
--- a/src/l2lExpandArrays.mli
+++ b/src/l2lExpandArrays.mli
@@ -1,8 +1,8 @@
-(* Time-stamp: <modified the 13/12/2012 (at 15:58) by Erwan Jahier> *)
+(* Time-stamp: <modified the 17/12/2012 (at 16:28) by Erwan Jahier> *)
(** Expand strutures and arrays *)
-val doit : Lic.id_solver -> Lic.local_env -> LicPrg.t -> LicPrg.t
+val doit : LicPrg.t -> LicPrg.t
diff --git a/src/l2lRmPoly.ml b/src/l2lRmPoly.ml
index 04284c68..502aaba2 100644
--- a/src/l2lRmPoly.ml
+++ b/src/l2lRmPoly.ml
@@ -1,17 +1,9 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:01) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 10:20) by Erwan Jahier> *)
(*
Source 2 source transformation :
élimine polymorphisme et surcharge
-CONDITION :
-- il est préférable d'appeler
- ce module AVANT L2lAliasType,
- sinon on risque d'avoir des alias bizarres, du style :
- 'anynum_4_7_int'
- au lieu de
- 'int_4_7'
- Mais bon, normalement c'est quand même correct ...
*)
open Lxm
@@ -63,22 +55,15 @@ let rec doit (inprg : LicPrg.t) : LicPrg.t =
| MetaOpLic _
| ExternLic -> ne.def_eff
| AbstractLic _ -> assert false
- | BodyLic nb ->
- BodyLic (do_body [] nb)
+ | BodyLic nb -> BodyLic (do_body [] nb)
in
res := LicPrg.add_node k { ne with def_eff = def'} !res
)
(** TRAITEMENT DES BODY *)
- and do_body
- (m: Lic.type_matches)
- (nb: Lic.node_body)
- : Lic.node_body =
+ and do_body (m: Lic.type_matches) (nb: Lic.node_body) : Lic.node_body =
(* parcours les expressions du body
- Ã la recherche d'appel ne noeuds poly *)
- let do_assert a =
- Lxm.flagit (
- do_exp m a.it
- ) a.src
+ Ã la recherche d'appel de noeuds poly *)
+ let do_assert a = Lxm.flagit (do_exp m a.it) a.src
and do_eq eq =
Lxm.flagit (
fst eq.it,
@@ -159,7 +144,9 @@ let rec doit (inprg : LicPrg.t) : LicPrg.t =
(Lic.string_of_type_matches tmatches)
;
let do_var vi =
- { vi with var_type_eff = Lic.subst_matches tmatches vi.var_type_eff }
+ let nt = Lic.subst_matches tmatches vi.var_type_eff in
+ assert(not (Lic.type_is_poly nt));
+ { vi with var_type_eff = nt }
in
(* nouvelle clé unique = ancienne + tmatches *)
let (nid, sargs) = nk in
diff --git a/src/l2lRmPoly.mli b/src/l2lRmPoly.mli
index fbe8bafe..62678f43 100644
--- a/src/l2lRmPoly.mli
+++ b/src/l2lRmPoly.mli
@@ -1,5 +1,15 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:02) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 10:13) by Erwan Jahier> *)
-(** Remove polymorphism and overloading *)
+(** Remove polymorphism and overloading
+
+nb :
+- il est préférable d'appeler
+ ce module AVANT L2lAliasType,
+ sinon on risque d'avoir des alias bizarres, du style :
+ 'anynum_4_7_int'
+ au lieu de
+ 'int_4_7'
+ Mais bon, normalement c'est quand même correct ...
+*)
val doit : LicPrg.t -> LicPrg.t
diff --git a/src/l2lSplit.ml b/src/l2lSplit.ml
index 002ed00e..24fc3bd0 100644
--- a/src/l2lSplit.ml
+++ b/src/l2lSplit.ml
@@ -138,16 +138,16 @@ type split_acc = (Lic.eq_info srcflagged) list * Lic.var_info list
let rec (eq : LicPrg.id_generator -> Lic.eq_info Lxm.srcflagged -> split_acc) =
fun getid { src = lxm_eq ; it = (lhs, rhs) } ->
let n_rhs, (neqs, nlocs) = split_val_exp false true getid rhs in
- { src = lxm_eq ; it = (lhs, n_rhs) }::neqs, nlocs
+ { src = lxm_eq ; it = (lhs, n_rhs) }::neqs, nlocs
and (split_eq_acc :
LicPrg.id_generator -> split_acc -> Lic.eq_info srcflagged -> split_acc) =
fun getid (eqs, locs) equation ->
let (neqs, nlocs) = eq getid equation in
- (split_tuples (eqs@neqs), locs@nlocs)
-
+ (split_tuples (eqs@neqs), locs@nlocs)
+
and (split_val_exp : bool -> bool -> LicPrg.id_generator -> Lic.val_exp ->
- Lic.val_exp * split_acc) =
+ Lic.val_exp * split_acc) =
fun when_flag top_level getid ve ->
(* [when_flag] is true is the call is made from a "when" statement.
We need this flag in order to know if it is necessary to add
@@ -168,171 +168,171 @@ and (split_val_exp : bool -> bool -> LicPrg.id_generator -> Lic.val_exp ->
| CallByPosLic({src=lxm;it=Lic.PREDEF_CALL(AstPredef.FALSE_n,_)}, _)
| CallByPosLic({src=lxm;it=Lic.PREDEF_CALL(AstPredef.ICONST_n _,_)}, _)
| CallByPosLic({src=lxm;it=Lic.PREDEF_CALL(AstPredef.RCONST_n _,_)}, _)
- (* We do not create an intermediary variable for those,
- but
- *)
+ (* We do not create an intermediary variable for those,
+ but
+ *)
-> if not when_flag then
- let clk = ve.ve_clk in
+ let clk = ve.ve_clk in
match (List.hd clk) with
| On(clock,_) ->
- let clk_exp = AstCore.NamedClock (Lxm.flagit clock lxm) in
- { ve with ve_core =
- CallByPosLic({src=lxm;it=Lic.WHEN clk_exp},OperLic [ve])},
- ([],[])
-
+ let clk_exp = AstCore.NamedClock (Lxm.flagit clock lxm) in
+ { ve with ve_core =
+ CallByPosLic({src=lxm;it=Lic.WHEN clk_exp},OperLic [ve])},
+ ([],[])
+
| (ClockVar _) (* should not occur *)
| BaseLic -> ve, ([],[])
- else
- ve, ([],[])
+ else
+ ve, ([],[])
| CallByNameLic (by_name_op_eff, fl) ->
- let lxm = by_name_op_eff.src in
- let fl, eql, vl =
- List.fold_left
- (fun (fl_acc, eql_acc, vl_acc) (fn, fv) ->
- let fv, (eql, vl) = split_val_exp false false getid fv in
- ((fn,fv)::fl_acc, eql@eql_acc, vl@vl_acc)
- )
- ([],[],[])
- fl
- in
- let rhs = { ve with ve_core = CallByNameLic (by_name_op_eff, List.rev fl) } in
- if top_level then
- rhs, (eql, vl)
- else
+ let lxm = by_name_op_eff.src in
+ let fl, eql, vl =
+ List.fold_left
+ (fun (fl_acc, eql_acc, vl_acc) (fn, fv) ->
+ let fv, (eql, vl) = split_val_exp false false getid fv in
+ ((fn,fv)::fl_acc, eql@eql_acc, vl@vl_acc)
+ )
+ ([],[],[])
+ fl
+ in
+ let rhs = { ve with ve_core = CallByNameLic (by_name_op_eff, List.rev fl) } in
+ if top_level then
+ rhs, (eql, vl)
+ else
(* create the var for the current call *)
- let clk_l = ve.ve_clk in
- let typ_l = ve.ve_typ in
- let nv_l = List.map2 (new_var getid) typ_l clk_l in
- let nve = match nv_l with
- | [nv] -> { ve with ve_core =
- CallByPosLic(
- Lxm.flagit (Lic.VAR_REF (nv.var_name_eff)) lxm,
- OperLic []
- )}
- | _ -> assert false
- in
- let lpl = List.map (fun nv -> LeftVarLic(nv, lxm)) nv_l in
- let eq = Lxm.flagit (lpl, rhs) lxm in
- nve, (eql@[eq], vl@nv_l)
+ let clk_l = ve.ve_clk in
+ let typ_l = ve.ve_typ in
+ let nv_l = List.map2 (new_var getid) typ_l clk_l in
+ let nve = match nv_l with
+ | [nv] -> { ve with ve_core =
+ CallByPosLic(
+ Lxm.flagit (Lic.VAR_REF (nv.var_name_eff)) lxm,
+ OperLic []
+ )}
+ | _ -> assert false
+ in
+ let lpl = List.map (fun nv -> LeftVarLic(nv, lxm)) nv_l in
+ let eq = Lxm.flagit (lpl, rhs) lxm in
+ nve, (eql@[eq], vl@nv_l)
-
+
| CallByPosLic(by_pos_op_eff, OperLic vel) -> (
(* recursively split the arguments *)
- let lxm = by_pos_op_eff.src in
- let (rhs, (eql,vl)) =
- match by_pos_op_eff.it with
- (* for WITH and HAT, a particular treatment is done because
- the val_exp is attached to them *)
- | Lic.WITH(ve) ->
- let ve, (eql, vl) = split_val_exp false false getid ve in
- let by_pos_op_eff = Lxm.flagit (Lic.WITH(ve)) lxm in
- let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
- rhs, (eql, vl)
-
- | Lic.HAT(i,ve) ->
- let ve, (eql, vl) = split_val_exp false false getid ve in
- let by_pos_op_eff = Lxm.flagit (Lic.HAT(i, ve)) lxm in
- let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
- rhs, (eql, vl)
-
- | Lic.WHEN ve -> (* should we create a var for the clock? *)
- let vel,(eql, vl) = split_val_exp_list true false getid vel in
- let by_pos_op_eff = Lxm.flagit (Lic.WHEN(ve)) lxm in
- let rhs = CallByPosLic(by_pos_op_eff, OperLic vel) in
- rhs, (eql, vl)
-
- | Lic.ARRAY vel ->
- let vel, (eql, vl) = split_val_exp_list false false getid vel in
- let by_pos_op_eff = Lxm.flagit (Lic.ARRAY(vel)) lxm in
- let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
- rhs, (eql, vl)
-
- | _ ->
- let vel, (eql, vl) = split_val_exp_list false false getid vel in
- let rhs = CallByPosLic(by_pos_op_eff, OperLic vel) in
- rhs, (eql, vl)
- in
- let rhs = { ve with ve_core = rhs } in
- if top_level || by_pos_op_eff.it = TUPLE then
- rhs, (eql, vl)
- else
+ let lxm = by_pos_op_eff.src in
+ let (rhs, (eql,vl)) =
+ match by_pos_op_eff.it with
+ (* for WITH and HAT, a particular treatment is done because
+ the val_exp is attached to them *)
+ | Lic.WITH(ve) ->
+ let ve, (eql, vl) = split_val_exp false false getid ve in
+ let by_pos_op_eff = Lxm.flagit (Lic.WITH(ve)) lxm in
+ let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
+ rhs, (eql, vl)
+
+ | Lic.HAT(i,ve) ->
+ let ve, (eql, vl) = split_val_exp false false getid ve in
+ let by_pos_op_eff = Lxm.flagit (Lic.HAT(i, ve)) lxm in
+ let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
+ rhs, (eql, vl)
+
+ | Lic.WHEN ve -> (* should we create a var for the clock? *)
+ let vel,(eql, vl) = split_val_exp_list true false getid vel in
+ let by_pos_op_eff = Lxm.flagit (Lic.WHEN(ve)) lxm in
+ let rhs = CallByPosLic(by_pos_op_eff, OperLic vel) in
+ rhs, (eql, vl)
+
+ | Lic.ARRAY vel ->
+ let vel, (eql, vl) = split_val_exp_list false false getid vel in
+ let by_pos_op_eff = Lxm.flagit (Lic.ARRAY(vel)) lxm in
+ let rhs = CallByPosLic(by_pos_op_eff, OperLic []) in
+ rhs, (eql, vl)
+
+ | _ ->
+ let vel, (eql, vl) = split_val_exp_list false false getid vel in
+ let rhs = CallByPosLic(by_pos_op_eff, OperLic vel) in
+ rhs, (eql, vl)
+ in
+ let rhs = { ve with ve_core = rhs } in
+ if top_level || by_pos_op_eff.it = TUPLE then
+ rhs, (eql, vl)
+ else
(* create the var for the current call *)
- let clk_l = ve.ve_clk in
- let typ_l = ve.ve_typ in
- let nv_l = List.map2 (new_var getid) typ_l clk_l in
-
- let nve =
- match nv_l with
- | [nv] -> {
- ve_typ = [nv.var_type_eff];
- ve_clk = clk_l;
- ve_core = CallByPosLic(
- Lxm.flagit (Lic.VAR_REF (nv.var_name_eff)) lxm,
- OperLic [])
- }
- | _ -> {
- ve_typ = List.map (fun v -> v.var_type_eff) nv_l;
- ve_clk = clk_l;
- ve_core = CallByPosLic(
- Lxm.flagit Lic.TUPLE lxm,
- OperLic
- (List.map (
- fun nv ->
- let nnv = {
- ve_core = CallByPosLic
- (Lxm.flagit
- (Lic.VAR_REF (nv.var_name_eff)) lxm,
- OperLic []);
- ve_typ = [nv.var_type_eff];
- ve_clk = [snd nv.var_clock_eff]
- }
- in
- nnv
- )
- nv_l
- )
- )
- }
- in
- let lpl = List.map (fun nv -> LeftVarLic(nv, lxm)) nv_l in
- let eq = Lxm.flagit (lpl, rhs) lxm in
- nve, (eql@[eq], vl@nv_l)
- )
+ let clk_l = ve.ve_clk in
+ let typ_l = ve.ve_typ in
+ let nv_l = List.map2 (new_var getid) typ_l clk_l in
+
+ let nve =
+ match nv_l with
+ | [nv] -> {
+ ve_typ = [nv.var_type_eff];
+ ve_clk = clk_l;
+ ve_core = CallByPosLic(
+ Lxm.flagit (Lic.VAR_REF (nv.var_name_eff)) lxm,
+ OperLic [])
+ }
+ | _ -> {
+ ve_typ = List.map (fun v -> v.var_type_eff) nv_l;
+ ve_clk = clk_l;
+ ve_core = CallByPosLic(
+ Lxm.flagit Lic.TUPLE lxm,
+ OperLic
+ (List.map (
+ fun nv ->
+ let nnv = {
+ ve_core = CallByPosLic
+ (Lxm.flagit
+ (Lic.VAR_REF (nv.var_name_eff)) lxm,
+ OperLic []);
+ ve_typ = [nv.var_type_eff];
+ ve_clk = [snd nv.var_clock_eff]
+ }
+ in
+ nnv
+ )
+ nv_l
+ )
+ )
+ }
+ in
+ let lpl = List.map (fun nv -> LeftVarLic(nv, lxm)) nv_l in
+ let eq = Lxm.flagit (lpl, rhs) lxm in
+ nve, (eql@[eq], vl@nv_l)
+ )
and (split_val_exp_list : bool ->
- bool -> LicPrg.id_generator -> Lic.val_exp list -> Lic.val_exp list * split_acc) =
+ bool -> LicPrg.id_generator -> Lic.val_exp list -> Lic.val_exp list * split_acc) =
fun when_flag top_level getid vel ->
let vel, accl =
List.split (List.map (split_val_exp when_flag top_level getid) vel)
in
let eqll,vll = List.split accl in
let eql, vl = List.flatten eqll, List.flatten vll in
- (vel,(eql,vl))
+ (vel,(eql,vl))
and split_node (getid: LicPrg.id_generator) (n: Lic.node_exp) : Lic.node_exp =
- Verbose.printf ~flag:dbg "*** Splitting node %s\n"
- (LicDump.string_of_node_key_iter n.node_key_eff);
- let res = match n.def_eff with
- | ExternLic
- | MetaOpLic _
- | AbstractLic None -> n
- | AbstractLic (Some pn) ->
+ Verbose.printf ~flag:dbg "*** Splitting node %s\n"
+ (LicDump.string_of_node_key_iter n.node_key_eff);
+ let res = match n.def_eff with
+ | ExternLic
+ | MetaOpLic _
+ | AbstractLic None -> n
+ | AbstractLic (Some pn) ->
{ n with def_eff = AbstractLic (Some (split_node getid pn)) }
- | BodyLic b ->
+ | BodyLic b ->
let loc = match n.loclist_eff with None -> [] | Some l -> l in
let (neqs, nv) = List.fold_left (split_eq_acc getid) ([], loc) b.eqs_eff in
let asserts = List.map (fun x -> x.it) b.asserts_eff in
let lxm_asserts = List.map (fun x -> x.src) b.asserts_eff in
let nasserts,(neqs_asserts,nv_asserts) =
- split_val_exp_list false true getid asserts
+ split_val_exp_list false true getid asserts
in
let nasserts = List.map2 Lxm.flagit nasserts lxm_asserts in
let (neqs, nv) = (neqs@neqs_asserts, nv@nv_asserts) in
let nb = { eqs_eff = neqs ; asserts_eff = nasserts } in
- { n with loclist_eff = Some nv; def_eff = BodyLic nb }
- in
- res
+ { n with loclist_eff = Some nv; def_eff = BodyLic nb }
+ in
+ res
let rec doit (inprg : LicPrg.t) : LicPrg.t =
(* n.b. on fait un minumum d'effet de bord pour
@@ -354,6 +354,9 @@ let rec doit (inprg : LicPrg.t) : LicPrg.t =
(** TRAITE LES NOEUDS : *)
let rec do_node k (ne:Lic.node_exp) =
(* On passe en parametre un constructeur de nouvelle variable locale *)
+ Verbose.printf ~flag:dbg
+ "#DBG: split equations of '%s'\n"
+ (Lic.string_of_node_key k);
let getid = LicPrg.fresh_var_id_generator inprg ne in
let ne' = split_node getid ne in
res := LicPrg.add_node k ne' !res
diff --git a/src/licPrg.ml b/src/licPrg.ml
index 39eb4c51..a7e26248 100644
--- a/src/licPrg.ml
+++ b/src/licPrg.ml
@@ -62,6 +62,17 @@ let find_type this k = ItemKeyMap.find k this.types
let find_const this k = ItemKeyMap.find k this.consts
let find_node this k = NodeKeyMap.find k this.nodes
+let (find_var : Ident.t -> Lic.node_exp -> Lic.var_info option) =
+ fun id ne ->
+ let name_matches vi = vi.Lic.var_name_eff = id in
+ try Some (List.find name_matches ne.Lic.inlist_eff) with Not_found ->
+ try Some (List.find name_matches ne.Lic.outlist_eff) with Not_found ->
+ match ne.Lic.loclist_eff with
+ | None -> None
+ | Some vil ->
+ try Some (List.find name_matches vil)
+ with Not_found -> None
+
(** PARCOURS *)
let fold_consts (f: Lic.item_key -> Lic.const -> 'a -> 'a) (this:t) (accin:'a) : 'a =
@@ -154,30 +165,30 @@ let to_file (oc: out_channel) (this:t) =
type id_generator = string -> string
let fresh_var_id_generator : t -> Lic.node_exp -> id_generator =
-fun prg ne ->
- let cpt = ref 0 in
- let forbidden = Hashtbl.create 100 in
- let _ = iter_consts (fun i c -> match c with
+ fun prg ne ->
+ let cpt = ref 0 in
+ let forbidden = Hashtbl.create 100 in
+ let _ = iter_consts (fun i c -> match c with
| Lic.Extern_const_eff (s,_)
| Lic.Abstract_const_eff (s,_,_,_)
| Lic.Enum_const_eff (s,_) -> Hashtbl.add forbidden (snd s) ()
| _ -> ()
- ) prg in
- let dovar vi = Hashtbl.add forbidden vi.Lic.var_name_eff () in
- let _ = List.iter dovar ne.Lic.inlist_eff in
- let _ = List.iter dovar ne.Lic.outlist_eff in
- let _ = match ne.Lic.loclist_eff with
+ ) prg in
+ let dovar vi = Hashtbl.add forbidden vi.Lic.var_name_eff () in
+ let _ = List.iter dovar ne.Lic.inlist_eff in
+ let _ = List.iter dovar ne.Lic.outlist_eff in
+ let _ = match ne.Lic.loclist_eff with
| Some l -> List.iter dovar l | None -> ()
- in
- let rec dogen (pfx: string) : string =
+ in
+ let rec dogen (pfx: string) : string =
let id = Printf.sprintf "%s%02d" pfx !cpt in
incr cpt;
try (
- let _ = Hashtbl.find forbidden id in
- dogen pfx
+ let _ = Hashtbl.find forbidden id in
+ dogen pfx
) with Not_found -> (
- Hashtbl.add forbidden id ();
- id
+ Hashtbl.add forbidden id ();
+ id
)
- in
- dogen
+ in
+ dogen
diff --git a/src/licPrg.mli b/src/licPrg.mli
index 50fc8a50..2fe9641d 100644
--- a/src/licPrg.mli
+++ b/src/licPrg.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 11:14) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 14:25) by Erwan Jahier> *)
(** The data structure resulting from the compilation process *)
@@ -43,10 +43,14 @@ val iter_nodes : (Lic.node_key -> Lic.node_exp -> unit) -> t -> unit
val to_file : out_channel -> t -> unit
+(* Raises Not_found. *)
val find_type : t -> Lic.item_key -> Lic.type_
val find_const : t -> Lic.item_key -> Lic.const
val find_node : t -> Lic.node_key -> Lic.node_exp
+
+val find_var : Ident.t -> Lic.node_exp -> Lic.var_info option
+
val fresh_type_id : t -> Ident.pack_name -> string -> Ident.long
(** utile : générateur de noms de flow 'frais'
diff --git a/src/main.ml b/src/main.ml
index e3e40dd9..56e3e31c 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 10:45) by Erwan Jahier> *)
+(* Time-stamp: <modified the 17/12/2012 (at 18:08) by Erwan Jahier> *)
@@ -232,12 +232,12 @@ let main = (
my_exit 1
| Assert_failure (file, line, col) ->
prerr_string (
- "\n*** oops: an internal error (lus2lic) occurred in file "^ file ^
- ", line " ^ (string_of_int line) ^ ", column " ^
+ "\n*** oops: lus2lic internal error\n\tFile \""^ file ^
+ "\", line " ^ (string_of_int line) ^ ", column " ^
(string_of_int col) ^ "\n*** when compiling lustre program" ^
(if List.length !Global.infiles > 1 then "s " else " ") ^
(String.concat ", " !Global.infiles) ^ "\n"^
- "\n*** You migth want to sent a bug report to jahier@imag.fr\n") ;
+ "\n*** You migth want to sent a bug report to "^Version.maintainer ^"\n") ;
my_exit 2
(* | Compile_node_error(nkey,lxm,msg) -> ( *)
diff --git a/src/mainArgs.ml b/src/mainArgs.ml
index b7ec488d..b1eecee2 100644
--- a/src/mainArgs.ml
+++ b/src/mainArgs.ml
@@ -229,7 +229,7 @@ let mkoptab (opt:t) : unit = (
(Arg.Set Global.nonreg_test)
["(internal)"]
;
- (* misc degub flag *)
+ (* misc debug flag *)
mkopt opt ~hide:true
["-dbg"; "--debug"]
(Arg.Symbol
diff --git a/todo.org b/todo.org
index e8e61671..ffbbb645 100644
--- a/todo.org
+++ b/todo.org
@@ -5,7 +5,7 @@
* Urgent
** TODO rebrancher le nodeExpand.ml et structArrayExpand.ml
- SCHEDULED: <2012-12-10 Mon>
+ SCHEDULED: <2012-12-14 Fri>
- State "TODO" from "" [2012-12-10 Mon 16:55]
file:src/l2lExpandNodes.mli
@@ -13,9 +13,15 @@ file:src/l2lExpandArrays.mli
que Pascal les a débranché lors de son ménage d'été.
+** TODO Pascal a shunté mon LicName dans split. Avait-il (une bonne) raison ?
+ SCHEDULED: <2012-12-17 Mon>
+ - State "TODO" from "" [2012-12-17 Mon 16:37]
+
+par ex, file:~/lus2lic/src/l2lExpandArrays.ml::50
+dois-je faire comme lui ou comme avant ?
** TODO Refaire marcher les tests de non-reg qui sont cassés
- SCHEDULED: <2012-12-10 Mon>
+ SCHEDULED: <2012-12-14 Fri>
suites aux modifs de Pascal de l'été 2012
- State "TODO" from "" [2012-10-26 Fri 14:59]
--
GitLab