1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
open Lxm
open Lic
let dbg = (Lv6Verbose.get_flag "poly")
let (is_predef_overloaded : Lic.node_key -> bool) =
fun nk ->
match fst nk with
| ("Lustre",("times"|"slash"|"uminus"|"minus"|"plus"|"lt"|"lte"|"gt"|"gte")) -> true
| _ -> false
(** utile : on ne traite que les poly non externe *)
let node_is_poly ne =
(Lic.node_is_poly ne) && not (Lic.node_is_extern ne)
let types_of_operands ops =
match ops with vl ->
List.flatten (List.map Lic.type_of_val_exp vl)
let static_args_of_matches matches =
List.map (fun (tv, te) ->
let tid = Lic.string_of_type_var tv in
TypeStaticArgLic (tid, te)
) matches
let (instanciate_node_key: Lic.type_matches -> Lic.node_key -> Lic.node_key) =
fun tmatches nk ->
if is_predef_overloaded nk then (
let ((_m,n),sargs) = nk in
try if List.assoc AnyNum tmatches = Int_type_eff then
("Lustre","i"^n),sargs
else
("Lustre","r"^n),sargs
with Not_found -> nk
) else
nk
let doit (inprg : LicPrg.t) : LicPrg.t =
let res = ref LicPrg.empty in
let do_type k (te:Lic.type_) =
res := LicPrg.add_type k te !res
in
LicPrg.iter_types do_type inprg;
let do_const k (ec: Lic.const) =
res := LicPrg.add_const k ec !res
in
LicPrg.iter_consts do_const inprg ;
let rec do_node k (ne:Lic.node_exp) = (
if node_is_poly ne then
Lv6Verbose.exe ~flag:dbg (fun() -> Printf.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
)
and do_body (m: Lic.type_matches) (nb: Lic.node_body) : Lic.node_body =
let do_assert a = Lxm.flagit (do_exp m a.it) a.src
and do_eq eq =
Lxm.flagit (List.map (do_left m) (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;
}
and do_left (m: Lic.type_matches) (l: Lic.left) : Lic.left =
let rec aux l =
match l with
| LeftVarLic (var_info, lxm) -> LeftVarLic(do_var_info m var_info, lxm)
| LeftFieldLic(left, id, t) -> LeftFieldLic(aux left, id, Lic.subst_matches m t)
| LeftArrayLic(left, int, t) -> LeftArrayLic(aux left, int, Lic.subst_matches m t)
| LeftSliceLic(left, si, t) -> LeftSliceLic(aux left, si, Lic.subst_matches m t)
in
aux l
and do_var_info (m: Lic.type_matches) (vi:Lic.var_info) : Lic.var_info =
{ vi with var_type_eff = Lic.subst_matches m vi.var_type_eff }
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
| CallByPosLic (posop, ops) -> (
let ops' = (List.map (do_exp m) ops) in
match posop.it with
| PREDEF_CALL (_pop) -> CallByPosLic (posop, ops')
| CALL nk ->
let ne =
match LicPrg.find_node inprg nk.it with
| Some n -> n
| None -> assert false
in
let nk' = if is_predef_overloaded nk.it then
(Lxm.flagit (instanciate_node_key m nk.it) nk.src)
else if node_is_poly ne
then (
Lv6Verbose.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}
)
else nk
in
let posop' = Lxm.flagit (CALL nk') posop.src in
CallByPosLic (posop', ops')
| _x ->
CallByPosLic (posop, ops')
)
| CallByNameLic (namop, idops) ->
let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
CallByNameLic (namop, idops')
| Merge (ce,cl) ->
let cl = List.map (fun (id, ve) -> (id, (do_exp m) ve)) cl in
Merge (ce, cl)
in
{ e with ve_core = core'; ve_typ = typ' }
and do_static_arg (m: Lic.type_matches) (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",_),[]) -> NodeStaticArgLic (id, instanciate_node_key m nk)
| _ ->
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')
)
and solve_poly (tmatches: Lic.type_matches) (nk: Lic.node_key) (ne: Lic.node_exp)
: Lic.node_key =
Lv6Verbose.exe ~flag:dbg (fun () ->
Printf.printf
"#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
let (nid, sargs) = nk in
let sargs' = (List.map (do_static_arg tmatches) sargs)
@(static_args_of_matches tmatches)
in
let nk' = (nid, sargs') in
let def' = match ne.def_eff with
| ExternLic
| AbstractLic _ -> assert false
| MetaOpLic -> MetaOpLic
| 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;
lxm = ne.lxm;
} in
res := LicPrg.add_node nk' ne' !res;
nk'
in
LicPrg.iter_nodes do_node inprg;
!res