Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 501 lines (404 sloc) 12.825 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
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
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19
20
21 (* refactoring in progress *)
22 (* depends *)
23 module List = BaseList
24 module String = BaseString
25
26 (* alias *)
27 module TypeIdent = QmlAst.TypeIdent
28
29 (* shorthands *)
30 module Q = QmlAst
31
32 (* -- *)
33
34
35 let rec traverse_coerce e = match e with
36 | Q.Coerce (_, e, _) -> traverse_coerce e
37 | _ -> e
38
39 let map_exprident code f =
40 let f' x = match x with
41 | Q.Ident (label, y) ->
42 let fy = f y in
43 if y == fy then x else Q.Ident (label, fy)
44 | _ -> x
45 in QmlAstWalk.CodeExpr.map (QmlAstWalk.Expr.map_up f') code
46
47 let rec get_deeper_expr ?(except=fun _ -> false) e =
48 if except e then e
49 else
50 match e with
51 (* special forms to document !!! *)
52 | Q.LetIn (_, [id, e1], Q.Ident (_, id'))
53 | Q.LetRecIn (_, [id, e1], Q.Ident (_, id')) when Ident.equal id id' ->
54 get_deeper_expr ~except e1
55
56 (* forms with a unique inner expr *)
57 | Q.LetIn (_, _, e) | Q.LetRecIn (_, _, e)
58 | Q.Lambda (_, _, e) | Q.Coerce (_, e, _)
59 | Q.Match (_, _, [_, e])
60
61 -> get_deeper_expr ~except e
62
63 | Q.Dot _ | Q.Path _
64 | Q.Bypass _
65 | Q.Ident _ | Q.Const _
66 | Q.Record _ | Q.ExtendRecord _
67 | Q.Apply _ | Q.Directive _
68 | Q.Match _ -> e
69
70
71 let substitute old_expr new_expr e =
72 let old_annot = Q.QAnnot.expr old_expr in
73 let aux tra e =
74 if Annot.equal (Q.QAnnot.expr e) old_annot
75 then new_expr
76 else tra e
77 in
78 QmlAstWalk.Expr.traverse_map aux e
79
80 let collect_annot old_annot e =
81 let coll tra acc e =
82 if Annot.equal (Q.QAnnot.expr e) old_annot
83 then e::acc
84 else tra acc e
85 in
86 QmlAstWalk.Expr.traverse_fold coll [] e
87
88 let collect old_expr e =
89 let old_annot = Q.QAnnot.expr old_expr in
90 collect_annot old_annot e
91
92 type stop_expansiveness =
93 [ `nonexpansive
94 | `unsafe_cast
95 | `fail
96 | `todo
97 ]
98 type ('a,'b,'c) strictly_non_expansive =
99 [ `expand of 'a
100 | `doctype of 'b
101 | `sliced_expr
102 | `warncoerce
103 | `specialize of 'c
104 | `may_cps
105 | Q.opavalue_directive
8edc001 [feature] adding: an @async directive on bindings to perform asynchro…
Valentin Gatien-Baron authored
106 | `async
fccc685 Initial open-source release
MLstate authored
107 ]
108 type non_expansive = [
109 | `module_
110 | `recval
111 | Q.slicer_directive
5e7b855 @OpaOnWindowsNow [fix] value restriction,qmlAstUtils: expansiveness detection now trav…
OpaOnWindowsNow authored
112 | Q.closure_instrumentation_directive
fccc685 Initial open-source release
MLstate authored
113 ]
114
115 let rec is_expansive e =
116 match e with
117 | Q.Const _
118 | Q.Ident _
119 | Q.Lambda _
120 | Q.Bypass _ -> false
121
122 | Q.Apply _ -> true
123
124 | Q.LetIn (_, bindings, expr)
125 | Q.LetRecIn (_, bindings, expr) ->
126 List.exists is_expansive (List.map snd bindings)
127 || is_expansive expr
128
129 | Q.Match (_, expr, branches) ->
130 List.exists is_expansive (List.map snd branches)
131 || is_expansive expr
132
133 | Q.Record (_, fields) ->
134 List.exists is_expansive (List.map snd fields)
135
136 | Q.Dot (_, expr, _)
137 | Q.Coerce (_, expr, _)
138 -> is_expansive expr
139
140 | Q.Directive (_, `llarray, [], _) ->
141 false (* the empty array is the only one that is not expansive
142 * because it is not mutable *)
143
144 | Q.Directive (_, `deprecated, args, _) -> (
145 match args with
146 | [ _ ; expr ] -> is_expansive expr
147 | _ ->
148 (*
149 wrong argument, ill typed
150 *)
151 assert false
152 )
153
154 | Q.Directive (_, #stop_expansiveness, _, _) ->
155 false
156
157 | Q.Directive (_, (#strictly_non_expansive | #non_expansive), exprs, _)
158 -> List.exists is_expansive exprs
159
160 | Q.ExtendRecord (_, _, e1, e2) -> is_expansive e1 || is_expansive e2
161
162 | Q.Path (_, elt, _) -> List.exists is_expansive_dbpath_expr_elt elt
163 | Q.Directive _ -> true
164
165 and is_expansive_dbpath_expr_elt e =
166 match e with
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored
167 | Q.Db.ExprKey e -> is_expansive e
fccc685 Initial open-source release
MLstate authored
168 | _ -> false
169
170 let rec is_expansive_strict e =
171 match e with
172 | Q.Const _
173 | Q.Ident _
174 | Q.Lambda _
175 | Q.Bypass _ -> false
176
177 | Q.Apply _
178 | Q.Record _ -> true
179
180 | Q.LetIn (_, bindings, expr)
181 | Q.LetRecIn (_, bindings, expr) ->
182 List.exists is_expansive_strict (List.map snd bindings)
183 || is_expansive_strict expr
184
185 | Q.Match (_, expr, branches) ->
186 List.exists is_expansive_strict (List.map snd branches)
187 || is_expansive_strict expr
188
189 | Q.Dot (_, expr, _)
190 | Q.Coerce (_, expr, _) -> is_expansive_strict expr
191
192 | Q.ExtendRecord (_, _, e1, e2) -> is_expansive_strict e1 || is_expansive_strict e2
193
194 | Q.Path (_, elt, _) -> List.exists is_expansive_strict_dbpath_expr_elt elt
195
196 | Q.Directive (_, #strictly_non_expansive, exprs, _)
197 -> List.exists is_expansive_strict exprs
198
199 | Q.Directive _ -> true
200
201 and is_expansive_strict_dbpath_expr_elt e =
202 match e with
28521d4 @BourgerieQuentin [enhance] compiler: (big) Added Update Ast, Added plain node, Added m…
BourgerieQuentin authored
203 | Q.Db.ExprKey e -> is_expansive_strict e
fccc685 Initial open-source release
MLstate authored
204 | _ -> false
205
206 let is_expansive_with_options = function
207 | `disabled -> (fun _ -> false)
208 | `normal -> is_expansive
209 | `strict -> is_expansive_strict
210
211 module App =
212 struct
213 type 'a util = Q.expr -> Q.expr list -> 'a
214
215 let to_list ?(strict=true) e =
216 match e with
217 | Q.Apply (_, f, args) -> f::args
218 | _ ->
219 if strict then invalid_arg "QmlAstUtils.App.to_list"
220 else [e]
221
222 let from_list l =
223 match l with
224 | f::args -> QmlAstCons.UntypedExpr.apply f args
225 | _ -> invalid_arg "QmlAstUtils.App.from_list"
226
227 let nary_args_number _f args = List.length args
228
229 let curryfied_args_number f _x =
230 let rec aux cpt e =
231 match e with
232 (* | Directive (#structural_ignored_directive, ...) *)
233 | Q.Apply (_, f, args) -> aux (cpt + List.length args) f
234 | _ -> cpt
235 in
236 aux 1 f
237 end
238
239 module ExprIdent =
240 struct
241 let string = function
242 | Q.Ident (_, n) -> Ident.to_uniq_string n
243 | _ -> assert false
244
245 let change_ident id expr =
246 match expr with
247 | Q.Ident (label, _) -> Q.Ident (label, id)
248 | _ -> invalid_arg "QmlAstUtils.Ident.change_ident"
249
250 let substitute ident_map expr =
251 let aux expr =
252 match expr with
253 | Q.Ident (_, i) -> (
254 match IdentMap.find_opt i ident_map with
255 | Some e -> e ()
256 | None -> expr
257 )
258 | _ -> expr
259 in
260 QmlAstWalk.Expr.map_up aux expr
261 end
262
263 module Lambda =
264 struct
265 type 'a util = Ident.t list -> Q.expr -> 'a
266
267 let nary_arity params _body = List.length params
268
269 let curryfied_arity params body =
270 let rec aux cpt e =
271 match e with
272 (* | Directive (#structural_ignored_directive, ...) -> aux cpt expr *)
273 | Q.Coerce (_, e, _) -> aux cpt e
274 | Q.Lambda (_, params, body) -> aux (cpt + List.length params) body
275 | _ -> cpt
276 in aux (List.length params) body
277
278 (* deprecated *)
279 let count e =
280 match e with
281 | Q.Lambda (_, params, body) -> curryfied_arity params body
282 | _ -> 0
283
71c1799 @fpessaux [fix] Missing position: OPA-697. Fixed all other cases in labmda-lift…
fpessaux authored
284
285
286 (* ************************************************************************ *)
287 (** {b Visibility}: Exported outside this module. *)
288 (* ************************************************************************ *)
fccc685 Initial open-source release
MLstate authored
289 let eta_expand_ast arity e =
71c1799 @fpessaux [fix] Missing position: OPA-697. Fixed all other cases in labmda-lift…
fpessaux authored
290 (* Use as position for of generated pieces of code, the position of the
291 currently processed expression. *)
292 let pos = Q.Pos.expr e in
293 let idents =
294 List.init
295 arity (fun i -> Ident.next (Printf.sprintf "eta_%d_%d" i arity)) in
296 let exps =
297 List.map
298 (fun i ->
299 let label = Annot.next_label pos in
300 QmlAstCons.UntypedExprWithLabel.ident ~label i)
301 idents in
302 let label_lambda = Annot.next_label pos in
303 let label_apply = Annot.next_label pos in
304 QmlAstCons.UntypedExprWithLabel.lambda
305 ~label: label_lambda idents
306 (QmlAstCons.UntypedExprWithLabel.apply ~label: label_apply e exps)
fccc685 Initial open-source release
MLstate authored
307 end
308
309 module Coerce =
310 struct
311
312 let uncoerce e =
313 let rec aux e acc =
314 match e with
315 | Q.Coerce (_, e, ty)-> aux e ((Q.Label.expr e, ty)::acc)
316 | _ -> e, acc
317 in aux e []
318
319 let recoerce e lanty =
320 List.foldl (fun (label, ty) e -> QmlAstCons.UntypedExprWithLabel.coerce ~label e ty) lanty e
321
322 let rm_coerces e = fst (uncoerce e)
323 end
324
325 module FreeVars =
326 struct
327
328 let pat_fold f pat acc0 =
329 let aux acc pat = match pat with
330 | Q.PatVar (label, i) | Q.PatAs (label, _, i) ->
331 f acc (Annot.annot label) i
332 | _ -> acc
333 in
334 QmlAstWalk.Pattern.fold_down aux acc0 pat
335
336 let pat pat = pat_fold (fun acc _ i -> IdentSet.add i acc) pat IdentSet.empty
337
338 let expr_fold f expr acc0 =
339 QmlAstWalk.Expr.fold_with_exprmap
340 (fun bound acc e -> match e with
341 | Q.Ident (label, i) when IdentMap.find_opt i bound = None ->
342 f acc (Annot.annot label) i
343 | _ -> acc)
344 acc0 expr
345
346 let expr pat = expr_fold (fun acc _ i -> IdentSet.add i acc) pat IdentSet.empty
347
348 end
349
350 module Const =
351 struct
352 let compare a b =
353 match a, b with
354 | Q.Int a, Q.Int b -> Pervasives.compare a b
355 | Q.Float a, Q.Float b -> Pervasives.compare a b
356 | Q.String a, Q.String b -> String.compare a b
357 | _ -> assert false
358
359 let equal a b = compare a b = 0
360 end
361
362 module Record =
363 struct
364 type 'a util = (string * Q.expr) list -> 'a
365
366 let uncons_tuple fields =
367 let mapi i (f, e) =
368 let field = QmlAstCons.Tuple.field (succ i) in
369 if String.compare f field <> 0
370 then raise Not_found
371 else e
372 in
373 try Some (List.mapi mapi fields)
374 with
375 | Not_found -> None
376
377 let uncons_qml_tuple fields =
378 let (@=) s s' = String.compare s s' = 0 in
379 let s_fst = QmlAstCons.Tuple.qml_fst in
380 let s_snd = QmlAstCons.Tuple.qml_snd in
381 let rec aux ?(fail=true) acc fields =
382 match fields with
383 | [ ( ss_fst, fst ) ; ( ss_snd, Q.Record (_, fields)) ]
384 when s_fst @= ss_fst && s_snd @= ss_snd
385 -> aux ~fail:false (fst::acc) fields
386 | [ ( ss_fst, fst ) ; ( ss_snd, snd ) ]
387 when s_fst @= ss_fst && s_snd @= ss_snd
388 -> List.rev (snd::fst::acc)
389 | _ ->
390 if fail then raise Not_found
391 else
392 List.rev ((QmlAstCons.UntypedExpr.record fields)::acc)
393 in
394 try
395 Some (aux [] fields)
396 with Not_found -> None
397
398 let uncons fields_exprs_list = List.split fields_exprs_list
399
400 let cons fields exprs =
401 QmlAstCons.UntypedExpr.record (List.combine fields exprs)
402 end
403
404 module Tuple =
405 struct
406 let uncons e =
407 match (traverse_coerce e) with
408 | Q.Record (_, fields) -> Record.uncons_tuple fields
409 | _ -> None
410
411 let uncons_typeident typeident =
412 match String.split_char '_' (QmlAst.TypeIdent.to_string typeident) with
413 | "tuple", r -> Base.int_of_string_opt r
414 | _ -> None
415
416 let uncons_qml_tuple e =
417 match (traverse_coerce e) with
418 | Q.Record (_, fields) -> Record.uncons_qml_tuple fields
419 | _ -> None
420 end
421
422 module Pat = QmlAstWatch.Pat
423
424 module Match =
425 struct
426 type 'a util = Q.expr -> (Q.pat * Q.expr) list -> 'a
427
428 let uncons_ifthenelse = QmlAstWatch.uncons_ifthenelse
429
430 let uncons if_ pats_exprs =
431 let pats, expr = List.split pats_exprs in
432 (if_, pats, expr)
433
434 let cons if_ pats exprs =
435 let p = List.combine pats exprs in
436 QmlAstCons.UntypedExpr.match_ if_ p
437
438 end
439
440 module LetIn =
441 struct
442 type 'a util = (Q.ident * Q.expr) list -> Q.expr -> 'a
443
444 let rev_uncons (l : (Q.ident * Q.expr) list) e =
445 let rec aux acc e =
446 match e with
447 | Q.LetIn (_, l, e) -> aux (l::acc) e
448 | _ -> acc,e
449 in aux [l] e
450
451 let uncons (l : (Q.ident * Q.expr) list) e =
452 let rev_u,e = rev_uncons l e in
453 List.rev rev_u, e
454
455 let cons l e =
456 List.fold_right
457 (fun l e -> QmlAstCons.UntypedExpr.letin l e) l e
458 end
459
460 module LetRecIn =
461 struct
462 type 'a util = (Q.ident * Q.expr) list -> Q.expr -> 'a
463
464 let rev_uncons (l : (Q.ident * Q.expr) list) e =
465 let rec aux acc e =
466 match e with
467 | Q.LetRecIn (_, l, e) -> aux (l::acc) e
468 | _ -> acc,e
469 in aux [l] e
470
471 let uncons (l : (Q.ident * Q.expr) list) e =
472 let rev_u,e = rev_uncons l e in
473 List.rev rev_u, e
474
475 let cons l e =
476 List.fold_right
477 (fun l e -> QmlAstCons.UntypedExpr.letrecin l e) l e
478 end
479
480 module Code =
481 struct
482 let insert ~deps ~insert code =
483 let last = function
484 | Q.NewVal (_, bindings)
485 | Q.NewValRec (_, bindings) ->
486 List.exists (fun (i, _) -> IdentSet.mem i deps) bindings
487 | _ -> false
488 in
489 let rec aux acc = function
490 | [] ->
491 insert @ acc
492 | code_elt :: tl ->
493 if last code_elt
494 then
495 List.rev_append tl (code_elt ::(insert @ acc))
496 else
497 aux (code_elt::acc) tl
498 in
499 aux [] (List.rev code)
500 end
Something went wrong with that request. Please try again.