Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 450 lines (368 sloc) 11.4 kB
fccc685 Initial open-source release
MLstate authored
1 (*
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
2 Copyright © 2011, 2012 MLstate
fccc685 Initial open-source release
MLstate authored
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
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
107 | `deprecated
fccc685 Initial open-source release
MLstate authored
108 ]
109 type non_expansive = [
110 | `module_
111 | `recval
112 | Q.slicer_directive
5e7b855 @OpaOnWindowsNow [fix] value restriction,qmlAstUtils: expansiveness detection now trav…
OpaOnWindowsNow authored
113 | Q.closure_instrumentation_directive
fccc685 Initial open-source release
MLstate authored
114 ]
115
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
116 let is_expansive =
117 QmlAstWalk.Expr.traverse_exists
118 (fun tra -> function
119 | Q.Const _
120 | Q.Ident _
121 | Q.Lambda _
122 | Q.Bypass _ -> false
fccc685 Initial open-source release
MLstate authored
123
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
124 | Q.Directive (_, `llarray, [], _) ->
fccc685 Initial open-source release
MLstate authored
125 false (* the empty array is the only one that is not expansive
126 * because it is not mutable *)
127
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
128 | Q.Directive (_, #stop_expansiveness, _, _) ->
fccc685 Initial open-source release
MLstate authored
129 false
130
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
131 | Q.Directive (_, (#strictly_non_expansive | #non_expansive), _exprs, _) as d
132 -> tra d
fccc685 Initial open-source release
MLstate authored
133
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
134 | Q.Directive _ -> true
135 | Q.Apply _ -> true
136 | e -> tra e)
fccc685 Initial open-source release
MLstate authored
137
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
138 let is_expansive_strict =
139 QmlAstWalk.Expr.traverse_exists
140 (fun tra -> function
141 | Q.Const _
142 | Q.Ident _
143 | Q.Lambda _
144 | Q.Bypass _ -> false
145 | Q.Apply _
146 | Q.Record _ -> true
fccc685 Initial open-source release
MLstate authored
147
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
148 | Q.Directive (_, #strictly_non_expansive, _exprs, _) as d
149 -> tra d
fccc685 Initial open-source release
MLstate authored
150
3c87af4 @BourgerieQuentin [enhance] compiler, utils: Use traverse
BourgerieQuentin authored
151 | Q.Directive _ -> true
152 | e -> tra e
153 )
fccc685 Initial open-source release
MLstate authored
154
155 let is_expansive_with_options = function
156 | `disabled -> (fun _ -> false)
157 | `normal -> is_expansive
158 | `strict -> is_expansive_strict
159
160 module App =
161 struct
162 type 'a util = Q.expr -> Q.expr list -> 'a
163
164 let to_list ?(strict=true) e =
165 match e with
166 | Q.Apply (_, f, args) -> f::args
167 | _ ->
168 if strict then invalid_arg "QmlAstUtils.App.to_list"
169 else [e]
170
171 let from_list l =
172 match l with
173 | f::args -> QmlAstCons.UntypedExpr.apply f args
174 | _ -> invalid_arg "QmlAstUtils.App.from_list"
175
176 let nary_args_number _f args = List.length args
177
178 let curryfied_args_number f _x =
179 let rec aux cpt e =
180 match e with
181 (* | Directive (#structural_ignored_directive, ...) *)
182 | Q.Apply (_, f, args) -> aux (cpt + List.length args) f
183 | _ -> cpt
184 in
185 aux 1 f
186 end
187
188 module ExprIdent =
189 struct
190 let string = function
191 | Q.Ident (_, n) -> Ident.to_uniq_string n
192 | _ -> assert false
193
194 let change_ident id expr =
195 match expr with
196 | Q.Ident (label, _) -> Q.Ident (label, id)
197 | _ -> invalid_arg "QmlAstUtils.Ident.change_ident"
198
199 let substitute ident_map expr =
200 let aux expr =
201 match expr with
202 | Q.Ident (_, i) -> (
203 match IdentMap.find_opt i ident_map with
204 | Some e -> e ()
205 | None -> expr
206 )
207 | _ -> expr
208 in
209 QmlAstWalk.Expr.map_up aux expr
210 end
211
212 module Lambda =
213 struct
214 type 'a util = Ident.t list -> Q.expr -> 'a
215
216 let nary_arity params _body = List.length params
217
218 let curryfied_arity params body =
219 let rec aux cpt e =
220 match e with
221 (* | Directive (#structural_ignored_directive, ...) -> aux cpt expr *)
222 | Q.Coerce (_, e, _) -> aux cpt e
223 | Q.Lambda (_, params, body) -> aux (cpt + List.length params) body
224 | _ -> cpt
225 in aux (List.length params) body
226
227 (* deprecated *)
228 let count e =
229 match e with
230 | Q.Lambda (_, params, body) -> curryfied_arity params body
231 | _ -> 0
232
71c1799 @fpessaux [fix] Missing position: OPA-697. Fixed all other cases in labmda-lift…
fpessaux authored
233
234
235 (* ************************************************************************ *)
236 (** {b Visibility}: Exported outside this module. *)
237 (* ************************************************************************ *)
fccc685 Initial open-source release
MLstate authored
238 let eta_expand_ast arity e =
71c1799 @fpessaux [fix] Missing position: OPA-697. Fixed all other cases in labmda-lift…
fpessaux authored
239 (* Use as position for of generated pieces of code, the position of the
240 currently processed expression. *)
241 let pos = Q.Pos.expr e in
242 let idents =
243 List.init
244 arity (fun i -> Ident.next (Printf.sprintf "eta_%d_%d" i arity)) in
245 let exps =
246 List.map
247 (fun i ->
248 let label = Annot.next_label pos in
249 QmlAstCons.UntypedExprWithLabel.ident ~label i)
250 idents in
251 let label_lambda = Annot.next_label pos in
252 let label_apply = Annot.next_label pos in
253 QmlAstCons.UntypedExprWithLabel.lambda
254 ~label: label_lambda idents
255 (QmlAstCons.UntypedExprWithLabel.apply ~label: label_apply e exps)
fccc685 Initial open-source release
MLstate authored
256 end
257
258 module Coerce =
259 struct
260
261 let uncoerce e =
262 let rec aux e acc =
263 match e with
264 | Q.Coerce (_, e, ty)-> aux e ((Q.Label.expr e, ty)::acc)
265 | _ -> e, acc
266 in aux e []
267
268 let recoerce e lanty =
269 List.foldl (fun (label, ty) e -> QmlAstCons.UntypedExprWithLabel.coerce ~label e ty) lanty e
270
271 let rm_coerces e = fst (uncoerce e)
272 end
273
274 module FreeVars =
275 struct
276
277 let pat_fold f pat acc0 =
278 let aux acc pat = match pat with
279 | Q.PatVar (label, i) | Q.PatAs (label, _, i) ->
280 f acc (Annot.annot label) i
281 | _ -> acc
282 in
283 QmlAstWalk.Pattern.fold_down aux acc0 pat
284
285 let pat pat = pat_fold (fun acc _ i -> IdentSet.add i acc) pat IdentSet.empty
286
287 let expr_fold f expr acc0 =
288 QmlAstWalk.Expr.fold_with_exprmap
289 (fun bound acc e -> match e with
290 | Q.Ident (label, i) when IdentMap.find_opt i bound = None ->
291 f acc (Annot.annot label) i
292 | _ -> acc)
293 acc0 expr
294
295 let expr pat = expr_fold (fun acc _ i -> IdentSet.add i acc) pat IdentSet.empty
296
297 end
298
299 module Const =
300 struct
301 let compare a b =
302 match a, b with
303 | Q.Int a, Q.Int b -> Pervasives.compare a b
304 | Q.Float a, Q.Float b -> Pervasives.compare a b
305 | Q.String a, Q.String b -> String.compare a b
306 | _ -> assert false
307
308 let equal a b = compare a b = 0
309 end
310
311 module Record =
312 struct
313 type 'a util = (string * Q.expr) list -> 'a
314
315 let uncons_tuple fields =
316 let mapi i (f, e) =
317 let field = QmlAstCons.Tuple.field (succ i) in
318 if String.compare f field <> 0
319 then raise Not_found
320 else e
321 in
322 try Some (List.mapi mapi fields)
323 with
324 | Not_found -> None
325
326 let uncons_qml_tuple fields =
327 let (@=) s s' = String.compare s s' = 0 in
328 let s_fst = QmlAstCons.Tuple.qml_fst in
329 let s_snd = QmlAstCons.Tuple.qml_snd in
330 let rec aux ?(fail=true) acc fields =
331 match fields with
332 | [ ( ss_fst, fst ) ; ( ss_snd, Q.Record (_, fields)) ]
333 when s_fst @= ss_fst && s_snd @= ss_snd
334 -> aux ~fail:false (fst::acc) fields
335 | [ ( ss_fst, fst ) ; ( ss_snd, snd ) ]
336 when s_fst @= ss_fst && s_snd @= ss_snd
337 -> List.rev (snd::fst::acc)
338 | _ ->
339 if fail then raise Not_found
340 else
341 List.rev ((QmlAstCons.UntypedExpr.record fields)::acc)
342 in
343 try
344 Some (aux [] fields)
345 with Not_found -> None
346
347 let uncons fields_exprs_list = List.split fields_exprs_list
348
349 let cons fields exprs =
350 QmlAstCons.UntypedExpr.record (List.combine fields exprs)
351 end
352
353 module Tuple =
354 struct
355 let uncons e =
356 match (traverse_coerce e) with
357 | Q.Record (_, fields) -> Record.uncons_tuple fields
358 | _ -> None
359
360 let uncons_typeident typeident =
361 match String.split_char '_' (QmlAst.TypeIdent.to_string typeident) with
362 | "tuple", r -> Base.int_of_string_opt r
363 | _ -> None
364
365 let uncons_qml_tuple e =
366 match (traverse_coerce e) with
367 | Q.Record (_, fields) -> Record.uncons_qml_tuple fields
368 | _ -> None
369 end
370
371 module Pat = QmlAstWatch.Pat
372
373 module Match =
374 struct
375 type 'a util = Q.expr -> (Q.pat * Q.expr) list -> 'a
376
377 let uncons_ifthenelse = QmlAstWatch.uncons_ifthenelse
378
379 let uncons if_ pats_exprs =
380 let pats, expr = List.split pats_exprs in
381 (if_, pats, expr)
382
383 let cons if_ pats exprs =
384 let p = List.combine pats exprs in
385 QmlAstCons.UntypedExpr.match_ if_ p
386
387 end
388
389 module LetIn =
390 struct
391 type 'a util = (Q.ident * Q.expr) list -> Q.expr -> 'a
392
393 let rev_uncons (l : (Q.ident * Q.expr) list) e =
394 let rec aux acc e =
395 match e with
396 | Q.LetIn (_, l, e) -> aux (l::acc) e
397 | _ -> acc,e
398 in aux [l] e
399
400 let uncons (l : (Q.ident * Q.expr) list) e =
401 let rev_u,e = rev_uncons l e in
402 List.rev rev_u, e
403
404 let cons l e =
405 List.fold_right
406 (fun l e -> QmlAstCons.UntypedExpr.letin l e) l e
407 end
408
409 module LetRecIn =
410 struct
411 type 'a util = (Q.ident * Q.expr) list -> Q.expr -> 'a
412
413 let rev_uncons (l : (Q.ident * Q.expr) list) e =
414 let rec aux acc e =
415 match e with
416 | Q.LetRecIn (_, l, e) -> aux (l::acc) e
417 | _ -> acc,e
418 in aux [l] e
419
420 let uncons (l : (Q.ident * Q.expr) list) e =
421 let rev_u,e = rev_uncons l e in
422 List.rev rev_u, e
423
424 let cons l e =
425 List.fold_right
426 (fun l e -> QmlAstCons.UntypedExpr.letrecin l e) l e
427 end
428
429 module Code =
430 struct
431 let insert ~deps ~insert code =
432 let last = function
433 | Q.NewVal (_, bindings)
434 | Q.NewValRec (_, bindings) ->
435 List.exists (fun (i, _) -> IdentSet.mem i deps) bindings
436 | _ -> false
437 in
438 let rec aux acc = function
439 | [] ->
440 insert @ acc
441 | code_elt :: tl ->
442 if last code_elt
443 then
444 List.rev_append tl (code_elt ::(insert @ acc))
445 else
446 aux (code_elt::acc) tl
447 in
448 aux [] (List.rev code)
449 end
Something went wrong with that request. Please try again.