Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 620 lines (518 sloc) 22.295 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
36b482f [cleanup] open: remove Base in qmlcps
Raja authored
49 module List = BaseList
50
fccc685 Initial open-source release
MLstate authored
51 module IL = struct
52 type ident = Ident.t
53
54 (** The name of a continuation.
55 This may be replaced in the future by a (cident, ExprIdent.t) UnionFind.t
56 where cident will be a black type. *)
57 type cident = Continuation of ident
58
59 (** The name of a value.
60 Same remark, (vident, ExprIdent.t) UnionFind.t *)
61 type vident = Value of ident
62
63 (**The name of a field*)
64 type fident = Field of string
65
66 (** skey, restriction option.
67 The restriction arg is used to distinguish between :
68 - standard bypass : {[QmlAst.Bypass key]}
69 represented by : {[IL.Bypass (key, None)]}
70 - restricted bypass : {[QmlAst.Directive (`restricted_bypass pass_id, [{ e = Bypass key }], _)|}
71 the pass_id the string contained in the string option in this case :
72 represented by : {[IL.Bypass (key, Some pass_id)]} *)
73 type bypass = Bypass of (BslKey.t * string option)
74
75 (* used to build stack traces *)
76 type stack_trace_info =
77 { caller_cont : cident option; (** continuation of the closest enclosing function if any *)
78 callee_name : string option; (** local name of the function we're calling if any *)
79 position : string option; (** position of the Apply if any *) }
80
81 (* TODO : see if this is needed for later optimizations *)
82 (*The type of a function definition*)
83 (*
84 type func =
85 {return: cident;
86 (**[None] if the function takes place outside of a transaction.*)
87 transact: cident option;
88 (* (**[None] if the function is called from outside a request.*)
89 request: cident option; *)
90 arg: vident;
91 term: term}
92 and application =
93 {app_called: vident;
94 app_return: cident;
95 app_transact: cident option;
96 app_term
97 }
98 *)
99 (* not used yet, either
100 type application =
101 {app_called: vident
102 ;app_arg: vident
103 ;app_return: cident
104 ;app_transaction: cident option
105 }
106 *)
107
108 type value =
109 | Constant of QmlAst.const_expr
110 | Record of (fident * vident * Annot.t) list
111 | ExtendRecord of (fident * vident) list * vident
112 | LazyRecord of (fident * vident * Annot.t) list * vident option
113 | BasicBypass of bypass (* for value bypass only (not functions) *)
114 | ValueSkip of QmlAst.expr
115
116 and cps_function = CpsVident of vident | CpsBypass of bypass
117
118 and term =
119
120 (**[LetVal("x", v, t)] represents [let x = v in t].
121 At this stage, this is the only way of using a value in a term. *)
122 | LetVal of vident * value * term
123
124 (**[LetProj("x", ("y", "foo"), t)] represents [let x = y.foo in t].
125 This is the only way of accessing a field. *)
126 | LetProj of vident * (vident * fident) * term
127
128 (**[LetCont(("k", "x", t, u), parent)] represents
129 [let(*continuation*) k (x -> t) in u].
130 This introduces a continuation [k] with one unique argument [x],
131 to be used in [u].
132 the parent is an option of the parent continuation id.
133
134 <!> Assert: x MUST be fresh and appear ONLY in t
135 or it would definitly break the substitution mechanism.
136 *)
137 | LetCont of ((cident * vident * term * term) * cident option)
138
139 (**Introduce a set of mutually recursive definitions. *)
140 | LetRecFun of ( vident (** function name *)
141 * vident list (** arguments *)
142 * cident (** the continuation *)
143 * term (** body *)
144 ) list * term
145
146 (**Introduce a set of non-recursive definitions. *)
147 | LetFun of (vident * vident list * cident * term) list * term
148
149 (**Apply a continuation to a value, e.g. to jump
150 or return from a function. *)
151 | ApplyCont of cident * vident
152
153 (**[ApplyExpr(a,b,k)] computes [a] (which must be a rewrited-function)
154 with argument [b] and continuation [k]
155 The function [a] used to take arg [b] and return type c
156 [k] is a 'c continuation, and function [a] has been rewritten to
157 'b -> 'c continuation -> unit
158 *)
159 | ApplyExpr of cps_function * vident * cident
160
161 (**
162 Nary mode for application.
163 TODO: remove ApplyExpr from the ast, keep only ApplyNary
164 *)
165 | ApplyNary of cps_function * vident list * cident * stack_trace_info option
166
167 (**
168 Special case of application of a non cps bypass, with all its arguments.
169 Bypasses cannot be currified.
170 *)
171 | ApplyBypass of bypass * (vident list) * cident
172
173 | Match of vident * (QmlAst.pat * term) list
174
175 (**End of program, with result*)
176 | Done of vident * string
177
178 | Directive of
179 (QmlAst.qml_directive * term list * QmlAst.ty list)
180
181 (**In some cases, no operation, keep the qml 'as it is'*)
182 (**Currently this node is unused*)
183 | Skip of QmlAst.expr
184
185
186 (** tools for code generation *)
187 let fresh_c () = Continuation (Ident.next "cont")
188 let fresh_v () = Value (Ident.next "val")
189
190 let fresh_fun () = Value (Ident.next "fun")
191
192 end
193
194 (** {6 Traversal} *)
195 (** for optimisation and rewriting rules in IL *)
196 (** *)
197 module Subs : TraverseInterface.S2 with type 'a t = IL.term constraint 'a = _ * _ * _ =
198 struct
199 open IL
200 type 'a t = term constraint 'a = _ * _ * _
201
202 let foldmap tra acc t =
203 match t with
204 | LetVal (vident, value, term) ->
205 let acc, fterm = tra acc term in
206 acc,
207 if term == fterm then t else
208 LetVal (vident, value, fterm)
209
210 | LetProj (vident, (vident', fident), term) ->
211 let acc, fterm = tra acc term in
212 acc,
213 if term == fterm then t else
214 LetProj (vident, (vident', fident), fterm)
215
216 | LetCont ((cident, vident, term, term'), cident') ->
217 let acc, fterm = tra acc term in
218 let acc, fterm' = tra acc term' in
219 acc,
220 if term == fterm && term' == fterm' then t else
221 LetCont ((cident, vident, fterm, fterm'), cident')
222
223 | LetRecFun (list, term) ->
224 let foldmap acc ((vident, vident_list, cident, term) as t) =
225 let acc, fterm = tra acc term in
226 acc,
227 if term == fterm then t else
228 (vident, vident_list, cident, fterm) in
229 let acc, flist = List.fold_left_map_stable foldmap acc list in
230 let acc, fterm = tra acc term in
231 acc,
232 if term == fterm && list == flist then t else
233 LetRecFun (flist, fterm)
234
235 | LetFun (list, term) ->
236 let foldmap acc ((vident, vident_list, cident, term) as t) =
237 let acc, fterm = tra acc term in
238 acc,
239 if term == fterm then t else
240 (vident, vident_list, cident, fterm) in
241 let acc, flist = List.fold_left_map_stable foldmap acc list in
242 let acc, fterm = tra acc term in
243 acc,
244 if list == flist && term == fterm then t else
245 LetFun (flist, fterm)
246
247 | ApplyCont (_cident, _vident) -> acc, t
248
249 | ApplyExpr (_cps_function, _vident', _cident) -> acc, t
250
251 | ApplyNary (_cps_function, _vident_list, _cident, _stack_infos) -> acc, t
252
253 | ApplyBypass (_bypass, _vident_list, _cident) -> acc, t
254
255 | Match (vident, pat_term_list) ->
256 let foldmap acc ((pat, term) as t) =
257 let acc, fterm = tra acc term in
258 acc,
259 if term == fterm then t else
260 (pat, fterm) in
261 let acc, fpat_term_list = List.fold_left_map_stable foldmap acc pat_term_list in
262 acc,
263 if pat_term_list == fpat_term_list then t else
264 Match (vident, fpat_term_list)
265
266 | Done (_vident, _string) -> acc, t
267
268 | Directive (qml_directive, terms, tys) ->
269 let acc, fterms = List.fold_left_map_stable tra acc terms in
270 acc,
271 if terms == fterms then t else
272 Directive (qml_directive, fterms, tys)
273
274 | Skip _expr -> acc, t
275
276 let iter x = Traverse.Unoptimized.iter foldmap x
277 let map x = Traverse.Unoptimized.map foldmap x
278 let fold x = Traverse.Unoptimized.fold foldmap x
279 end
280
281 module Walk : TraverseInterface.TRAVERSE
282 with type 'a t = IL.term constraint 'a = _ * _ * _
283 and type 'a container = IL.term constraint 'a = _ * _ * _
284 = Traverse.Make2 ( Subs )
285
286 (* TODO: replace this with the unionFind algorithm *)
287 module IdentWalk :
288 sig
289 open IL
290 val foldmap : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
291 val foldmap_up : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
292 val foldmap_down : ( 'acc -> ident -> 'acc * ident ) -> 'acc -> term -> 'acc * term
293 val exists : ident -> value -> bool
294 end =
295 struct
296 open IL
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
978b7c4 @akoprow [fix] typo: occurence->occurrence, occured->occurred
akoprow authored
523 (** letcont : factorize all occurrence of the form
fccc685 Initial open-source release
MLstate authored
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
543 let counter = ref 0
544 let count () = !counter
545
546 let _chrono_subst = Chrono.make ()
547 let chrono_subst () = Chrono.read _chrono_subst
548
549 let letcont term =
550 let rec map t =
551 match t with
552 (* This case is unused, but is should be done somewhere. Keep this code until we find the correct way to do it
553
554 | LetCont ((Continuation cident, Value vident, ApplyCont (Continuation cident', Value vident'), term), cident_option)
555 when Ident.compare vident vident' = 0 ->
556
557 (* we could eventually loose some thread_context, be sure that not before simplifying *)
558 let authorized_simplification =
559 match cident_option with
560 | None -> true
561 | Some (Continuation cident'') -> Ident.compare cident' cident'' = 0
562 in
563 if authorized_simplification
564 then
565 let _ =
566 incr(counter);
567 #<If:CPS_VERBOSE $minlevel 2>
568 debug "#%d LetCont %s (%s -> ApplyCont %s %s) in <term>" (!counter)
569 (Ident.stident cident) (Ident.stident vident)
570 (Ident.stident cident') (Ident.stident vident')
571 #<End> in
572
573 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.start _chrono_subst #<End> in
574 let term = Substitution.ident cident cident' term in
575 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.stop _chrono_subst #<End> in
576 map term
577 else
578 term
579 *)
580
581 | LetCont ((Continuation cident, Value vident, term, applycont), _) ->
582 begin
583 (* traversing local LetVal *)
584 let rec find_applycont acc = function
585 | ApplyCont (Continuation cident', (Value vident')) ->
586 if Ident.compare cident cident' <> 0
587 then None
588 else Some (acc, vident')
589 | LetVal (vident, value, term) when not (IdentWalk.exists cident value) -> find_applycont ((vident, value)::acc) term
590 | _ -> None
591 in
592 match find_applycont [] applycont with
593 | None -> t
594 | Some (letvals, vident') ->
595 let _ =
596 incr(counter);
597 #<If:CPS_VERBOSE $minlevel 2>
598 debug "#%d LetCont %s (%s -> <term>) in ApplyCont %s %s" (!counter)
599 (Ident.stident cident) (Ident.stident vident)
600 (Ident.stident cident) (Ident.stident vident')
601 #<End> in
602
603 (* this can be factorized <term> { vident <- vident' } *)
604 (* Optimisation: once Vident are (vident, ExprIdent.t) UnionFind.t,
605 we can use : UnionFind.replace vident vident', but we need to be
978b7c4 @akoprow [fix] typo: occurence->occurrence, occured->occurred
akoprow authored
606 sure that [term] is the only one containing occurrences of [vident] *)
fccc685 Initial open-source release
MLstate authored
607
608 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.start _chrono_subst #<End> in
609 let term = Substitution.ident vident vident' term in
610 let _ = #<If:CPS_VERBOSE $minlevel 1> Chrono.stop _chrono_subst #<End> in
611
612 (* putting back local LetVal in the same order *)
613 let term = List.fold_left (fun term (vident, const) -> LetVal (vident, const, term)) term letvals in
614 map term
615 end
616 | _ -> t in
617 Walk.map_down map term
618
619 end
Something went wrong with that request. Please try again.