Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 621 lines (520 sloc) 22.305 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 Intermediate language for CPS transformations.
20
21 This language is based on "Compiling with Continuations, Continued",
22 by Andrew Kennedy, in Proceedings of ICFP 2007.
23
24 Note: In a near-future, the algebraic structure will be
25 in part replaced by a graph structure, which permits
26 numerous phases of optimization in O(n) rather than O(n^2)
27
28 This file has no mli because it would just duplicate the IL ast.
29
30 The file define a module IL because for convenience we write :
31
32 IL.Continuation, IL.Bypass, etc... because of clash of constructor names
33 between this module and the module QmlAst.
34
35 We do not want to write the name of the module (QmlCpsIL),
36 and neither do an 'open' leading to having constructors like Bypass in the
37 scope.
38
39 @author David Rajchenbach-Teller
40 @author Mathieu Barbin
41 @author Rudy Sicard
42 *)
43
44 (**
45 TODO : if needed, the cps rewriter should return consistents gamma & annotmap
46 The IL ast should be updated to support annotation
47 *)
48
49 module IL = struct
50 type ident = Ident.t
51
52 (** The name of a continuation.
53 This may be replaced in the future by a (cident, ExprIdent.t) UnionFind.t
54 where cident will be a black type. *)
55 type cident = Continuation of ident
56
57 (** The name of a value.
58 Same remark, (vident, ExprIdent.t) UnionFind.t *)
59 type vident = Value of ident
60
61 (**The name of a field*)
62 type fident = Field of string
63
64 (** skey, restriction option.
65 The restriction arg is used to distinguish between :
66 - standard bypass : {[QmlAst.Bypass key]}
67 represented by : {[IL.Bypass (key, None)]}
68 - restricted bypass : {[QmlAst.Directive (`restricted_bypass pass_id, [{ e = Bypass key }], _)|}
69 the pass_id the string contained in the string option in this case :
70 represented by : {[IL.Bypass (key, Some pass_id)]} *)
71 type bypass = Bypass of (BslKey.t * string option)
72
73 (* used to build stack traces *)
74 type stack_trace_info =
75 { caller_cont : cident option; (** continuation of the closest enclosing function if any *)
76 callee_name : string option; (** local name of the function we're calling if any *)
77 position : string option; (** position of the Apply if any *) }
78
79 (* TODO : see if this is needed for later optimizations *)
80 (*The type of a function definition*)
81 (*
82 type func =
83 {return: cident;
84 (**[None] if the function takes place outside of a transaction.*)
85 transact: cident option;
86 (* (**[None] if the function is called from outside a request.*)
87 request: cident option; *)
88 arg: vident;
89 term: term}
90 and application =
91 {app_called: vident;
92 app_return: cident;
93 app_transact: cident option;
94 app_term
95 }
96 *)
97 (* not used yet, either
98 type application =
99 {app_called: vident
100 ;app_arg: vident
101 ;app_return: cident
102 ;app_transaction: cident option
103 }
104 *)
105
106 type value =
107 | Constant of QmlAst.const_expr
108 | Record of (fident * vident * Annot.t) list
109 | ExtendRecord of (fident * vident) list * vident
110 | LazyRecord of (fident * vident * Annot.t) list * vident option
111 | BasicBypass of bypass (* for value bypass only (not functions) *)
112 | ValueSkip of QmlAst.expr
113
114 and cps_function = CpsVident of vident | CpsBypass of bypass
115
116 and term =
117
118 (**[LetVal("x", v, t)] represents [let x = v in t].
119 At this stage, this is the only way of using a value in a term. *)
120 | LetVal of vident * value * term
121
122 (**[LetProj("x", ("y", "foo"), t)] represents [let x = y.foo in t].
123 This is the only way of accessing a field. *)
124 | LetProj of vident * (vident * fident) * term
125
126 (**[LetCont(("k", "x", t, u), parent)] represents
127 [let(*continuation*) k (x -> t) in u].
128 This introduces a continuation [k] with one unique argument [x],
129 to be used in [u].
130 the parent is an option of the parent continuation id.
131
132 <!> Assert: x MUST be fresh and appear ONLY in t
133 or it would definitly break the substitution mechanism.
134 *)
135 | LetCont of ((cident * vident * term * term) * cident option)
136
137 (**Introduce a set of mutually recursive definitions. *)
138 | LetRecFun of ( vident (** function name *)
139 * vident list (** arguments *)
140 * cident (** the continuation *)
141 * term (** body *)
142 ) list * term
143
144 (**Introduce a set of non-recursive definitions. *)
145 | LetFun of (vident * vident list * cident * term) list * term
146
147 (**Apply a continuation to a value, e.g. to jump
148 or return from a function. *)
149 | ApplyCont of cident * vident
150
151 (**[ApplyExpr(a,b,k)] computes [a] (which must be a rewrited-function)
152 with argument [b] and continuation [k]
153 The function [a] used to take arg [b] and return type c
154 [k] is a 'c continuation, and function [a] has been rewritten to
155 'b -> 'c continuation -> unit
156 *)
157 | ApplyExpr of cps_function * vident * cident
158
159 (**
160 Nary mode for application.
161 TODO: remove ApplyExpr from the ast, keep only ApplyNary
162 *)
163 | ApplyNary of cps_function * vident list * cident * stack_trace_info option
164
165 (**
166 Special case of application of a non cps bypass, with all its arguments.
167 Bypasses cannot be currified.
168 *)
169 | ApplyBypass of bypass * (vident list) * cident
170
171 | Match of vident * (QmlAst.pat * term) list
172
173 (**End of program, with result*)
174 | Done of vident * string
175
176 | Directive of
177 (QmlAst.qml_directive * term list * QmlAst.ty list)
178
179 (**In some cases, no operation, keep the qml 'as it is'*)
180 (**Currently this node is unused*)
181 | Skip of QmlAst.expr
182
183
184 (** tools for code generation *)
185 let fresh_c () = Continuation (Ident.next "cont")
186 let fresh_v () = Value (Ident.next "val")
187
188 let fresh_fun () = Value (Ident.next "fun")
189
190 end
191
192 (** {6 Traversal} *)
193 (** for optimisation and rewriting rules in IL *)
194 (** *)
195 module Subs : TraverseInterface.S2 with type 'a t = IL.term constraint 'a = _ * _ * _ =
196 struct
197 open IL
198 open Base
199 type 'a t = term constraint 'a = _ * _ * _
200
201 let foldmap tra acc t =
202 match t with
203 | LetVal (vident, value, term) ->
204 let acc, fterm = tra acc term in
205 acc,
206 if term == fterm then t else
207 LetVal (vident, value, fterm)
208
209 | LetProj (vident, (vident', fident), term) ->
210 let acc, fterm = tra acc term in
211 acc,
212 if term == fterm then t else
213 LetProj (vident, (vident', fident), fterm)
214
215 | LetCont ((cident, vident, term, term'), cident') ->
216 let acc, fterm = tra acc term in
217 let acc, fterm' = tra acc term' in
218 acc,
219 if term == fterm && term' == fterm' then t else
220 LetCont ((cident, vident, fterm, fterm'), cident')
221
222 | LetRecFun (list, term) ->
223 let foldmap acc ((vident, vident_list, cident, term) as t) =
224 let acc, fterm = tra acc term in
225 acc,
226 if term == fterm then t else
227 (vident, vident_list, cident, fterm) in
228 let acc, flist = List.fold_left_map_stable foldmap acc list in
229 let acc, fterm = tra acc term in
230 acc,
231 if term == fterm && list == flist then t else
232 LetRecFun (flist, fterm)
233
234 | LetFun (list, term) ->
235 let foldmap acc ((vident, vident_list, cident, term) as t) =
236 let acc, fterm = tra acc term in
237 acc,
238 if term == fterm then t else
239 (vident, vident_list, cident, fterm) in
240 let acc, flist = List.fold_left_map_stable foldmap acc list in
241 let acc, fterm = tra acc term in
242 acc,
243 if list == flist && term == fterm then t else
244 LetFun (flist, fterm)
245
246 | ApplyCont (_cident, _vident) -> acc, t
247
248 | ApplyExpr (_cps_function, _vident', _cident) -> acc, t
249
250 | ApplyNary (_cps_function, _vident_list, _cident, _stack_infos) -> acc, t
251
252 | ApplyBypass (_bypass, _vident_list, _cident) -> acc, t
253
254 | Match (vident, pat_term_list) ->
255 let foldmap acc ((pat, term) as t) =
256 let acc, fterm = tra acc term in
257 acc,
258 if term == fterm then t else
259 (pat, fterm) in
260 let acc, fpat_term_list = List.fold_left_map_stable foldmap acc pat_term_list in
261 acc,
262 if pat_term_list == fpat_term_list then t else
263 Match (vident, fpat_term_list)
264
265 | Done (_vident, _string) -> acc, t
266
267 | Directive (qml_directive, terms, tys) ->
268 let acc, fterms = List.fold_left_map_stable tra acc terms in
269 acc,
270 if terms == fterms then t else
271 Directive (qml_directive, fterms, tys)
272
273 | Skip _expr -> acc, t
274
275 let iter x = Traverse.Unoptimized.iter foldmap x
276 let map x = Traverse.Unoptimized.map foldmap x
277 let fold x = Traverse.Unoptimized.fold foldmap x
278 end
279
280 module Walk : TraverseInterface.TRAVERSE
281 with type 'a t = IL.term constraint 'a = _ * _ * _
282 and type 'a container = IL.term constraint 'a = _ * _ * _
283 = Traverse.Make2 ( Subs )
284
285 (* TODO: replace this with the unionFind algorithm *)
286 module IdentWalk :
287 sig
288 open IL
289 val foldmap : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
290 val foldmap_up : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
291 val foldmap_down : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
292 val exists : ident -> value -> bool
293 end =
294 struct
295 open IL
296 open Base
297
298 let foldmap_vident tra acc ((Value id) as v) =
299 let acc, fid = tra acc id in
300 acc,
301 if id == fid then v else
302 Value fid
303
304 let foldmap_cident tra acc ((Continuation id) as v) =
305 let acc, fid = tra acc id in
306 acc,
307 if id == fid then v else
308 Continuation fid
309
310 let foldmap_skip tra acc e =
311 QmlAstWalk.Expr.foldmap
312 (fun acc e ->
313 match e with
314 | QmlAst.Ident (_, id) ->
315 let acc, fid = tra acc id in
316 acc,
317 if id == fid then e else
318 QmlAstCons.UntypedExpr.ident fid
319 | _ -> acc, e
320 ) acc e
321
322 let foldmap_cps_function tra acc cps =
323 match cps with
324 | CpsVident (Value id) ->
325 let acc, fid = tra acc id in
326 acc,
327 if id == fid then cps else
328 CpsVident (Value fid)
329 | _ -> acc, cps
330
331 let foldmap_stack_info tra acc stack_info =
332 match stack_info.caller_cont with
333 | None -> acc, stack_info
334 | Some cident ->
335 let acc, fcident = foldmap_cident tra acc cident in
336 acc,
337 if cident == fcident then stack_info else {stack_info with caller_cont = Some fcident}
338
339 let foldmap_ident_value tra acc t =
340 match t with
341 | Constant _ -> acc, t
342 | Record list ->
343 let foldmap acc ((fident, vident, annot) as t) =
344 let acc, fvident = foldmap_vident tra acc vident in
345 acc,
346 if vident == fvident then t else
347 (fident, fvident, annot) in
348 let acc, flist = List.fold_left_map_stable foldmap acc list in
349 acc,
350 if list == flist then t else
351 Record flist
352 | ExtendRecord (list, vident) ->
353 let foldmap acc ((fident, vident (*, annot*)) as t) =
354 let acc, fvident = foldmap_vident tra acc vident in
355 acc,
356 if vident == fvident then t else
357 (fident, fvident(*, annot*)) in
358 let acc, flist = List.fold_left_map_stable foldmap acc list in
359 let acc, fvident = foldmap_vident tra acc vident in
360 acc,
361 if list == flist && vident == fvident then t else
362 ExtendRecord (flist, fvident)
363 | LazyRecord (list, vident_option) ->
364 let foldmap acc ((fident, vident, annot) as t) =
365 let acc, fvident = foldmap_vident tra acc vident in
366 acc,
367 if vident == fvident then t else
368 (fident, fvident, annot) in
369 let acc, flist = List.fold_left_map_stable foldmap acc list in
370 let acc, fvident_option = Option.foldmap_stable (foldmap_vident tra) acc vident_option in
371 acc,
372 if list == flist && vident_option == fvident_option then t else
373 LazyRecord (flist, fvident_option)
374 | BasicBypass _ -> acc, t
375 | ValueSkip e ->
376 let acc, fe = foldmap_skip tra acc e in
377 acc,
378 if e == fe then t else
379 ValueSkip fe
380
381 let foldmap_ident tra acc t =
382 match t with
383 | LetVal (vident, value, term) ->
384 let acc, fvident = foldmap_vident tra acc vident in
385 let acc, fvalue = foldmap_ident_value tra acc value in
386 acc,
387 if vident == fvident && value == fvalue then t else
388 LetVal (fvident, fvalue, term)
389
390 | LetProj (vident, (vident', fident), term) ->
391 let acc, fvident = foldmap_vident tra acc vident in
392 let acc, fvident' = foldmap_vident tra acc vident' in
393 acc,
394 if vident == fvident && vident' == fvident' then t else
395 LetProj (fvident, (fvident', fident), term)
396
397 | LetCont ((cident, vident, term, term'), cident') ->
398 let acc, fcident = foldmap_cident tra acc cident in
399 let acc, fvident = foldmap_vident tra acc vident in
400 let acc, fcident' = Option.foldmap_stable (foldmap_cident tra) acc cident' in
401 acc,
402 if cident == fcident && vident == fvident && cident' == fcident' then t else
403 LetCont ((fcident, fvident, term, term'), fcident')
404
405 | LetRecFun (list, term) ->
406 let foldmap acc ((vident, vident_list, cident, term) as t)=
407 let acc, fvident = foldmap_vident tra acc vident in
408 let acc, fvident_list = List.fold_left_map_stable (foldmap_vident tra) acc vident_list in
409 let acc, fcident = foldmap_cident tra acc cident in
410 acc,
411 if vident == fvident && vident_list == fvident_list && cident = fcident then t else
412 (fvident, fvident_list, fcident, term) in
413 let acc, flist = List.fold_left_map_stable foldmap acc list in
414 acc,
415 if list == flist then t else
416 LetRecFun (flist, term)
417
418 | LetFun (list, term) ->
419 let foldmap acc ((vident, vident_list, cident, term) as t) =
420 let acc, fvident = foldmap_vident tra acc vident in
421 let acc, fvident_list = List.fold_left_map_stable (foldmap_vident tra) acc vident_list in
422 let acc, fcident = foldmap_cident tra acc cident in
423 acc,
424 if vident == fvident && vident_list == fvident_list && cident == fcident then t else
425 (fvident, fvident_list, fcident, term) in
426 let acc, flist = List.fold_left_map_stable foldmap acc list in
427 acc,
428 if list == flist then t else
429 LetFun (flist, term)
430
431 | ApplyCont (cident, vident) ->
432 let acc, fcident = foldmap_cident tra acc cident in
433 let acc, fvident = foldmap_vident tra acc vident in
434 acc,
435 if cident == fcident && vident == fvident then t else
436 ApplyCont (fcident, fvident)
437
438 | ApplyExpr (cps_function, vident, cident) ->
439 let acc, fcps_function = foldmap_cps_function tra acc cps_function in
440 let acc, fvident = foldmap_vident tra acc vident in
441 let acc, fcident = foldmap_cident tra acc cident in
442 acc,
443 if cps_function == fcps_function && vident == fvident && cident == fcident then t else
444 ApplyExpr (fcps_function, fvident, fcident)
445
446 | ApplyNary (cps_function, vident_list, cident, stack_info_opt) ->
447 let acc, fcps_function = foldmap_cps_function tra acc cps_function in
448 let acc, fvident_list = List.fold_left_map_stable (foldmap_vident tra) acc vident_list in
449 let acc, fcident = foldmap_cident tra acc cident in
450 let acc, fstack_info_opt = Option.foldmap (foldmap_stack_info tra) acc stack_info_opt in
451 acc,
452 if cps_function == fcps_function && vident_list == fvident_list && cident == fcident && stack_info_opt == fstack_info_opt then t else
453 ApplyNary (fcps_function, fvident_list, fcident, fstack_info_opt)
454
455 | ApplyBypass (bypass, vident_list, cident) ->
456 let acc, fvident_list = List.fold_left_map_stable (foldmap_vident tra) acc vident_list in
457 let acc, fcident = foldmap_cident tra acc cident in
458 acc,
459 if vident_list == fvident_list && cident == fcident then t else
460 ApplyBypass (bypass, fvident_list, fcident)
461
462 | Match (vident, pat_term_list) ->
463 let acc, fvident = foldmap_vident tra acc vident in
464 acc,
465 if vident == fvident then t else
466 Match (fvident, pat_term_list)
467
468 | Done (vident, string) ->
469 let acc, fvident = foldmap_vident tra acc vident in
470 acc,
471 if vident == fvident then t else
472 Done (fvident, string)
473
474 | Directive (_qml_directive, _terms, _tys) -> acc, t
475
476 | Skip e ->
477 let acc, fe = foldmap_skip tra acc e in
478 acc,
479 if e == fe then t else
480 Skip fe
481
482 let foldmap tra = Walk.foldmap (foldmap_ident tra)
483 let foldmap_up tra = Walk.foldmap_up (foldmap_ident tra)
484 let foldmap_down tra = Walk.foldmap_down (foldmap_ident tra)
485
486 let exists ident value =
487 try
488 ignore
489 (foldmap_ident_value
490 (fun () v ->
491 if Ident.equal v ident then raise Exit;
492 (), v) () value);
493 false
494 with Exit -> true
495
496 end
497
498
499 (** {6 Utils on IL} *)
500
501 #<Debugvar:CPS_VERBOSE>
502
503 let debug fmt =
504 Printf.fprintf stderr ("[Cps] "^^fmt^^"\n%!")
505
506 module Substitution :
507 sig
508 open IL
509 val ident : ident -> ident -> term -> term
510 end =
511 struct
512 let ident ident ident' term =
513 let subst v = if Ident.equal v ident then ident' else v in
514 let foldmap () ident = (), subst ident in
515 let _, term = IdentWalk.foldmap foldmap () term in
516 term
517 end
518
519 module Factorize :
520 sig
521 open IL
522
523 (** letcont : factorize all occurence of the form
524 [LetCont (k, (x -> term), [ ApplyCont (k, y) ])]
525 rewriting it so :
526 [ <term> {x <- y} ]
527
528 <!> The Optimized implementation uses a side-effect with the
529 union find structure.
530 assert : x is fresh and appears only in term.
531 *)
532 val letcont : term -> term
533
534 (** debug : give the number of letcont simplified until now *)
535 val count : unit -> int
536
537 (** profile : give the global time taken doing substitution *)
538 val chrono_subst : unit -> float
539 end =
540 struct
541 open IL
542 open Base
543
544 let counter = ref 0
545 let count () = !counter
546
547 let _chrono_subst = Chrono.make ()
548 let chrono_subst () = Chrono.read _chrono_subst
549
550 let letcont term =
551 let rec map t =
552 match t with
553 (* This case is unused, but is should be done somewhere. Keep this code until we find the correct way to do it
554
555 | LetCont ((Continuation cident, Value vident, ApplyCont (Continuation cident', Value vident'), term), cident_option)
556 when Ident.compare vident vident' = 0 ->
557
558 (* we could eventually loose some thread_context, be sure that not before simplifying *)
559 let authorized_simplification =
560 match cident_option with
561 | None -> true
562 | Some (Continuation cident'') -> Ident.compare cident' cident'' = 0
563 in
564 if authorized_simplification
565 then
566 let _ =
567 incr(counter);
568 #<If:CPS_VERBOSE $minlevel 2>
569 debug "#%d LetCont %s (%s -> ApplyCont %s %s) in <term>" (!counter)
570 (Ident.stident cident) (Ident.stident vident)
571 (Ident.stident cident') (Ident.stident vident')
572 #<End> in
573
574 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.start _chrono_subst #<End> in
575 let term = Substitution.ident cident cident' term in
576 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.stop _chrono_subst #<End> in
577 map term
578 else
579 term
580 *)
581
582 | LetCont ((Continuation cident, Value vident, term, applycont), _) ->
583 begin
584 (* traversing local LetVal *)
585 let rec find_applycont acc = function
586 | ApplyCont (Continuation cident', (Value vident')) ->
587 if Ident.compare cident cident' <> 0
588 then None
589 else Some (acc, vident')
590 | LetVal (vident, value, term) when not (IdentWalk.exists cident value) -> find_applycont ((vident, value)::acc) term
591 | _ -> None
592 in
593 match find_applycont [] applycont with
594 | None -> t
595 | Some (letvals, vident') ->
596 let _ =
597 incr(counter);
598 #<If:CPS_VERBOSE $minlevel 2>
599 debug "#%d LetCont %s (%s -> <term>) in ApplyCont %s %s" (!counter)
600 (Ident.stident cident) (Ident.stident vident)
601 (Ident.stident cident) (Ident.stident vident')
602 #<End> in
603
604 (* this can be factorized <term> { vident <- vident' } *)
605 (* Optimisation: once Vident are (vident, ExprIdent.t) UnionFind.t,
606 we can use : UnionFind.replace vident vident', but we need to be
607 sure that [term] is the only one containing occurences of [vident] *)
608
609 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.start _chrono_subst #<End> in
610 let term = Substitution.ident vident vident' term in
611 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.stop _chrono_subst #<End> in
612
613 (* putting back local LetVal in the same order *)
614 let term = List.fold_left (fun term (vident, const) -> LetVal (vident, const, term)) term letvals in
615 map term
616 end
617 | _ -> t in
618 Walk.map_down map term
619
620 end
Something went wrong with that request. Please try again.