Skip to content
This repository
Newer
Older
100644 790 lines (707 sloc) 26.376 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
2 Copyright © 2011, 2012 MLstate
fccc6851 » MLstate
2011-06-21 Initial open-source release
3
5bb0f1a4 » Aqua-Ye
2012-07-09 [cleanup] compiler: typo on Opa
4 This file is part of Opa.
fccc6851 » MLstate
2011-06-21 Initial open-source release
5
5bb0f1a4 » Aqua-Ye
2012-07-09 [cleanup] compiler: typo on Opa
6 Opa is free software: you can redistribute it and/or modify it under the
fccc6851 » MLstate
2011-06-21 Initial open-source release
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
5bb0f1a4 » Aqua-Ye
2012-07-09 [cleanup] compiler: typo on Opa
10 Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc6851 » MLstate
2011-06-21 Initial open-source release
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
5bb0f1a4 » Aqua-Ye
2012-07-09 [cleanup] compiler: typo on Opa
16 along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc6851 » MLstate
2011-06-21 Initial open-source release
17 *)
18 (* cf mli *)
19
20 (* depends *)
21 module List = BaseList
22
23 (* aliases *)
24 module Db = QmlAst.Db
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
25 module TU = Traverse.Utils
fccc6851 » MLstate
2011-06-21 Initial open-source release
26
27 (* shorthands *)
28 module Q = QmlAst
29
30 let add_void_acc f = fun () v->(), f v
31 let rm_void_acc f = fun v-> snd (f () v)
32 let make_fold fold_map f acc elt = fst (fold_map (fun acc v-> f acc v, v) acc elt)
33 let make_map fold_map f elt = rm_void_acc (fold_map (add_void_acc f)) elt
34 let make_iter fold_map f elt = fst (fold_map (fun () v-> (f v:unit), v) () elt)
35
36
37 module Row =
38 struct
39
40 let rec aux_flag tau = Some tau
41
42 let fold_left fct acc r =
43 let Q.TyRow (fs, _) = r in
44 List.fold_left (fun acc (f, t) -> fct acc f t) acc fs
45
46 let fold_left_map fct acc r =
47 let Q.TyRow (fs, v) = r in
48 let acc, ffs = List.fold_left_map_stable
49 (fun acc ((f, t) as c) ->
50 let acc, ft = fct acc t in
51 acc,
52 if t == ft then c else
53 (f, ft)
54 ) acc fs in
55 acc,
56 if fs == ffs then r else
57 Q.TyRow (ffs, v)
58
59 let fold_right fct r acc =
60 let Q.TyRow (fs, _) = r in
61 List.fold_right (fun (f, t) acc -> fct f t acc) fs acc
62
63 let elements (Q.TyRow (fs, _)) = fs
64
65 let length (Q.TyRow (fs, _)) = List.length fs
66
67 let compare (f, _) (f', _) = String.compare f f'
68
69 let ordered_elements row = List.sort compare (elements row) (** eventually use a heap with a fold_left *)
70
71 let ordered_fold fct acc row =
72 let fct acc (f, t) = fct acc f t in
73 List.fold_left fct acc (ordered_elements row)
74
75 let pos_of_field row =
76 let len = ref 0 in
77 let li = fold_left (fun acc f o -> incr(len); (f, o)::acc) [] row in
78 let len = !len and li = List.rev li in
79 let fields = Array.make len ("", QmlAst.typeNull) in
80 List.iteri (fun fo i -> fields.(i) <- fo) li;
81 let map = List.fold_left_i (fun map (f, o) i -> StringMap.add f (i, o) map) StringMap.empty li in
82 fields, map
83
84 let has_field f (Q.TyRow (fs, _)) = List.mem_assoc f fs
85 let get_field f (Q.TyRow (fs, _)) = List.assoc_opt f fs
86 end
87
88 module Col =
89 struct
90 let fold_left_map fct acc col =
91 let Q.TyCol (fsl, cv) = col in
92 let acc, ffsl =
93 List.fold_left_map_stable
94 (List.fold_left_map_stable
95 (fun acc ((f, t) as c) ->
96 let acc, ft = fct acc t in
97 acc,
98 if t == ft then c else
99 (f, ft)
100 )
101 )
102 acc fsl in
103 acc,
104 if fsl == ffsl then col else
105 Q.TyCol (ffsl, cv)
106
107 let fold_records f acc col =
108 let Q.TyCol (fldslist, _colvar) = col in
109 List.fold_left (fun acc flds -> f acc (Q.TypeRecord (Q.TyRow (flds, None)))) acc fldslist
110 end
111
112 (** over interface, cf mli *)
113 module Ty_sums =
114 struct
115 let elements l = l
116 let fold f l a = List.fold_left (fun t a -> f a t) a l
117 end
118
119 module Type =
120 struct
121 (*
122 module Subs : TraverseInterface.S with type 'a t = ty constraint 'a = 'b * 'c * 'd = struct
123 type 'a t = ty constraint 'a = 'b * 'c * 'd
124
125 let subs_cons ty =
126 let fun0 e = function [] -> e | _ -> assert false in
127 let fun1 f = function [x] -> f x | _ -> assert false in
128 let fun2 f = function [x; y] -> f x y | _ -> assert false in
129 let rec list_combine_rem l1 l2 = match l1, l2 with
130 | x1::r1,x2::r2 -> let r,rem = list_combine_rem r1 r2 in
131 (x1, x2)::r, rem
132 | [],l -> [],l
133 | _, [] -> assert false in
134 match ty with
135 | (TypeConst _ | TypeVar _ | TypeAbstract) -> fun0 ty, []
136 | TypeArrow (lt, t) ->
137 ((fun tlt ->
138 match tlt with
139 | [] -> assert false
140 | t :: lt -> TypeArrow (lt, t)),
141 t :: lt)
142 | TypeRecord (TyRow (row, rv)) ->
143 let fields, tys = List.split row in
144 (fun tys ->
145 let row, rest = list_combine_rem fields tys in
146 assert (rest = []);
147 TypeRecord (TyRow (row, rv))), tys
148 | TypeSum (TyCol (col, cv)) ->
149 (* something special is happening here (this may or may not be what you want) *)
150 let recs = List.map (fun row -> TypeRecord (TyRow (row, None))) col in
151 (fun recs ->
152 let col = List.map (function
153 | TypeRecord (TyRow (row, None)) -> row
154 | _ -> assert false) recs in
155 TypeSum (TyCol (col, cv))), recs
156 | TypeSumSugar tys ->
157 (fun tys -> TypeSumSugar tys), tys
158 | TypeName (tys, ti) ->
159 (fun tys -> TypeName (tys, ti)), tys
160 | TypeForall (vars, rvars, cvars, t) ->
161 fun1 (fun t -> TypeForall (vars, rvars, cvars, t)), [t]
162 end
163 *)
164 module S2 : TraverseInterface.S2 with type 'a t = Q.ty constraint 'a = 'b * 'c * 'd =
165 struct
166 type 'a t = Q.ty constraint 'a = 'b * 'c * 'd
167
168 let foldmap_field_stable tra acc ((x, y) as c) =
169 let acc, y' = tra acc y in
170 acc,
171 if y == y' then c else (x, y')
172
173 let foldmap tra acc t =
174 match t with
175 | Q.TypeConst _
176 | Q.TypeVar _ -> acc, t
177 | Q.TypeArrow (tyl, ty) ->
178 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
179 let acc, fty = tra acc ty in
180 acc,
181 if tyl == ftyl && ty = fty then t else
182 Q.TypeArrow (ftyl, fty)
183 | Q.TypeRecord (Q.TyRow (fields, rowvar)) ->
184 let acc, ffields = List.fold_left_map_stable (foldmap_field_stable tra) acc fields in
185 acc,
186 if fields == ffields then t else
187 Q.TypeRecord (Q.TyRow (ffields, rowvar))
188 | Q.TypeSum (Q.TyCol (l_fields, colvar)) ->
189 let acc, fl_fields = List.fold_left_map_stable (List.fold_left_map_stable (foldmap_field_stable tra)) acc l_fields in
190 acc,
191 if l_fields == fl_fields then t else
192 Q.TypeSum (Q.TyCol (fl_fields, colvar))
193 | Q.TypeSumSugar tyl ->
194 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
195 acc,
196 if tyl == ftyl then t else
197 Q.TypeSumSugar ftyl
198 | Q.TypeName (tyl, typeident) ->
199 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
200 acc,
201 if tyl == ftyl then t else
202 Q.TypeName (ftyl, typeident)
203 | Q.TypeAbstract -> acc, t
204 | Q.TypeForall (typevars, rowvars, colvars, ty) ->
205 let acc, fty = tra acc ty in
206 acc,
207 if ty == fty then t else
208 Q.TypeForall (typevars, rowvars, colvars, fty)
209
210 let iter_field tra (_, ty) = tra ty
211
212 let iter tra t =
213 match t with
214 | Q.TypeConst _
215 | Q.TypeVar _ -> ()
216 | Q.TypeArrow (tyl, ty) ->
217 List.iter tra tyl;
218 tra ty
219 | Q.TypeRecord (Q.TyRow (fields, _rowvar)) ->
220 List.iter (iter_field tra) fields
221 | Q.TypeSum (Q.TyCol (l_fields, _colvar)) ->
222 List.iter (List.iter (iter_field tra)) l_fields
223 | Q.TypeSumSugar tyl ->
224 List.iter tra tyl
225 | Q.TypeName (tyl, _typeident) ->
226 List.iter tra tyl
227 | Q.TypeAbstract -> ()
228 | Q.TypeForall (_typevars, _rowvars, _colvars, ty) ->
229 tra ty
230
231 let map_field_stable tra ((x, y) as c) =
232 let y' = tra y in
233 if y == y' then c else (x, y')
234
235 let map tra t =
236 match t with
237 | Q.TypeConst _
238 | Q.TypeVar _ -> t
239 | Q.TypeArrow (tyl, ty) ->
240 let mtyl = List.map_stable tra tyl in
241 let mty = tra ty in
242 if tyl == mtyl && ty = mty then t else
243 Q.TypeArrow (mtyl, mty)
244 | Q.TypeRecord (Q.TyRow (fields, rowvar)) ->
245 let mfields = List.map_stable (map_field_stable tra) fields in
246 if fields == mfields then t else
247 Q.TypeRecord (Q.TyRow (mfields, rowvar))
248 | Q.TypeSum (Q.TyCol (l_fields, colvar)) ->
249 let ml_fields = List.map_stable (List.map_stable (map_field_stable tra)) l_fields in
250 if l_fields == ml_fields then t else
251 Q.TypeSum (Q.TyCol (ml_fields, colvar))
252 | Q.TypeSumSugar tyl ->
253 let mtyl = List.map_stable tra tyl in
254 if tyl == mtyl then t else
255 Q.TypeSumSugar mtyl
256 | Q.TypeName (tyl, typeident) ->
257 let mtyl = List.map_stable tra tyl in
258 if tyl == mtyl then t else
259 Q.TypeName (mtyl, typeident)
260 | Q.TypeAbstract -> t
261 | Q.TypeForall (typevars, rowvars, colvars, ty) ->
262 let mty = tra ty in
263 if ty == mty then t else
264 Q.TypeForall (typevars, rowvars, colvars, mty)
265
266 let fold_field tra acc (_, ty) = tra acc ty
267
268 let fold tra acc t =
269 match t with
270 | Q.TypeConst _
271 | Q.TypeVar _ -> acc
272 | Q.TypeArrow (tyl, ty) ->
273 let acc = List.fold_left tra acc tyl in
274 let acc = tra acc ty in
275 acc
276 | Q.TypeRecord (Q.TyRow (fields, _rowvar)) ->
277 let acc = List.fold_left (fold_field tra) acc fields in
278 acc
279 | Q.TypeSum (Q.TyCol (l_fields, _colvar)) ->
280 let acc = List.fold_left (List.fold_left (fold_field tra)) acc l_fields in
281 acc
282 | Q.TypeSumSugar tyl ->
283 let acc = List.fold_left tra acc tyl in
284 acc
285 | Q.TypeName (tyl, _typeident) ->
286 let acc = List.fold_left tra acc tyl in
287 acc
288 | Q.TypeAbstract -> acc
289 | Q.TypeForall (_typevars, _rowvars, _colvars, ty) ->
290 let acc = tra acc ty in
291 acc
292 end
293
294 (* TODO: bench with this one *)
295 include Traverse.Make2 (S2)
296
297 (* For now, Keeping old implementation *)
298 (* include Traverse.Make (Subs) *)
299 end
300
301
302 module Top =
303 struct
304 (*let iter_expr f = function
305 | Database _
306 | NewDbValue (Db_Q.TypeDecl _)
307 | NewType _ -> ()
308 | NewDbValue (Db_Constraint _) -> assert false
309 | NewVal bnd | NewValRec bnd -> List.iter (fun (_,e) -> f e) bnd
310 | NewDbValue (Db_Default (p, dflt)) -> f dflt
311
312 let map_expr map elt = match elt with
313 | Database _
314 | NewDbValue (Db_TypeDecl _)
315 | NewType _ -> elt
316 | NewDbValue (Db_Constraint _) -> assert false
317 | NewDbValue (Db_Default (p, dflt)) -> NewDbValue (Db_Default (p, map dflt))
318 | NewVal se -> NewVal (List.map (fun (s, e) -> (s, map e)) se)
319 | NewValRec se -> NewValRec (List.map (fun (s, e) -> (s, map e)) se)
320
321 let fold_expr f acc elt = match elt with
322 | Database _
323 | NewDbValue (Db_TypeDecl _)
324 | NewType _ -> acc
325 | NewDbValue (Db_Constraint _) -> assert false
326 | NewVal bnd | NewValRec bnd -> List.fold_left (fun acc (id,e) -> f acc e) acc bnd
327 | NewDbValue (Db_Default (p, dflt)) -> f acc dflt*)
328
329 let fold_map_name_expr f acc elt =
330 match elt with
331 | Q.Database _
332 | Q.NewDbValue (_, Db.Db_TypeDecl _)
333 | Q.NewDbValue (_, Db.Db_Alias _)
334 | Q.NewType _ -> acc, elt
335 | Q.NewDbValue (label, Db.Db_Constraint (p, cstr)) ->
336 (match cstr with
337 | Db.C_Ordering e ->
338 let acc, (_, fe) = f acc (Ident.source "dbconstr", e) in
339 acc,
340 if e == fe then elt else
341 Q.NewDbValue (label, Db.Db_Constraint (p, Db.C_Ordering fe))
342 | Db.C_Validation e ->
343 let acc, (_, fe) = f acc (Ident.source "dbconstr", e) in
344 acc,
345 if e == fe then elt else
346 Q.NewDbValue (label, Db.Db_Constraint (p, Db.C_Validation fe))
9e1327c5 » OpaOnWindowsNow
2012-07-06 [fix] dbGen,private,full: two privacy levels
347 | Db.C_Inclusion _ | Db.C_Inverse _ | Db.C_Private _ ->
fccc6851 » MLstate
2011-06-21 Initial open-source release
348 acc, elt)
349 | Q.NewDbValue (label, Db.Db_Default (p, dflt)) ->
350 let acc, (_, fdflt) = f acc (Ident.source "dbdefault", dflt) in
351 acc,
352 if dflt == fdflt then elt else
353 Q.NewDbValue (label, Db.Db_Default (p, fdflt))
354 | Q.NewDbValue (label, Db.Db_Virtual (p, e)) ->
355 let acc, (_, fe) = f acc (Ident.source "dbdefault", e) in
356 acc,
357 if e == fe then elt else
358 Q.NewDbValue (label, Db.Db_Virtual (p, fe))
359 | Q.NewVal (label, se) ->
360 let acc, fse = List.fold_left_map_stable f acc se in
361 acc,
362 if se == fse then elt else
363 Q.NewVal (label, fse)
364 | Q.NewValRec (label, se) ->
365 let acc, fse = List.fold_left_map_stable f acc se in
366 acc,
367 if se == fse then elt else
368 Q.NewValRec (label, fse)
369
370 let fold_map_expr foldmap acc elt =
371 let f acc ((s, e) as c) =
372 let acc, fe = foldmap acc e in
373 acc,
374 if e == fe then c else
375 (s, fe)
376 in
377 fold_map_name_expr f acc elt
378
379 let map_name_expr map elt =
380 let f () bnd = (), map bnd in
381 snd (fold_map_name_expr f () elt)
382
383 let iter_name_expr f = make_iter fold_map_name_expr f
384
385 let fold_name_expr f = make_fold fold_map_name_expr f
386
387 let fold_expr f = make_fold fold_map_expr f
388 let map_expr f = make_map fold_map_expr f
389 let iter_expr f = make_iter fold_map_expr f
390
391 let fold_names f acc = function
392 | Q.NewVal (_,iel)
393 | Q.NewValRec (_,iel) -> List.fold_left (fun acc (ident,_) -> f acc ident) acc iel
394 | Q.Database (_,ident,_,_) -> f acc ident
395 | Q.NewDbValue _
396 | Q.NewType _ -> acc
397 end
398
399 module CodeExpr =
400 struct
401 let iter f c =
402 List.iter (fun ce -> Top.iter_expr f ce) c
403
404 let map f c =
405 List.map_stable (fun ce -> Top.map_expr f ce) c
406
407 let fold f acc c =
408 List.fold_left (fun acc ce -> Top.fold_expr f acc ce) acc c
409
410 let fold_name_expr f acc c =
411 List.fold_left (fun acc ce -> Top.fold_name_expr f acc ce) acc c
412
413 let fold_names f acc c =
414 List.fold_left (Top.fold_names f) acc c
415
416 let fold_map_name_expr f acc c =
417 List.fold_left_map_stable (fun acc ce -> Top.fold_map_name_expr f acc ce) acc c
418
419 let map_name_expr f c =
420 List.map (fun ce -> Top.map_name_expr f ce) c
421
422 let fold_map f acc c =
423 List.fold_left_map_stable (fun acc ce -> Top.fold_map_expr f acc ce) acc c
424
425 let iter_with_code_elt f c =
426 List.iter (fun ce -> Top.iter_expr (fun e -> f ce e) ce) c
427
428 let exists f c =
429 try iter (fun e -> if f e then raise Exit) c; false
430 with Exit -> true
431 end
432
433 module Code =
434 struct
435 let filter_binding f code =
436 List.filter_map
437 (function
438 | Q.NewVal (label, iel) -> (
439 match List.filter f iel with
440 | [] -> None
441 | l -> Some (Q.NewVal (label, l))
442 )
443 | Q.NewValRec (label, iel) -> (
444 match List.filter f iel with
445 | [] -> None
446 | l -> Some (Q.NewValRec (label, l))
447 )
448 | c -> Some c) code
449 let iter_binding f code =
450 List.iter
451 (function
452 | Q.NewValRec (_,iel)
453 | Q.NewVal (_,iel) ->
454 List.iter f iel
455 | _ -> ()) code
456 end
457
458 module Pattern =
459 struct
00818f90 » Valentin Gatien-Baron
2011-06-17 [refactor] removing most typing directives sooner
460 module S2 =
461 struct
462 type 'a t = QmlAst.pat constraint 'a = _ * _ * _
463 let foldmap tra acc input_p =
464 match input_p with
465 | Q.PatConst _ | Q.PatVar _ | Q.PatAny _ -> acc, input_p
466 | Q.PatRecord (label, fields, rowvar) ->
467 let acc, fields' =
468 List.fold_left_map_stable
469 (fun acc ((f,p) as c) ->
470 let acc, p' = tra acc p in
471 if p == p' then acc, c else acc, (f,p')
472 ) acc fields in
473 if fields == fields' then
474 acc, input_p
475 else
476 acc, Q.PatRecord (label, fields', rowvar)
477 | Q.PatCoerce (label, pat, t) ->
478 let acc, pat' = tra acc pat in
479 if pat == pat' then
480 acc, input_p
481 else
482 acc, Q.PatCoerce (label, pat', t)
483 | Q.PatAs (label, pat, id) ->
484 let acc, pat' = tra acc pat in
485 if pat == pat' then
486 acc, input_p
487 else
488 acc, Q.PatAs (label, pat', id)
489
490 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
491 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
492 let map tra e = Traverse.Unoptimized.map foldmap tra e
493 end
fccc6851 » MLstate
2011-06-21 Initial open-source release
494
00818f90 » Valentin Gatien-Baron
2011-06-17 [refactor] removing most typing directives sooner
495 include Traverse.Make2(S2)
fccc6851 » MLstate
2011-06-21 Initial open-source release
496
497 let get_fields pat =
498 let rec top pat0 =
499 match pat0 with
500 | Q.PatRecord (_, fields, rowvar) -> Some (fields, rowvar = `open_)
501 | Q.PatCoerce (_, p, _) -> top p
502 | _ -> None
503 in top pat
504 end
505
506 module Expr =
507 struct
508 module S2 =
509 struct
510 type 'a t = QmlAst.expr constraint 'a = _ * _ * _
c197c0f7 » BourgerieQuentin
2012-01-24 [enhance] compiler: (big) Added more update and query node + added ty…
511
fccc6851 » MLstate
2011-06-21 Initial open-source release
512 let foldmap tra acc input_e =
513 match input_e with
514 | Q.Directive (label, `hybrid_value, [e_client;e_server], z) ->
515 (* When we traverse this directive we traverse only the client value.
516 * Because this directive can be only on client code... *)
517 let acc, e_client' = tra acc e_client in
518 acc,
519 if e_client == e_client' then input_e else
520 Q.Directive (label, `hybrid_value, [e_client';e_server], z)
521 | Q.Directive (_, `hybrid_value, [_e_server], _) ->
522 acc, input_e
523 | Q.Directive (_, `hybrid_value, _, _) -> assert false
524 | Q.Const _
525 | Q.Ident _
526 | Q.Bypass _
527 -> acc, input_e
528 | Q.Directive (label, variant, exprs, tys) ->
529 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
530 acc,
531 if exprs == exprs' then input_e else
532 Q.Directive (label, variant, exprs', tys)
533 | Q.LetIn (label, bnd, e) ->
534 let acc, bnd' =
535 List.fold_left_map_stable
536 (fun acc ((i, e) as p) ->
537 let acc, e' = tra acc e in
538 acc,
539 if e == e' then p else (i, e')
540 ) acc bnd in
541 let acc, e' = tra acc e in
542 acc,
543 if bnd == bnd' && e == e' then input_e else
544 Q.LetIn (label, bnd', e')
545 | Q.LetRecIn (label, bnd, e) ->
546 let acc, bnd' =
547 List.fold_left_map_stable
548 (fun acc ((i, e) as p) ->
549 let acc, e' = tra acc e in
550 acc,
551 if e == e' then p else (i, e')
552 ) acc bnd in
553 let acc, e' = tra acc e in
554 acc,
555 if bnd == bnd' && e == e' then input_e else
556 Q.LetRecIn (label, bnd', e')
557 | Q.Lambda (label, params, e) ->
558 let acc, e' = tra acc e in
559 acc,
560 if e == e' then input_e else
561 Q.Lambda (label, params, e')
562 | Q.Apply (label, e1, args) ->
563 let acc, e1' = tra acc e1 in
564 let acc, args' = List.fold_left_map_stable tra acc args in
565 acc,
566 if e1 == e1' && args == args' then input_e else
567 Q.Apply (label, e1', args')
568 | Q.Match (label, e, clist) ->
569 let acc, e' = tra acc e in
570 let acc, clist' =
571 List.fold_left_map_stable
572 (fun acc ((p,e) as rule_) ->
573 let acc, e' = tra acc e in
574 acc,
575 if e == e' then rule_ else (p, e')
576 ) acc clist in
577 acc,
578 if e == e' && clist == clist' then input_e else
579 Q.Match (label, e',clist')
580 | Q.Record (label, rl) ->
581 let acc, rl' =
582 List.fold_left_map_stable
583 (fun acc ((s,e) as bnd) ->
584 let acc, e' = tra acc e in
585 acc,
586 if e == e' then bnd else (s, e')
587 ) acc rl in
588 acc,
589 if rl == rl' then input_e else
590 Q.Record (label, rl')
591 | Q.Dot (label, e, field) ->
592 let acc, e' = tra acc e in
593 acc,
594 if e == e' then input_e else
595 Q.Dot (label, e', field)
596 | Q.ExtendRecord (label, field, e1, e2) ->
597 let acc, e1' = tra acc e1 in
598 let acc, e2' = tra acc e2 in
599 acc,
600 if e1 == e1' && e2 == e2' then input_e else
601 Q.ExtendRecord (label, field, e1', e2')
602 | Q.Coerce (label, e, ty) ->
603 let acc, e' = tra acc e in
604 acc,
605 if e == e' then input_e else
606 Q.Coerce (label, e', ty)
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
607 | Q.Path (label, p, kind, select) ->
608 let aux subs acc elt =
609 let (rebuild, exprs) =
610 subs TU.sub_current TU.sub_ignore elt
611 in let (acc, exprs') =
612 List.fold_left_map_stable
613 (fun acc e ->
614 let acc, e' = tra acc e in
615 acc, if e == e' then e else e')
616 acc exprs
617 in acc, if exprs' == exprs then elt else rebuild exprs'
618 in
fccc6851 » MLstate
2011-06-21 Initial open-source release
619 let acc, p' =
620 List.fold_left_map_stable
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
621 (fun acc e1 -> aux Q.Db.sub_path_elt acc e1)
622 acc p
623 in
624 let acc, select' = aux Q.Db.sub_db_select acc select in
625 let acc, kind' = aux Q.Db.sub_db_kind acc kind in
fccc6851 » MLstate
2011-06-21 Initial open-source release
626 acc,
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
627 if p == p' && kind == kind' && select == select' then input_e else
628 Q.Path (label, p', kind', select')
fccc6851 » MLstate
2011-06-21 Initial open-source release
629
630 let fold tra acc e =
631 match e with
632 | Q.Const _
633 | Q.Ident _
634 | Q.Bypass _ -> acc
635
636 | Q.Coerce (_, e, _)
637 | Q.Dot (_, e, _)
638 | Q.Lambda (_, _, e) -> tra acc e
639
640 | Q.ExtendRecord (_, _,e1, e2) -> tra (tra acc e1) e2
641
642 | Q.Apply (_, f, args) ->
643 let acc = tra acc f in
644 List.fold_left tra acc args
645
646 | Q.LetIn (_, bnd, e)
647 | Q.LetRecIn (_, bnd, e) ->
648 let acc =
649 List.fold_left
650 (fun acc (_,e) -> tra acc e) acc bnd in
651 tra acc e
652 | Q.Match (_, e, clist) ->
653 let acc = tra acc e in
654 List.fold_left
655 (fun acc (_,e) -> tra acc e)
656 acc clist
657 | Q.Record (_, rl) ->
658 List.fold_left
659 (fun acc (_,e) -> tra acc e) acc rl
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
660 | Q.Path (_, p, kind, select) ->
661 let aux subs acc elt =
662 let (_rebuild, exprs) =
663 subs TU.sub_current TU.sub_ignore elt
664 in let acc =
665 List.fold_left
666 (fun acc e -> tra acc e)
667 acc exprs
668 in acc
669 in
28521d48 » BourgerieQuentin
2012-01-24 [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
670 let acc =
671 List.fold_left
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
672 (fun acc e -> aux Q.Db.sub_path_elt acc e)
673 acc p
28521d48 » BourgerieQuentin
2012-01-24 [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
674 in
e31e02cd » BourgerieQuentin
2012-04-03 [enhance] compiler: In ast walk use subs db function and handle selec…
675 let acc = aux Q.Db.sub_db_select acc select in
676 let acc = aux Q.Db.sub_db_kind acc kind in
677 acc
fccc6851 » MLstate
2011-06-21 Initial open-source release
678 | Q.Directive (_, _, exprs, _) -> List.fold_left tra acc exprs
679
680 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
681 let map tra e = Traverse.Unoptimized.map foldmap tra e
682 end
683 include Traverse.Make2(S2)
684
685 let fold_with_env add_env env folder acc expr =
686 let isrec = function
687 | Q.LetIn _ -> false
688 | Q.LetRecIn _ -> true
689 | _ -> assert false in
690 let add_bnd env (n,expr) = add_env env n (Some expr) in
691 let add_lambda env n = List.fold_left (fun env n -> add_env env n None) env n in
692 let add_pat pat env =
693 Pattern.fold_down (* TODO: OPTIMIZE IT *)
694 (fun env pat->
695 match pat with
696 | Q.PatVar (_, v) | Q.PatAs (_,_,v) -> add_env env v None
697 | _ -> env
698 ) env pat in
699 let rec process_expr tra env acc expr =
700 let acc = folder env acc expr in
701 let orig_e0 = expr in
702 match orig_e0 with
703 | Q.Lambda (_, ids, expr) ->
704 process_expr tra (add_lambda env ids) acc expr
705 | Q.LetIn (_, bnd, expr)
706 | Q.LetRecIn (_, bnd, expr) ->
707 let env_bnd = List.fold_left add_bnd env bnd in
708 let env_let = if isrec orig_e0 then env_bnd else env in
709 let acc = List.fold_left (fun acc (_,expr) -> process_expr tra env_let acc expr) acc bnd in
710 process_expr tra env_bnd acc expr
711 | Q.Match (_, expr, clist) ->
712 let acc = process_expr tra env acc expr in
713 List.fold_left (fun acc rule_ -> process_pattern_expr tra env acc rule_) acc clist
714 | _ -> tra env acc expr
715 and process_pattern_expr tra env acc (pat,expr) =
716 let env_bnd = add_pat pat env in
717 process_expr tra env_bnd acc expr in
718 traverse_fold_context_down process_expr env acc expr
719
720 let fold_with_exprmap ?(env=IdentMap.empty) f a e =
721 fold_with_env (fun map id optval -> IdentMap.add id optval map) env f a e
722
723 end
724
725 module ExprPatt = struct
726 let iter_down f_expr f_pat =
727 Expr.iter_down
728 (fun e ->
729 f_expr e;
730 match e with
731 | Q.Match (_, _, clst) -> List.iter (fun (p, _e) -> Pattern.iter_down f_pat p) clst
732 | _ -> ())
733 let iter = iter_down
734
735 let extend_pat f_expr f_pat acc e =
736 let acc, e = f_expr acc e in
737 match e with
738 | Q.Match (label, x, clst) ->
739 let acc, clst = List.fold_left_map
740 (fun acc (p, e) ->
741 let acc, p = Pattern.foldmap_down f_pat acc p
742 in acc, (p, e)) acc clst in
743 acc, Q.Match (label, x, clst)
744 | e0 -> acc, e0
745
746 let foldmap_down f_expr f_pat = Expr.foldmap_down (extend_pat f_expr f_pat)
747 let foldmap = foldmap_down
748
749 let map_down f_expr f_pat = make_map Expr.foldmap_down (rm_void_acc (extend_pat (add_void_acc f_expr) (add_void_acc f_pat)))
750 let map = map_down
751
752 let fold_down f_expr f_pat a e =
753 let f_expr a e = (f_expr a e, e)
754 and f_pat a p = (f_pat a p, p) in
755 fst (foldmap_down f_expr f_pat a e)
756 let fold = fold_down
757 end
758
759 (** todo : return an expr0 option instead of saying just yes or no will upgrade error messages *)
760 module UseDb =
761 struct
762 let expr expr =
763 let use_db = function
764 | Q.Path _ ->
765 true
766 (* FIXME: what about library calls that need the DB ? *)
767 | _ ->
768 false
769 in
770 Expr.exists_down use_db expr
771
772 let code_elt ?(ignore_declaration=false) = function
773 | Q.Database _
774 | Q.NewDbValue _ -> not ignore_declaration
775 | Q.NewType _ -> false
776 | Q.NewVal (_, v)
777 | Q.NewValRec (_, v) -> List.exists (fun (_, e) -> expr e) v
778
779 let code ?(ignore_declaration=false) code =
780 List.exists (code_elt ~ignore_declaration) code
781 end
782
783 module Misc =
784 struct
785 let rec remove_coerce = function
786 | Q.Coerce (_, x, _) -> remove_coerce x
787 | x -> x
788
789 let code_size code = CodeExpr.fold (fun acc e -> Expr.fold (fun acc _ -> acc + 1) acc e) 0 code
790 end
Something went wrong with that request. Please try again.