From 43dc79f09a5f462c7cf0d8f2eb30b123ba63e7db Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Thu, 20 Dec 2012 09:49:34 +0100
Subject: [PATCH] Plug back Meta operator Expansion.
---
Makefile | 2 +
src/compile.ml | 6 +-
src/l2lExpandArrays.ml | 8 +-
src/l2lExpandMetaOp.ml | 391 ++++++++++++++++++++++++++++++++++++++++
src/l2lExpandMetaOp.mli | 6 +
src/l2lRmPoly.ml | 246 +++++++++++++------------
src/lic.ml | 78 ++++----
src/licPrg.ml | 6 +-
src/licPrg.mli | 11 +-
src/uglyStuff.ml | 16 +-
10 files changed, 588 insertions(+), 182 deletions(-)
create mode 100644 src/l2lExpandMetaOp.ml
create mode 100644 src/l2lExpandMetaOp.mli
diff --git a/Makefile b/Makefile
index 1ae7f6aa..276090c4 100644
--- a/Makefile
+++ b/Makefile
@@ -92,6 +92,8 @@ SOURCES = \
$(OBJDIR)/l2lExpandArrays.ml \
$(OBJDIR)/l2lExpandNodes.mli \
$(OBJDIR)/l2lExpandNodes.ml \
+ $(OBJDIR)/l2lExpandMetaOp.ml \
+ $(OBJDIR)/l2lExpandMetaOp.mli \
$(OBJDIR)/l2lRmPoly.mli \
$(OBJDIR)/l2lRmPoly.ml \
$(OBJDIR)/l2lAliasType.mli \
diff --git a/src/compile.ml b/src/compile.ml
index 09747369..98bc64af 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 18/12/2012 (at 14:39) by Erwan Jahier> *)
+(* Time-stamp: <modified the 19/12/2012 (at 17:23) by Erwan Jahier> *)
open Lxm
@@ -44,6 +44,10 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
let zelic = L2lRmPoly.doit zelic in
(* alias des types array *)
let zelic = L2lAliasType.doit zelic in
+ let zelic = if not !Global.inline_iterator then zelic else
+ (* Array and struct expansion: to do after polymorphism elimination *)
+ L2lExpandMetaOp.doit zelic
+ in
let zelic = if not !Global.one_op_per_equation then zelic else
(* Split des equations (1 eq = 1 op) *)
L2lSplit.doit zelic
diff --git a/src/l2lExpandArrays.ml b/src/l2lExpandArrays.ml
index 0be003de..00b1a984 100644
--- a/src/l2lExpandArrays.ml
+++ b/src/l2lExpandArrays.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 18/12/2012 (at 14:46) by Erwan Jahier> *)
+(** Time-stamp: <modified the 18/12/2012 (at 15:54) 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...
@@ -292,7 +292,11 @@ and (var_trees_of_val_exp :
)
| CONST_REF idl -> (
try
- let const = LicPrg.find_const lctx.prg idl in
+ let const =
+ match LicPrg.find_const lctx.prg idl with
+ | Some c -> c
+ | None -> assert false
+ in
let s, ve_const =
UnifyClock.const_to_val_eff lxm true UnifyClock.empty_subst const
in
diff --git a/src/l2lExpandMetaOp.ml b/src/l2lExpandMetaOp.ml
new file mode 100644
index 00000000..0f9c1534
--- /dev/null
+++ b/src/l2lExpandMetaOp.ml
@@ -0,0 +1,391 @@
+(** Time-stamp: <modified the 20/12/2012 (at 09:49) by Erwan Jahier> *)
+
+open Lxm
+open Lic
+
+let dbg=Some (Verbose.get_flag "ei")
+
+(* pack useful info into a single struct *)
+type local_ctx = {
+ idgen : LicPrg.id_generator;
+ node : Lic.node_exp;
+ prg : LicPrg.t;
+}
+
+(********************************************************************************)
+(* stuff to create fresh var names. *)
+let new_var str lctx type_eff clock_eff =
+ let id = Ident.of_string (LicName.new_local_var str) in
+ let var =
+ {
+ var_name_eff = id;
+ var_nature_eff = AstCore.VarLocal;
+ var_number_eff = -1; (* this field is used only for i/o.
+ Should i rather put something sensible there ? *)
+ var_type_eff = type_eff;
+ var_clock_eff = id, clock_eff;
+ }
+ in
+ var
+
+(********************************************************************************)
+(* A small util function followed by a quick unit test. *)
+let rec fill i size = if i >= size then [] else i::(fill (i+1) size)
+let _ = assert (fill 0 5 = [0;1;2;3;4])
+
+let rec (list_map3:
+ ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list) =
+ fun f l1 l2 l3 ->
+ match (l1, l2, l3) with
+ | ([], [], []) -> []
+ | (e1::t1, e2::t2, e3::t3) -> (f e1 e2 e3)::(list_map3 f t1 t2 t3)
+ | _ -> (* should not occur *)
+ print_string "*** list_map3 called with lists of different size.\n";
+ flush stdout;
+ assert false
+(********************************************************************************)
+(* Some utililities to build Lic expressions *)
+
+(* We generate code that does not correspond to any use source one *)
+let lxm = Lxm.dummy "no_source"
+
+let (val_exp_of_var_info : Lic.var_info -> Lic.val_exp) =
+ fun vi ->
+ {
+ ve_core = CallByPosLic({src=lxm;it=Lic.VAR_REF vi.var_name_eff}, OperLic []);
+ ve_typ = [vi.var_type_eff];
+ ve_clk = [snd vi.var_clock_eff];
+ }
+
+let (val_exp_of_int : int -> Lic.val_exp) =
+ fun i ->
+ let id_of_int i = AstPredef.ICONST_n(Ident.of_string (string_of_int i)) in
+ {
+ ve_clk = [BaseLic];
+ ve_typ = [Int_type_eff];
+ ve_core = CallByPosLic({it=PREDEF_CALL(id_of_int i,[]);src=lxm},OperLic[])
+ }
+
+let rec (elt_type_of_array : Lic.type_ -> Lic.type_) =
+ function
+ | Array_type_eff(t, _) -> t
+ | Abstract_type_eff(_,t) -> elt_type_of_array t
+ | _ -> assert false
+
+let (array_var_to_val_exp : int -> var_info -> val_exp) =
+ fun i vi ->
+ (* vi holds x of type array and returns x.[i] *)
+ let t_elt = elt_type_of_array vi.var_type_eff in
+ let op_flg = {src = lxm ; it = ARRAY_ACCES(i)} in
+ {
+ ve_core = CallByPosLic(op_flg, OperLic [val_exp_of_var_info vi]);
+ ve_typ = [t_elt];
+ ve_clk = [snd vi.var_clock_eff];
+ }
+
+let (op_to_val_exp : AstPredef.op -> val_exp -> val_exp -> val_exp) =
+ fun op ve1 ve2 ->
+ let op = { it = PREDEF_CALL(op,[]) ; src = lxm } in
+ {
+ ve_clk = ve1.ve_clk;
+ ve_typ = ve1.ve_typ;
+ ve_core = CallByPosLic(op, OperLic [ve1; ve2])
+ }
+let (ite_to_val_exp : val_exp -> val_exp -> val_exp -> val_exp) =
+ fun ve1 ve2 ve3 ->
+ let ite_op = { it = PREDEF_CALL(AstPredef.IF_n,[]); src = lxm } in
+ {
+ ve_clk = ve2.ve_clk;
+ ve_typ = ve2.ve_typ;
+ ve_core = CallByPosLic(ite_op, OperLic [ve1; ve2; ve3])
+ }
+
+let (array_var_to_left : int -> var_info -> Lic.left) =
+ fun i vi ->
+ let lp = LeftVarLic(vi,lxm) in
+ let t_elt = elt_type_of_array vi.var_type_eff in
+ LeftArrayLic(lp,i,t_elt)
+
+
+let (create_fillred_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+ fun lctx sargs ->
+ (* Given
+ - a node n of type : tau * tau_1 * ... * tau_n -> tau * teta_1 * ... * teta_l
+ - a integer c
+
+ the fillred expression has the profile:
+ tau * tau_1^c * ... * tau_n^c -> tau * teta_1^c * ... * teta_l^c
+ *)
+ let iter_node,c = match sargs with
+ | [ConstStaticArgLic(_,Int_const_eff(c)) ; NodeStaticArgLic(_,_node_key)]
+ | [NodeStaticArgLic(_,_node_key) ; ConstStaticArgLic(_,Int_const_eff(c))] ->
+ _node_key,c
+ | _ -> assert false
+ in
+ let iter_node = Lxm.flagit iter_node lxm in
+ (*
+ Hence:
+ node(acc_in:tau; X1:tau_1^c ; ... ; Xn:tau_n^c)
+ returns (acc_out:tau; Y1:teta_1^c; ... ; Yl:teta_l^c) = fillred<<n,c>>;
+ *)
+ let (acc_in : var_info) = List.hd lctx.node.Lic.inlist_eff in
+ let (y1_yl : var_info list) = List.tl lctx.node.Lic.inlist_eff in
+ let (acc_out: var_info) = List.hd lctx.node.Lic.outlist_eff in
+ let (x1_xn : var_info list) = List.tl lctx.node.Lic.outlist_eff in
+ (*
+ can be defined like this:
+ node(acc_in:tau; X1:tau_1^c ; ... ; Xn:tau_n^c)
+ returns (acc_out:tau; Y1 : teta1^c; ... ; Yl: teta_l^c) =
+ var
+ acc_1, ..., acc_c-2 : tau;
+ let
+
+ acc_1, Y1[0], ... ,Yl[0] = n(acc_in,X1[0], ... ,Xk[0]);
+ acc_2, Y1[1], ... ,Yl[1] = n(acc_1, X1[1], ... ,Xk[1]);
+ ...
+ acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i]);
+ ...
+ acc_out, Y1[c-1], ... ,Yl[c-1] = n(acc_c-1,X1[c-1], ... ,Xk[c-1]);
+
+ « for all i = 0, ..., c-1 »
+ acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i])
+ tel
+ *)
+ let index_list = fill 0 c in
+ (* Building this list "acc_left_list" as [acc_1, ..., acc_c-2, acc_out] *)
+ let type_exp,clock_exp = acc_in.var_type_eff, snd acc_in.var_clock_eff in
+ let (acc_vars : var_info list) =
+ let rec f i acc = if i = 0 then acc else
+ f (i-1) ((new_var "acc" lctx type_exp clock_exp)::acc)
+ in
+ List.rev(f (c-1) [])
+ in
+ let (acc_left_list : left list) =
+ (List.map (fun vi -> LeftVarLic(vi,lxm)) (acc_vars@[acc_out]))
+ in
+ (* Ditto for rigth part : [acc_in, acc_1, ..., acc_c-1]*)
+ let (acc_rigth_list : val_exp list) =
+ List.map val_exp_of_var_info (acc_in::acc_vars)
+ in
+ let neqs =
+ (*
+ So now we build those equations ;
+ acc_1, Y1[0], ... ,Yl[0] = n(acc_in,X1[0], ... ,Xk[0]);
+ acc_2, Y1[1], ... ,Yl[1] = n(acc_1, X1[1], ... ,Xk[1]);
+ ...
+ acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i]);
+ ...
+ acc_out, Y1[c-1], ... ,Yl[c-1] = n(acc_c-1,X1[c-1], ... ,Xk[c-1]);
+ *)
+ list_map3
+ (fun i acc_left acc_rigth ->
+ let (xi_j:val_exp list) = (* X1[i], ... ,Xn[i] *)
+ List.map (array_var_to_val_exp i) y1_yl
+ in
+ let args = acc_rigth::xi_j in
+ let (yi_k : left list) = (* Y1[i], ... ,Yl[i] *)
+ List.map (array_var_to_left i) x1_xn
+ in
+ let lhs = acc_left::yi_k in
+ let cl =
+ List.map (fun l -> snd (Lic.var_info_of_left l).var_clock_eff) lhs
+ in
+ let rhs = {
+ ve_typ = List.map Lic.type_of_left lhs;
+ ve_clk = cl;
+ ve_core = CallByPosLic({src=lxm;it=(CALL iter_node)}, OperLic args) }
+ in
+ let eq = { src = lxm ; it = (lhs, rhs) } in
+ eq
+ )
+ index_list
+ acc_left_list
+ acc_rigth_list
+ in
+ { asserts_eff = []; eqs_eff = List.rev neqs }, acc_vars
+
+let (create_map_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+ fun lctx sargs ->
+ (* Given
+ - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+ - and an integer c
+
+ The profile of map<<node,c>> is:
+ tau_1^c * ... * tau_n^c -> teta_1^c * ... * teta_l^c
+ and
+
+ Y1, ... ,Yl = map<<node; c>>(X1,...,Xk)
+ <=>
+ for all i = 0, ..., c-1; (Y1[i], ... ,Yl[i]) = N(X_1[i], ... ,X_k[i])
+ *)
+ let iter_node,c = match sargs with
+ | [ConstStaticArgLic(_,Int_const_eff(c)) ; NodeStaticArgLic(_,_node_key)]
+ | [NodeStaticArgLic(_,_node_key) ; ConstStaticArgLic(_,Int_const_eff(c))] ->
+ _node_key,c
+ | _ -> assert false
+ in
+ let iter_node = Lxm.flagit iter_node lxm in
+ let (y1_yl : var_info list) = lctx.node.Lic.inlist_eff in
+ let (x1_xn : var_info list) = lctx.node.Lic.outlist_eff in
+ let index_list = fill 0 c in
+ let neqs =
+ List.map
+ (fun i ->
+ let (xi_j:val_exp list) = (* X1[i], ... ,Xn[i] *)
+ List.map (array_var_to_val_exp i) y1_yl
+ in
+ let (lhs : left list) = (* Y1[i], ... ,Yl[i] *)
+ List.map (array_var_to_left i) x1_xn
+ in
+ let cl =
+ List.map (fun l -> snd (Lic.var_info_of_left l).var_clock_eff) lhs
+ in
+ let rhs = {
+ ve_typ = List.map Lic.type_of_left lhs;
+ ve_clk = cl;
+ ve_core = CallByPosLic({src=lxm;it=(CALL iter_node)}, OperLic xi_j) }
+ in
+ let eq = { src = lxm ; it = (lhs, rhs) } in
+ eq
+ )
+ index_list
+ in
+ { asserts_eff = []; eqs_eff = List.rev neqs }, []
+
+let (create_boolred_body: local_ctx -> int -> int -> int -> Lic.node_body * var_info list) =
+ fun lctx i j k ->
+ (* Given - 3 integers i, j, k boolred<<i,j,k>> has the profile: bool^n -> bool
+ and is defined by
+ node toto = boolred<<i,j,k>>(tab);
+ <=>
+ node toto(tab:bool^n) returns (res:bool);
+ var
+ cpt:int;
+ let
+ cpt = (if tab[0] then 1 else 0) + ... + (if tab[k-1] then 1 else 0);
+ res = i <= cpt && cpt <= j;
+ tel
+ *)
+ assert(0 <= i && i <= j && j <= k && k>0);
+ let (tab_vi : var_info) = match lctx.node.Lic.inlist_eff with
+ | [vi] -> vi
+ | _ -> assert false
+ in
+ let (res_vi : var_info) = match lctx.node.Lic.outlist_eff with
+ | [vi] -> vi
+ | _ -> assert false
+ in
+ let (cpt_vi : var_info) = new_var "cpt" lctx Int_type_eff BaseLic in
+ let cpt_left = LeftVarLic (cpt_vi,lxm) in
+ let zero = val_exp_of_int 0
+ and one = val_exp_of_int 1 in
+ let index_list = fill 0 k in (* [0;1; ...;k-1]*)
+ let (ite_list:Lic.val_exp list) = List.map
+ (fun i -> (* returns [if A[i] then 1 else 0]_i=0,k-1 *)
+ let tab_ve_i = array_var_to_val_exp i tab_vi in
+ ite_to_val_exp tab_ve_i one zero
+ )
+ index_list
+ in
+ let cpt_rigth = List.fold_left (op_to_val_exp AstPredef.IPLUS_n)
+ (List.hd ite_list) (List.tl ite_list) in
+ let res_left = LeftVarLic (res_vi,lxm) in
+ let res_rigth = (* i <= cpt && cpt <= j; *)
+ let i_eff = val_exp_of_int i in
+ let j_eff = val_exp_of_int j in
+ let cpt_eff = val_exp_of_var_info cpt_vi in
+ let i_inf_cpt = op_to_val_exp AstPredef.LTE_n i_eff cpt_eff in
+ let cpt_inf_j = op_to_val_exp AstPredef.LTE_n cpt_eff j_eff in
+ op_to_val_exp AstPredef.AND_n i_inf_cpt cpt_inf_j
+ in
+ let cpt_eq = { src = lxm ; it = ([cpt_left], cpt_rigth) } in
+ let res_eq = { src = lxm ; it = ([res_left], res_rigth) } in
+ {
+ asserts_eff = [];
+ eqs_eff = [cpt_eq; res_eq]
+ }, [cpt_vi]
+
+let (create_condact_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+ fun lctx sargs ->
+ assert false (* XXX finish me! *)
+
+let (create_merge_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+ fun lctx sargs ->
+ assert false (* XXX finish me! *)
+
+let rec (create_meta_op_body: local_ctx -> Lic.node_key -> Lic.node_body * var_info list) =
+ fun lctx (nk,sargs) ->
+ match nk with
+ | "Lustre", "fill"
+ | "Lustre", "red"
+ | "Lustre", "fillred" -> create_fillred_body lctx sargs
+ | "Lustre", "map" -> create_map_body lctx sargs
+ | "Lustre", "boolred" -> (
+ let (i,j,k) =
+ match sargs with
+ | [ConstStaticArgLic(_, Int_const_eff i);
+ ConstStaticArgLic(_, Int_const_eff j);
+ ConstStaticArgLic(_, Int_const_eff k)
+ ] ->
+ (i,j,k)
+ | _ -> assert false
+ in
+ create_boolred_body lctx i j k
+ )
+ | "Lustre", "diese" -> (
+ (* a diese is a particular kind of boolred:
+ #(A,...,an) = boolred(1,1,n)([a1,...,an])
+ *)
+ let n = List.length lctx.node.Lic.inlist_eff in
+ create_boolred_body lctx 1 1 n
+ )
+ | "Lustre", "nor" -> (
+ (* a nor is a particular kind of boolred too:
+ nor(A,...,an) = boolred(0,0,n)([a1,...,an])
+ *)
+ let n = List.length lctx.node.Lic.inlist_eff in
+ create_boolred_body lctx 0 0 n
+ )
+ | "Lustre", "condact" -> create_condact_body lctx sargs
+ | "Lustre", "merge" -> create_merge_body lctx sargs
+ | _,_ -> assert false
+
+
+let rec (node : local_ctx -> Lic.node_exp -> Lic.node_exp) =
+ fun lctx n ->
+ let sonk = Lic.string_of_node_key in
+ Verbose.printf ~flag:dbg "#DBG: L2lInlineMetaOp %s\n" (sonk n.node_key_eff);
+ match n.def_eff with
+ | MetaOpLic nk ->
+ let nbody, nlocs = create_meta_op_body lctx nk in
+ { n with
+ def_eff = BodyLic nbody;
+ loclist_eff = Some nlocs;
+ }
+ | ExternLic
+ | AbstractLic None -> n
+ | AbstractLic (Some pn) ->
+ { n with def_eff = AbstractLic (Some (node lctx pn)) }
+ | BodyLic b -> n
+
+(* exported *)
+and (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
+ let outprg = LicPrg.fold_consts LicPrg.add_const inprg outprg in
+ (** transform nodes *)
+ let rec (do_node : Lic.node_key -> Lic.node_exp -> LicPrg.t -> LicPrg.t) =
+ fun nk ne outprg ->
+ 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
+ outprg
diff --git a/src/l2lExpandMetaOp.mli b/src/l2lExpandMetaOp.mli
new file mode 100644
index 00000000..87fe7758
--- /dev/null
+++ b/src/l2lExpandMetaOp.mli
@@ -0,0 +1,6 @@
+(** Time-stamp: <modified the 19/12/2012 (at 17:26) by Erwan Jahier> *)
+
+
+(** Expand Meta operators (red, map, etc.) *)
+
+val doit : LicPrg.t -> LicPrg.t
diff --git a/src/l2lRmPoly.ml b/src/l2lRmPoly.ml
index 502aaba2..72ed3785 100644
--- a/src/l2lRmPoly.ml
+++ b/src/l2lRmPoly.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 18/12/2012 (at 10:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 15:57) by Erwan Jahier> *)
(*
Source 2 source transformation :
@@ -28,151 +28,159 @@ let static_args_of_matches matches =
) matches
let rec doit (inprg : LicPrg.t) : LicPrg.t =
- (* n.b. on fait un minumum d'effet de bord pour
- pas avoir trop d'acummulateur ... *)
- let res = ref LicPrg.empty in
+ (* n.b. on fait un minumum d'effet de bord pour
+ pas avoir trop d'acummulateur ... *)
+ let res = ref LicPrg.empty in
- (** TRAITE LES TYPES *)
- let do_type k (te:Lic.type_) =
- res := LicPrg.add_type k te !res
- in
- LicPrg.iter_types do_type inprg;
+ (** TRAITE LES TYPES *)
+ let do_type k (te:Lic.type_) =
+ res := LicPrg.add_type k te !res
+ in
+ LicPrg.iter_types do_type inprg;
- (** TRAITE LES CONSTANTES *)
- let do_const k (ec: Lic.const) =
- res := LicPrg.add_const k ec !res
- in
- LicPrg.iter_consts do_const inprg ;
+ (** TRAITE LES CONSTANTES *)
+ let do_const k (ec: Lic.const) =
+ res := LicPrg.add_const k ec !res
+ in
+ LicPrg.iter_consts do_const inprg ;
- (** TRAITE LES NOEUDS : *)
- let rec do_node k (ne:Lic.node_exp) = (
- if node_is_poly ne then
- (* pour les noeuds polymorphes/surchagés, on fait rien du tout *)
- Verbose.printf "### Warning: no code generated for polymorphic/overloaded node '%s'\n"
- (Lic.string_of_node_key ne.node_key_eff)
- else
- let def' = match ne.def_eff with
- | MetaOpLic _
- | ExternLic -> ne.def_eff
- | AbstractLic _ -> assert false
- | 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 =
- (* parcours les expressions du body
- Ã 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,
- do_exp m (snd eq.it)
- ) eq.src
+ (** TRAITE LES NOEUDS : *)
+ let rec do_node k (ne:Lic.node_exp) = (
+ if node_is_poly ne then
+ (* pour les noeuds polymorphes/surchagés, on fait rien du tout *)
+ Verbose.printf "### Warning: no code generated for polymorphic/overloaded node '%s'\n"
+ (Lic.string_of_node_key ne.node_key_eff)
+ else
+ let def' = match ne.def_eff with
+ | MetaOpLic _
+ | ExternLic -> ne.def_eff
+ | AbstractLic _ -> assert false
+ | BodyLic nb -> BodyLic (do_body [] nb)
in
- {
- asserts_eff = List.map do_assert nb.asserts_eff;
- eqs_eff = List.map do_eq nb.eqs_eff;
- }
- (* TRAITEMENT DES EXP : on passe en parametre un Lic.type_matches *)
- and do_exp
+ 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 =
+ (* parcours les expressions du body
+ Ã 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,
+ do_exp m (snd eq.it)
+ ) eq.src
+ in
+ {
+ asserts_eff = List.map do_assert nb.asserts_eff;
+ eqs_eff = List.map do_eq nb.eqs_eff;
+ }
+ (* TRAITEMENT DES EXP : on passe en parametre un Lic.type_matches *)
+ and do_exp
(m: Lic.type_matches)
- (e: Lic.val_exp)
- : Lic.val_exp =
- let typ' = Lic.apply_type_matches m e.ve_typ in
- let core' = match e.ve_core with
+ (e: Lic.val_exp)
+ : Lic.val_exp =
+ let typ' = Lic.apply_type_matches m e.ve_typ in
+ let core' = match e.ve_core with
| CallByPosLic (posop, OperLic ops) -> (
- let ops' = OperLic (List.map (do_exp m) ops) in
- match posop.it with
- | PREDEF_CALL (pop,sas) ->
+ let ops' = OperLic (List.map (do_exp m) ops) in
+ match posop.it with
+ | PREDEF_CALL (pop,sas) ->
(* 12/07 ICI version provisoise :
les macros predef n'existe plus ! (ce sont des calls classiques)
*)
assert (sas = []);
CallByPosLic (posop, ops')
- | CALL nk ->
- let ne = LicPrg.find_node inprg nk.it in
+ | CALL nk ->
+ let ne =
+ match LicPrg.find_node inprg nk.it with
+ | Some n -> n
+ | None -> assert false
+ in
let nk' = if node_is_poly ne then (
- Verbose.exe ~flag:dbg (fun () ->
- Printf.fprintf stderr "#DBG: CALL poly node %s\n"
+ Verbose.exe ~flag:dbg (fun () ->
+ Printf.fprintf stderr "#DBG: CALL poly node %s\n"
(Lxm.details posop.src));
- let intypes = types_of_operands ops' in
- let (inpars, _) = Lic.profile_of_node_exp ne in
- let tmatches = UnifyType.is_matched inpars intypes in
- {it=solve_poly tmatches nk.it ne; src=nk.src}
+ let intypes = types_of_operands ops' in
+ let (inpars, _) = Lic.profile_of_node_exp ne in
+ let tmatches = UnifyType.is_matched inpars intypes in
+ {it=solve_poly tmatches nk.it ne; src=nk.src}
) else nk in
let posop' = Lxm.flagit (CALL nk') posop.src in
CallByPosLic (posop', ops')
- | x ->
+ | x ->
(* dans tout les autre cas, raf ? *)
CallByPosLic (posop, ops')
)
| CallByNameLic (namop, idops) ->
- let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
- CallByNameLic (namop, idops')
- in
- { e with ve_core = core'; ve_typ = typ' }
- (* TRAITEMENT DES PARAMS STATIQUES *)
- and do_static_arg
+ let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
+ CallByNameLic (namop, idops')
+ in
+ { e with ve_core = core'; ve_typ = typ' }
+ (* TRAITEMENT DES PARAMS STATIQUES *)
+ and do_static_arg
(m: Lic.type_matches)
- (a: Lic.static_arg)
- : Lic.static_arg =
- match a with
+ (a: Lic.static_arg)
+ : Lic.static_arg =
+ match a with
| ConstStaticArgLic (id, cst) -> a
| TypeStaticArgLic (id, ty) -> a
| NodeStaticArgLic (id, nk) -> (
- match nk with
- | (("Lustre",_),[]) -> a
- | _ ->
- let ne = LicPrg.find_node inprg nk in
+ match nk with
+ | (("Lustre",_),[]) -> a
+ | _ ->
+ let ne =
+ match LicPrg.find_node inprg nk with
+ | Some n -> n
+ | None -> assert false
+ in
let nk' = solve_poly m nk ne in
NodeStaticArgLic (id, nk')
)
- (** Gros du boulot :
+ (** Gros du boulot :
soit un noeud poly, soit un profil attendu,
fabrique s'il n'existe pas déjà , un noeud non poly adéquat ...
- *)
- and solve_poly
+ *)
+ and solve_poly
(tmatches: Lic.type_matches)
- (nk: Lic.node_key)
- (ne: Lic.node_exp)
- : Lic.node_key =
- Verbose.printf ~flag:dbg
- "#DBG: L2lRmPoly.solve_poly nk='%s'\n# prof=%s'\n# matches='%s'\n"
- (Lic.string_of_node_key nk)
- (Lic.string_of_type_profile (Lic.profile_of_node_exp ne))
- (Lic.string_of_type_matches tmatches)
- ;
- let do_var vi =
- 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
- let sargs' = sargs@(static_args_of_matches tmatches) in
- let nk' = (nid, sargs') in
- let def' = match ne.def_eff with
- | ExternLic
- | AbstractLic _ -> assert false
- | MetaOpLic (bid, sas) -> MetaOpLic (bid, List.map (do_static_arg tmatches) sas)
- | BodyLic nb -> BodyLic(do_body tmatches nb)
- in
- let ne' = {
- node_key_eff = nk';
- inlist_eff = List.map do_var ne.inlist_eff;
- outlist_eff = List.map do_var ne.outlist_eff;
- loclist_eff = (match ne.loclist_eff with
- | None -> None
- | Some vl -> Some (List.map do_var vl)
- );
- def_eff = def';
- has_mem_eff = ne.has_mem_eff;
- is_safe_eff = ne.is_safe_eff;
- } in
- res := LicPrg.add_node nk' ne' !res;
- nk'
- in
- (*LET's GO *)
- LicPrg.iter_nodes do_node inprg;
- !res
+ (nk: Lic.node_key)
+ (ne: Lic.node_exp)
+ : Lic.node_key =
+ Verbose.printf ~flag:dbg
+ "#DBG: L2lRmPoly.solve_poly nk='%s'\n# prof=%s'\n# matches='%s'\n"
+ (Lic.string_of_node_key nk)
+ (Lic.string_of_type_profile (Lic.profile_of_node_exp ne))
+ (Lic.string_of_type_matches tmatches)
+ ;
+ let do_var vi =
+ 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
+ let sargs' = sargs@(static_args_of_matches tmatches) in
+ let nk' = (nid, sargs') in
+ let def' = match ne.def_eff with
+ | ExternLic
+ | AbstractLic _ -> assert false
+ | MetaOpLic (bid, sas) -> MetaOpLic (bid, List.map (do_static_arg tmatches) sas)
+ | BodyLic nb -> BodyLic(do_body tmatches nb)
+ in
+ let ne' = {
+ node_key_eff = nk';
+ inlist_eff = List.map do_var ne.inlist_eff;
+ outlist_eff = List.map do_var ne.outlist_eff;
+ loclist_eff = (match ne.loclist_eff with
+ | None -> None
+ | Some vl -> Some (List.map do_var vl)
+ );
+ def_eff = def';
+ has_mem_eff = ne.has_mem_eff;
+ is_safe_eff = ne.is_safe_eff;
+ } in
+ res := LicPrg.add_node nk' ne' !res;
+ nk'
+ in
+ (*LET's GO *)
+ LicPrg.iter_nodes do_node inprg;
+ !res
diff --git a/src/lic.ml b/src/lic.ml
index 98f05832..c22fac77 100644
--- a/src/lic.ml
+++ b/src/lic.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 13/12/2012 (at 16:16) by Erwan Jahier> *)
+(* Time-stamp: <modified the 19/12/2012 (at 10:18) by Erwan Jahier> *)
(** Define the Data Structure representing Compiled programs. *)
@@ -174,11 +174,12 @@ and val_exp =
a cleaner solution would be to define two versions of val_exp: one with
type info, and one without. But it is a big mutually recursive thing,
and doing that would be a little bit heavy...
+ XXX why not an option type?
*)
ve_clk : clock list
(* ditto *)
}
-(** CallByPosLicest (sans doute ?)
+(** CallByPosLic est (sans doute ?)
le BON endroit pour stocker l'information de 'matches',
i.e. est-ce qu'un 'type_matches' a été nécessaire
pour typer l'appel de l'opérateur ?
@@ -320,8 +321,7 @@ and type_matches = (type_var * type_) list
and node_def =
| ExternLic
- | MetaOpLic of node_key
- (* ICI A QUOI CA SERT ???? *)
+ | MetaOpLic of node_key (* ICI A QUOI CA SERT ???? *)
| AbstractLic of node_exp option (* None if extern in the provide part *)
| BodyLic of node_body
@@ -637,7 +637,7 @@ let rec string_of_type = function
| Abstract_type_eff (name, t) -> (string_of_ident name)
| Enum_type_eff (name, _) -> (string_of_ident name)
| Array_type_eff (ty, sz) ->
- Printf.sprintf "%s^%d" (string_of_type ty) sz
+ Printf.sprintf "%s^%d" (string_of_type ty) sz
| Struct_type_eff (name, _) -> (string_of_ident name)
| TypeVar Any -> "any"
| (TypeVar AnyNum) -> "anynum"
@@ -656,51 +656,51 @@ and string_of_clock = function
| On (id, ck) -> " on "^(Ident.string_of_clk id)^(string_of_clock ck)
and string_of_const = function
- | Bool_const_eff true -> "true"
- | Bool_const_eff false -> "false"
- | Int_const_eff i -> (sprintf "%d" i)
- | Real_const_eff r -> r
- | Extern_const_eff (s,_) -> (string_of_ident s)
- | Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
- | Enum_const_eff (s,_) -> (string_of_ident s)
- | Struct_const_eff (fl, t) ->
- let string_of_field (id, veff) =
- (Ident.to_string id)^" = "^ (string_of_const veff)
- in
- Printf.sprintf "%s{%s}"
- (string_of_type t)
- (String.concat "; " (List.map string_of_field fl))
- | Array_const_eff (ctab, t) ->
- Printf.sprintf "[%s]"
- (String.concat ", " (List.map string_of_const ctab))
- | Tuple_const_eff cl ->
- Printf.sprintf "(%s)"
- (String.concat ", " (List.map string_of_const cl))
+ | Bool_const_eff true -> "true"
+ | Bool_const_eff false -> "false"
+ | Int_const_eff i -> (sprintf "%d" i)
+ | Real_const_eff r -> r
+ | Extern_const_eff (s,_) -> (string_of_ident s)
+ | Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
+ | Enum_const_eff (s,_) -> (string_of_ident s)
+ | Struct_const_eff (fl, t) ->
+ let string_of_field (id, veff) =
+ (Ident.to_string id)^" = "^ (string_of_const veff)
+ in
+ Printf.sprintf "%s{%s}"
+ (string_of_type t)
+ (String.concat "; " (List.map string_of_field fl))
+ | Array_const_eff (ctab, t) ->
+ Printf.sprintf "[%s]"
+ (String.concat ", " (List.map string_of_const ctab))
+ | Tuple_const_eff cl ->
+ Printf.sprintf "(%s)"
+ (String.concat ", " (List.map string_of_const cl))
and string_of_var_info x =
- (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type x.var_type_eff)^(string_of_clock (snd x.var_clock_eff))
+ (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type x.var_type_eff)^(string_of_clock (snd x.var_clock_eff))
and string_of_var_list vl = String.concat " ; " (List.map string_of_var_info vl)
and string_of_node_key = function
-| (ik, []) ->
- (string_of_ident ik)
-| (ik, sargs) -> Printf.sprintf "%s<<%s>>"
- (string_of_ident ik)
- (String.concat ", " (List.map string_of_static_arg sargs))
+ | (ik, []) ->
+ (string_of_ident ik)
+ | (ik, sargs) -> Printf.sprintf "%s<<%s>>"
+ (string_of_ident ik)
+ (String.concat ", " (List.map string_of_static_arg sargs))
and string_of_static_arg = function
-| ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
-| TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type teff)
+ | ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
+ | TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
-| NodeStaticArgLic (id, nk) ->
- Printf.sprintf "node %s = %s" id (string_of_node_key nk)
+ | NodeStaticArgLic (id, nk) ->
+ Printf.sprintf "node %s = %s" id (string_of_node_key nk)
and string_of_type_var tv = string_of_type (TypeVar tv)
and string_of_type_matches pm =
- let sotm (tv,t) = Printf.sprintf "%s <- %s"
- (string_of_type_var tv) (string_of_type t)
- in
- String.concat ", " (List.map sotm pm)
+ let sotm (tv,t) = Printf.sprintf "%s <- %s"
+ (string_of_type_var tv) (string_of_type t)
+ in
+ String.concat ", " (List.map sotm pm)
let string_of_node_exp ne =
(Printf.sprintf " node_key_eff = %s\n" (string_of_node_key ne.node_key_eff))
diff --git a/src/licPrg.ml b/src/licPrg.ml
index a7e26248..ee70de4c 100644
--- a/src/licPrg.ml
+++ b/src/licPrg.ml
@@ -58,9 +58,9 @@ let fresh_type_id this pname pfx =
fresh 0
(** RECHERCHE *)
-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_type this k = try Some(ItemKeyMap.find k this.types ) with Not_found -> None
+let find_const this k = try Some(ItemKeyMap.find k this.consts) with Not_found -> None
+let find_node this k = try Some(NodeKeyMap.find k this.nodes ) with Not_found -> None
let (find_var : Ident.t -> Lic.node_exp -> Lic.var_info option) =
fun id ne ->
diff --git a/src/licPrg.mli b/src/licPrg.mli
index 2fe9641d..297e6c60 100644
--- a/src/licPrg.mli
+++ b/src/licPrg.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 18/12/2012 (at 14:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 15:51) by Erwan Jahier> *)
(** The data structure resulting from the compilation process *)
@@ -43,12 +43,9 @@ 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_type : t -> Lic.item_key -> Lic.type_ option
+val find_const : t -> Lic.item_key -> Lic.const option
+val find_node : t -> Lic.node_key -> Lic.node_exp option
val find_var : Ident.t -> Lic.node_exp -> Lic.var_info option
val fresh_type_id : t -> Ident.pack_name -> string -> Ident.long
diff --git a/src/uglyStuff.ml b/src/uglyStuff.ml
index 3a9c6fac..1ed25936 100644
--- a/src/uglyStuff.ml
+++ b/src/uglyStuff.ml
@@ -1,7 +1,7 @@
(** XXX REMOVE ME : Crutch for make it works
- Des béquilles et autres trucs moches qui ne devraient etre refaits ...
+ Des béquilles et autres trucs moches qui devraient etre refaits ...
*)
@@ -12,25 +12,19 @@ ACCES AUX INFOS DEJA COMPILEES,
infos déjà compilées, alors que c'est pas fait pour...
- Y'a un probleme de gestion d'environnement a revoir ...
*)
-let node_exp_of_node_key
- (id_solver: Lic.id_solver)
- (node_key: Lic.node_key)
- (lxm : Lxm.t)
+let node_exp_of_node_key
+ (id_solver: Lic.id_solver) (node_key: Lic.node_key) (lxm : Lxm.t)
: Lic.node_exp =
let (id, sargs) = node_key in
id_solver.Lic.id2node (Ident.idref_of_long id) sargs lxm
let var_info_of_ident
- (id_solver: Lic.id_solver)
- (id: Ident.t)
- (lxm : Lxm.t)
+ (id_solver: Lic.id_solver) (id: Ident.t) (lxm : Lxm.t)
: Lic.var_info =
id_solver.Lic.id2var (Ident.idref_of_id id) lxm
let const_eff_of_item_key
- (id_solver: Lic.id_solver)
- (id: Lic.item_key)
- (lxm : Lxm.t)
+ (id_solver: Lic.id_solver) (id: Lic.item_key) (lxm : Lxm.t)
: Lic.const =
id_solver.Lic.id2const (Ident.idref_of_long id) lxm
--
GitLab