forked from MLstate/opalang
-
Notifications
You must be signed in to change notification settings - Fork 0
/
qmlCpsRewriter.ml
1925 lines (1679 loc) · 72.4 KB
/
qmlCpsRewriter.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* THIS FILE HAS A DOCUMENTED MLI *)
(*
TODO:
-exploit the LetIn rewriting for implementing all multi-expression skipping (like apply case)
-remove annots were useless fields and add them where usefull match, dot, record construction
*)
(* depends in Base *)
module List = Base.List
(* refactoring in progress *)
(* depends, alias *)
module Factorize = QmlCpsIL.Factorize
module IL = QmlCpsIL.IL
module Q = QmlAst
(* deprecated error managment *)
type error = string
exception Exception of error
external error_message : error -> string = "%identity"
(*
debug levels : keep it synchro with DebugVariables.mli
*)
module DebugLevel =
struct
let make_barrier = 2
let release_barrier = make_barrier
let cont_tracer = 10
let il_opt_timer = 1
let full_backtrace = 100
end
let debug fmt =
OManager.printf ("@[<2>@{<cyan>[Cps]@}@ "^^fmt^^"@]@.")
(* facilities to generate qmlAst *)
(* TODO: use the statefull constructor, keep annotation, position and types *)
module QC = QmlAstCons.UntypedExpr
(* Bypass helpers *)
let cps_id = "cps"
(* FIXME: use opacapi *)
let bycps_call call = BslKey.normalize (Printf.sprintf "bslcps.%s" call)
let il_bycps_call call = IL.Bypass (bycps_call call, Some cps_id)
let il_other_call call = IL.Bypass (BslKey.normalize call, None)
let qml_bycps_call call = QC.restricted_bypass ~pass:cps_id (bycps_call call)
let qml_other_call call = QC.bypass (bycps_call call)
let qml_byobj_magic () = QC.bypass Opacapi.Opabsl.BslPervasives.Magic.id
let il_bypass key = IL.Bypass (key, None)
let qml_group_app expr =
let fresh = Ident.next "_" in
QC.letin [fresh, expr] (QC.ident fresh)
(* TODO: replace errors by call to 1) internal or 2) public errors modules *)
let myself = "QmlCpsRewriter"
let error fmt =
let k s = raise (Exception s) in
Printf.ksprintf k fmt
type options =
{
no_assert : bool ;
no_server : bool;
qml_closure : bool ;
toplevel_concurrency : bool ;
warn_x_field : unit ;
server_side : bool ;
}
(* please, keep default values synchro with the documentation *)
let default_options =
{
no_assert = false ;
no_server = true;
qml_closure = false ;
toplevel_concurrency = false ;
warn_x_field = () ;
server_side = true ;
}
type env =
{
options : options ;
bsl_bypass_tags : BslKey.t -> BslTags.t ;
bsl_bypass_cps : BslKey.t -> BslKey.t option ;
bsl_bypass_typer : BslKey.t -> BslTypes.t ;
typing : QmlTyper.env ;
}
let env_initial ~options ~bsl_bypass_typer ~bsl_bypass_tags ~bsl_bypass_cps ~typing () =
{
options = options ;
bsl_bypass_typer = bsl_bypass_typer ;
bsl_bypass_tags = bsl_bypass_tags ;
bsl_bypass_cps = bsl_bypass_cps ;
typing = typing ;
}
(* In order to do the transformation, there is a need for type t used to collect
toplevel barrier introduction. *)
type private_env =
{
(* skipped functions : (arity * fskip_id * fcps_id) Map *)
skipped_functions : (int * Ident.t * Ident.t) IdentMap.t;
toplevel_barrier : Ident.t IdentMap.t ;
warn_x_field : unit ;
bindings : (Ident.t * QmlAst.expr) list
}
let private_env_initial : unit -> private_env = fun () ->
let bindings = [] in
{
skipped_functions = IdentMap.empty;
toplevel_barrier = IdentMap.empty ;
warn_x_field = () ;
bindings = bindings
}
let print_private_env private_env =
Printf.printf "SKIPPED\n%!";
IdentMap.iter( fun k (i,i1,i2) ->
let n i = Ident.stident i in
Printf.printf "%s %d => %s , %s\n" (n k) i (n i1) (n i2);
) private_env.skipped_functions
let private_binding (private_env:private_env) =
private_env.bindings
let private_env_get_skipped_fun id private_env =
IdentMap.find_opt id private_env.skipped_functions
module S =
struct
type t = private_env
let pass = "qmlCpsRewriter"
let pp f _ = Format.pp_print_string f "<dummy>"
end
module Package = struct
include ObjectFiles.MakeClientServer(S)
let debug = false
let load_dependencies ~side =
let merge _pack a b =
if debug then Printf.printf "LOADING %s\n%!\n" (fst _pack);
{ skipped_functions = IdentMap.safe_merge a.skipped_functions b.skipped_functions
; toplevel_barrier = IdentMap.safe_merge a.toplevel_barrier b.toplevel_barrier
; warn_x_field = ()
; bindings = [] }
in
fold_with_name ~side merge (private_env_initial ())
let save_current ~side ~private_env_initial ~private_env =
let (-) ab a =
{ skipped_functions = IdentMap.diff ab.skipped_functions a.skipped_functions
; toplevel_barrier = IdentMap.diff ab.toplevel_barrier a.toplevel_barrier
; warn_x_field = ()
; bindings = [] }
in
let private_env_increment = private_env - private_env_initial in
if debug then (
Printf.printf "SAVING\n%!\n";
print_private_env private_env_initial;
print_private_env private_env;
print_private_env private_env_increment;
);
save ~side private_env_increment
end
(* production of embeded location error messages in the server *)
let string_of_pos = FilePos.to_string
(*
Fetch the definition and the type of a bypass, for use in CPS.
For the moment, we have no CPS-specific BSL language. Therefore,
we take the OCaml implementation of the bypass and we transform
it into a CPS function.
Note that this form of embedding would fail if a function appears in
negative position of the type of your bypass (i.e. as argument to a
function).
That's why the CTrans has provided a reverse transformation mechanism,
a way of transforming an OCaml ['a -> 'b continuation -> unit] function
into a OCaml ['a -> 'b] function using the [uncps-n] primitives.
In the future, we could also think about having special cps
types in the bsl, in order to see if we need to do the conversion
or not.
*)
(* The cps transform makes no assumption about the bypass it receives
* It will eta expand if needed, but only when necessary (when bypasses
* are not applied) *)
let expand_bypass (env:env) (expr:QmlAst.expr) =
let key =
match expr with
| Q.Directive (_, `restricted_bypass _, [Q.Bypass (_, key)], _)
| Q.Bypass (_, key) -> key
| _ -> assert false in
let typ = env.bsl_bypass_typer key in
(* forming the type list corresponding to this type *)
let inputs, _output = match typ with
| BslTypes.Fun (_, inputs, output) -> Some inputs, output
| _ -> None, typ
in
match inputs with
| None ->
(* it is not a function, do nothing *)
None
| Some l ->
let n = List.length l in
let args = List.init n (fun i -> Ident.nextf "bypass_arg_%d" i) in
let apply = QC.apply expr (List.map QC.ident args) in
Some (QC.lambda args apply)
(* private context to be sure to control what goes out *)
module Context :
sig
type t
val make :
transaction:(IL.vident -> IL.term) option ->
kappa:(IL.vident -> IL.term) ->
cont:(IL.cident) option ->
parent:(IL.cident) option ->
t
val start : parent:IL.cident option -> t
val apply : t -> IL.vident -> IL.term
val cont : t -> IL.cident -> t
val kappa : t -> (IL.vident -> IL.term) -> t
val insertLetCont : t -> (IL.cident -> IL.term) -> IL.term
val current_cont : t -> IL.cident option
end =
struct
type t =
{
(*The continuation to use in case of transaction failure*)
transaction: (IL.vident -> IL.term) option;
kappa: IL.vident -> IL.term ;
cont : IL.cident option;
parent : IL.cident option;
}
let make ~transaction ~kappa ~cont ~parent =
{
transaction = transaction ;
kappa = kappa ;
cont = cont;
parent = parent;
}
let start ~parent =
make
~transaction:None
~kappa:(fun x -> IL.Done (x, "Top-level expression terminated"))
~cont:None
~parent
(* until we manage to remove totally kappa (context.kappa)
we switch to an hybrid approach with an option of cident *)
let apply context =
match context.cont with
| Some k -> (fun z -> IL.ApplyCont(k, z))
| None -> context.kappa
let cont context cont = { context with cont = Some cont }
let kappa context kappa = { context with cont = None ; kappa = kappa }
(* dont produce re-binding continuation *)
(* insertLetCont is never called with a of_cont introducing a ApplyCont,
so it does not introduced direct applied cont *)
let insertLetCont context of_cont =
match context.cont with
| Some k -> of_cont k
| None ->
begin
let v = IL.fresh_v () in
let returned = context.kappa v in
match v, returned with
| IL.Value v, IL.ApplyCont (cont, IL.Value v')
when Ident.equal v v' -> of_cont cont
| _ ->
let c = IL.fresh_c () in
IL.LetCont ((c, v, returned, of_cont c), context.parent)
end
let current_cont context =
match context.cont with
| None -> context.parent
| c -> c
end
(** skiping utils module *)
module Skip = struct
(* skipping can be desactivated here *)
let can = #<If:CPS_NOSKIP> false #<Else> true #<End>
(* insert a skipped term properly when a context should be used *)
let remove ilexpr (context:Context.t) =
match ilexpr with
| IL.Skip e ->
begin match e with
| Q.Ident (_, i) -> Context.apply context (IL.Value i)
| Q.Const (_, c) -> let v = IL.fresh_v () in IL.LetVal (v, IL.Constant c, Context.apply context v)
| _ -> let v = IL.fresh_v () in IL.LetVal (v, IL.ValueSkip e, Context.apply context v)
end
| _ -> ilexpr
let remove2 c (a,e) = a, remove e c
let is1 = function IL.Skip _ -> true | _ -> false
let is2 = function _, IL.Skip _ -> true | _ -> false
let is4 = function _, _, _, IL.Skip _ -> true | _ -> false
let get = function IL.Skip qml -> qml | _ -> assert false
end
(** utily module, essentially to simplify the apply case *)
module U = struct
(**
check if an ident need to be changed to something else
(e.g. wait barrier or another ident)
note that an ident cannot be a barrier ident and
at the same time a function with non skipped version
*)
let is_stable_ident env = function
| Q.Ident (_, id)
when not((IdentMap.mem id env.toplevel_barrier)
|| (IdentMap.mem id env.skipped_functions) )
-> true
| _ -> false
let is_not_barrier_ident_or_internal_bypass penv e = match e with
| Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) | Q.Directive (_, `may_cps, _, _) -> true
| Q.Ident (_, id) -> not(IdentMap.mem id penv.toplevel_barrier)
| _ -> false
let get_value_il_of_ident = function
(* cannnot be extended for constant *)
| Q.Ident (_, id) -> IL.Value id
| _ -> assert false
let rec bp_get_key_and_passid bp = match bp with
| Q.Directive (_, `may_cps, [bypass], _) -> bp_get_key_and_passid bypass
| Q.Directive (_, `restricted_bypass pass_id, [Q.Bypass (_, key)], _) ->
key, Some pass_id
| Q.Bypass (_, key) -> key, None
| _ ->
let context = QmlError.Context.expr bp in
QmlError.i_error None context
"Unexpected form of bypass"
let bp_get_key bp = fst (bp_get_key_and_passid bp)
let bp_cps bp_cps bp =
let rec aux bp =
match bp with
| Q.Directive (label, `restricted_bypass pass_id, [bp] , x) ->
Q.Directive (label, `restricted_bypass pass_id, [aux bp] , x)
| Q.Directive (_, `may_cps, [Q.Bypass (label, key) as bp] , _) ->
(match bp_cps key with
| Some key -> Q.Bypass (label, key)
| None -> bp)
| Q.Bypass _ -> bp
| _ ->
Format.printf "@[<2>expr:@ %a@]@." QmlPrint.pp#expr bp;
assert false
in aux bp
let is_second_order_bypass bsltags =
bsltags.BslTags.second_order && BslTags.do_projection bsltags "cps"
(** check if a bypass implementation (projection included) is waiting a continuation as last argument *)
let is_cps_bp bp_tags bp =
let bsltags = bp_tags (bp_get_key bp) in
(is_second_order_bypass bsltags)
|| (bsltags.BslTags.cps_bypass)
|| (bsltags.BslTags.raise_)
(** cps_apply fcps_id f_args context :
create the IL application of the CPS function fskip_id with IL TERM arguments under the given context *)
let cps_apply ?stack_info fcps_id f_args context =
let args = List.map get_value_il_of_ident f_args in
Context.insertLetCont context (fun k -> IL.ApplyNary (IL.CpsVident (IL.Value fcps_id), args, k, stack_info))
(** bp_apply ~cont_as_arg bypass (f_args:QmlAst.expr list)
create the IL application of the bypass with QML arguments,
WARNING : cps=true =>
bypass take a continuation as last argument
cps=false =>
bypass is applied to standard arguments,
then the contination is used on the result of application *)
let bp_apply ~cps bypass bp_args context =
let key, pass_id = bp_get_key_and_passid bypass in
let args = List.map get_value_il_of_ident bp_args in
Context.insertLetCont context (fun k ->
if cps
then IL.ApplyNary(IL.CpsBypass (IL.Bypass (key, pass_id)), args, k, None)
else IL.ApplyBypass( IL.Bypass (key, pass_id) , args, k)
)
let label () = Annot.nolabel "Cps.nolabel"
(** skipped_apply fskip_id f_args :
create the IL application of the SKIPPED function fskip_id with QML IDENT arguments *)
let skipped_apply ?(partial=false) fskip_id f_args =
let e = QmlAstUtils.App.from_list (Q.Ident (label (), fskip_id) :: f_args ) in
let e = if partial then Q.Directive (label (), `partial_apply None, [e], []) else e in
IL.Skip e
(** same for bypass *)
let skipped_bp_apply bypass bp_args = IL.Skip (QmlAstCons.UntypedExpr.apply bypass bp_args)
(** bad_apply_property f f_args : check that all args are idents that don't need rewriting
and that f is either an non barrier ident or a bypass *)
let good_apply_property penv f f_args =
List.for_all (is_stable_ident penv) f_args
&& is_not_barrier_ident_or_internal_bypass penv f
(** transform the expression so that the apply has the good property
gives name to all element in need for cps rewriting *)
let normalize_apply_property ?stack_info ?(partial=false) penv f f_args =
let f_and_args = f::f_args in
let rec fold ?(head_is_f=false) f_and_args (bindings, ids) =
let s_fold e l= fold l (bindings, (e :: ids)) in
match f_and_args with
(* keep already named *)
(* 1 eventually the function *)
| (Q.Bypass _ | Q.Directive (_, `restricted_bypass _, _, _) as e) :: l
when head_is_f -> s_fold e l
(* 2 function and args *)
| (Q.Ident _ as e) :: l
when is_stable_ident penv e
|| (head_is_f && is_not_barrier_ident_or_internal_bypass penv f)
-> s_fold e l
(* name all others *)
| e :: l ->
let id = Ident.next "arg" in
fold l (((id, e) :: bindings), Q.Ident (label (), id) :: ids)
(* create the letin if needed *)
| [] when bindings = [] -> assert false
| [] ->
let app = QmlAstUtils.App.from_list (List.rev ids) in
let app =
match stack_info with
| None -> app
| Some info -> Q.Directive (label (), `cps_stack_apply info, [app], []) in
let app =
if partial then Q.Directive (label (), `partial_apply None, [app], [])
else app in
Q.LetIn (label (), bindings, app)
in fold ~head_is_f:true f_and_args ([],[])
let rewrite_apply_partial context f_id f_args =
let e = IL.Skip (QC.apply (QC.ident f_id) f_args) in
if Skip.can then e
else Skip.remove e context
let rewrite_apply ?stack_info ?(partial=false) ~private_env ~expr ~context f_id f_args =
match private_env_get_skipped_fun f_id private_env with
| Some(real_arity, fskip_id, fcps_id) ->
if partial then
(* skipped version exists but incomplete call *)
skipped_apply ~partial fcps_id f_args
else (
(* skipped version exists, complete call *)
if List.length f_args <> real_arity then (
Format.printf "Partial apply (expected %d args, get %d) in CpsRewriter :@\n%a@."
real_arity (List.length f_args) QmlPrint.pp#expr expr;
assert false
);
skipped_apply ~partial fskip_id f_args
)
| None ->
(* skipped version don t exist *)
if partial then
skipped_apply ~partial f_id f_args
else
cps_apply ?stack_info f_id f_args context
let is_const e =
match e with
| Q.Const _ -> true
| _ -> false
let good_llarray_property_elt penv arg =
is_stable_ident penv arg
|| is_const arg
let good_llarray_property penv args =
List.for_all (good_llarray_property_elt penv) args
let normalize_llarray_property penv args =
let foldmap bindings expr =
if good_llarray_property_elt penv expr
then
bindings, expr
else
(* name all others *)
let id = Ident.next "arg" in
let binding = id, expr in
let bindings = binding :: bindings in
let expr = Q.Ident (label (), id) in
bindings, expr
in
let bindings, args = List.fold_left_map foldmap [] args in
let llarray = Q.Directive (label (), `llarray, args, []) in
assert (bindings <> []) ;
Q.LetIn (label (), bindings, llarray)
end
(** The code_elt is there only for Error context *)
(* Convert a QML expression to a CPS term.*)
let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr:QmlAst.expr) =
(* Records
<!> beware, this function is partial, it is defined only on complex records, and lazy records.
the skip option specify if we accept to use and propagate skip nodes and provide the
constructor for its content *)
let rec aux_record ?skip fields (context:Context.t) create_record =
let il_fields, build_fields =
let fold (il_fields, build) (f, expr) =
let c = IL.fresh_c () in
let v = IL.fresh_v () in
((IL.Field f, v, (Q.QAnnot.expr expr))::il_fields),
((f, c, v, (aux_can_skip expr (Context.cont context c)))::build) in
List.fold_left fold ([], []) fields in
(* do you accept Skip to return node ? *)
let can_skip = Skip.can && skip <> None in
(* do we accept to propagate skip nodes from fields ? *)
let all_skip =
can_skip
&& List.for_all Skip.is4 build_fields
in
if all_skip then (* Skipping *) (Option.get skip) fields build_fields
else
let il_record =
let v = IL.fresh_v () in
IL.LetVal (v, create_record (List.rev il_fields),
Context.apply context v)
in
let parent = Context.current_cont context in
let fold il_term (_, c, v, field_term) =
let field_term = Skip.remove field_term (Context.cont context c) in
IL.LetCont ((c, v, il_term, field_term), parent)
in
List.fold_left fold il_record build_fields
and aux_lambda ?(can_skip_lambda=false) context label args e =
let k = IL.fresh_c () in
let args = List.map (fun id -> IL.Value id) args in
let cont_e = (Context.cont context k) in
let e = aux_can_skip e cont_e in
(match e with
| IL.Skip e when can_skip_lambda ->
(* skip transformations must not be lost -> do not return IL.Skip expr *)
`skip (QmlAstCons.UntypedExprWithLabel.lambda ~label (List.map (function IL.Value x -> x) args) e)
| (* include Skipped and non Skipped *)_ ->
begin
`letfun (args, k, Skip.remove e cont_e)
end)
(* this version of 'aux' is allowed to return 'Skip' node,
you should only call it if you know how to handle them properly.
Currently, only const, ident and record case can give 'Skip' node
Only record case is recursively calling 'aux_can_skip'.
All other calls are on the standard 'aux' (see after)
*)
and aux_can_skip ?(can_skip_lambda=false) expr (context:Context.t) =
match expr with
| Q.Const _ when Skip.can -> IL.Skip expr
| Q.Const (_, c) ->
let x = IL.fresh_v () in
IL.LetVal (x, IL.Constant c, Context.apply context x)
| Q.Ident (label, x) ->
begin
match IdentMap.find_opt x private_env.toplevel_barrier with
| Some barrier ->
(* if option --cps-toplevel-concurrency is set,
this ident may be unbound, and we have just a barrier instead *)
let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "wait"), [IL.Value barrier], k, None) in
Context.insertLetCont context func
| None when not(Skip.can) -> Context.apply context (IL.Value x)
| None ->
match IdentMap.find_opt x private_env.skipped_functions with
| Some (_, _, fcps_id) -> IL.Skip (Q.Ident (label, fcps_id))
| None -> IL.Skip expr
end
| Q.LetIn (label, l, e) ->
begin
let item name value sub_expr =
let value_il =
match value with
| Q.Lambda (label,params,body) -> (
match aux_lambda context label params body with
| `skip _ -> assert false
| `letfun _ as e -> e
)
| _ ->
let c = IL.fresh_c () in
let context_for_value = Context.cont context c in
let value_il = aux_can_skip value context_for_value in
`letcont (c,context_for_value,value_il) in
let sub_expr_il = aux_can_skip sub_expr context in
match value_il with
| `letcont (_, _, value_il) when Skip.is1 sub_expr_il && Skip.is1 value_il ->
begin
(* old skip changes (fun_skipped ...) must not be removed *)
let value = Skip.get value_il in
let sub_expr = Skip.get sub_expr_il in
IL.Skip (QmlAstCons.UntypedExprWithLabel.letin ~label [(name, value)] sub_expr)
end
| `letcont (c, context_for_value, value_il) ->
let parent = Context.current_cont context in
IL.LetCont ((c, (IL.Value name), Skip.remove sub_expr_il context,
Skip.remove value_il context_for_value), parent)
| `letfun (args,k,body) ->
IL.LetFun ([IL.Value name,args,k,body], Skip.remove sub_expr_il context)
in
match l with
| [] -> aux_can_skip e context
| [(name, value)] -> item name value e
| (name, value)::t -> item name value (Q.LetIn (label, t, e))
end
| Q.LetRecIn (_, defs, e) ->
let items = List.map
(fun (name, def) ->
match def with
| Q.Lambda (_, params, body) ->
let params = List.map (fun id -> IL.Value id) params in
let k = IL.fresh_c () in
(IL.Value name, params, k, aux body (Context.cont context k))
| _ -> error "Recursive definition of a non-function"
) defs
in
IL.LetRecFun (items, aux e context)
| Q.Lambda (label, args, e) -> (
match aux_lambda ~can_skip_lambda context label args e with
| `skip e -> IL.Skip e
| `letfun (args,k,body) ->
let anonymous = IL.fresh_fun () in
IL.LetFun([anonymous, args, k, body], Context.apply context anonymous)
)
(* Special case for stack traces *)
| Q.Directive (_, `cps_stack_lambda cont_opt_ref, e_opt,_) ->
(* this directive does not modifying the rewriting of the expression in any way
* it just records the current continuation in the reference *)
(cont_opt_ref : Obj.t option ref) := Obj.magic (Context.current_cont context : IL.cident option);
let e = List.get_only_element e_opt in
aux_can_skip e context
(* Special case of Apply node for stack traces *)
| Q.Directive (_, `cps_stack_apply ((cont_opt_ref_opt,name,position) as stack_info), [Q.Apply (_, f, f_args)], _) -> (
if not (U.good_apply_property private_env f f_args) then
aux_can_skip (U.normalize_apply_property ~stack_info private_env f f_args) context
else
(* the only difference with the usual apply case is that the case
* bypass never occurs here (because `cps_stack_apply is never put
* on a bypass) *)
let cont : IL.cident option =
match cont_opt_ref_opt with
| None -> None
| Some x -> Some (Obj.obj (Option.get !x)) in
match f with
| Q.Ident (_, f_id) ->
let stack_info =
{IL.caller_cont = cont;
IL.callee_name = name;
IL.position = position} in
U.rewrite_apply ~stack_info ~private_env ~expr ~context f_id f_args
| _ ->
OManager.printf "unexpected expr for cps trace@\n" ;
OManager.printf "expr: %a@." QmlPrint.pp#expr expr ;
assert false
)
(* BEGIN OF APPLY NODE *)
(* normalisation of apply node
to guaranty property : f is a non barrier ident or a bypass, f_args are stable identifiers *)
| Q.Apply (_, f, f_args) when not(U.good_apply_property private_env f f_args) ->
aux_can_skip (U.normalize_apply_property private_env f f_args) context
| Q.Directive (_, `partial_apply _, [Q.Apply (_, f, f_args)], _) when not(U.good_apply_property private_env f f_args) ->
aux_can_skip (U.normalize_apply_property private_env ~partial:true f f_args) context
(* guaranteed property : f is a non barrier ident, f_args are stable identifiers *)
| Q.Apply (_, Q.Ident (_, f_id), f_args) ->
U.rewrite_apply ~private_env ~expr ~context f_id f_args
| Q.Directive (_, `partial_apply _, [Q.Apply (_, Q.Ident (_, f_id), f_args)], _) ->
U.rewrite_apply ~partial:true ~private_env ~expr ~context f_id f_args
(* guaranteed property : f is a bypass, f_args are stable identifiers *)
| Q.Apply (_, bypass, bp_args) ->
let bypass = U.bp_cps env.bsl_bypass_cps bypass in
let cps = U.is_cps_bp env.bsl_bypass_tags bypass in
if cps || not(Skip.can)
then U.bp_apply ~cps bypass bp_args context
else U.skipped_bp_apply bypass bp_args
(* END OF APPLY NODE *)
| Q.Match (label, e, cases) ->
let cases =
let map (pat, epat) = (pat, aux_can_skip epat context) in
List.map map cases in
let all_cases_are_skipped = List.for_all Skip.is2 cases in
let c = IL.fresh_c () in
let context_for_e = Context.cont context c in
begin match aux_can_skip e context_for_e with
| IL.Skip e when all_cases_are_skipped && Skip.can ->
let map (pat, epat) = (pat, Skip.get epat) in
IL.Skip (QmlAstCons.UntypedExprWithLabel.match_ ~label e (List.map map cases))
| e ->
let cases = List.map (Skip.remove2 context) cases in
let e = Skip.remove e context_for_e in
let v = IL.fresh_v () in
let parent = Context.current_cont context in
IL.LetCont((c,v,
IL.Match (v, cases),
e ), parent)
end
| Q.Record (label, fields) ->
let skip _ builded =
let map (f, _, _, term) = (f, Skip.get term) in
IL.Skip (QmlAstCons.UntypedExprWithLabel.record ~label (List.map map builded))
in
aux_record ~skip:skip fields context (fun fields -> IL.Record fields)
| Q.Directive (_, `create_lazy_record, exprs, _) -> (
let expr, info = QmlDirectives.create_lazy_record_arguments exprs in
(* <!> beware there : the info has type 'a in QmlFlatServerLib *)
match expr with
| Q.Record (_, fields) -> (
match info with
| Some info ->
let v = IL.fresh_v () and c = IL.fresh_c () in
let parent = Context.current_cont context in
IL.LetCont((c, v,
(let create_record fields = IL.LazyRecord (fields, Some v) in
aux_record fields context create_record),
aux info (Context.cont context c)
), parent)
| None ->
let create_record fields = IL.LazyRecord (fields, None) in
aux_record fields context create_record
)
| _ -> assert false
)
| Q.Dot (label, e, s) ->
let c = IL.fresh_c () in
let context_for_e = Context.cont context c in
begin match aux_can_skip e context_for_e with
| IL.Skip e when Skip.can ->
IL.Skip (QmlAstCons.UntypedExprWithLabel.dot ~label e s)
| e ->
let e = Skip.remove e context_for_e in
let v = IL.fresh_v () in
let p = IL.fresh_v () in
let parent = Context.current_cont context in
IL.LetCont((c, v,
IL.LetProj (p, (v, IL.Field s), Context.apply context p),
e), parent)
end
| Q.ExtendRecord _ ->
let il_fields, build_fields, rest =
let rec fold ((il_fields, build, seen) as acc) expr =
match expr with
| Q.Coerce (_, e, _) -> fold acc e
| Q.ExtendRecord (_, f, expr, e) ->
let acc =
if StringSet.mem f seen
then
(* This field has been added once already.
Drop the second extension or it would break [extend_with_array] *)
acc
else
let c = IL.fresh_c () in
let v = IL.fresh_v () in
(
((IL.Field f, v)::il_fields),
((c, v, (aux expr (Context.cont context c)))::build),
(StringSet.add f seen)
)
in
fold acc e
| _ -> il_fields, build, expr
in fold ([], [], StringSet.empty) expr
in
let record = IL.fresh_v () in
let il_extend_record =
let v = IL.fresh_v () in
IL.LetVal (v, IL.ExtendRecord ((List.rev il_fields), record), Context.apply context v) in
let parent = Context.current_cont context in
let il_term =
let c = IL.fresh_c () in
IL.LetCont((c, record, il_extend_record, aux rest (Context.cont context c)), parent) in
let fold il_term (c, v, term) = IL.LetCont((c, v, il_term, term), parent) in
List.fold_left fold il_term build_fields
| Q.Bypass _
| Q.Directive (_, `restricted_bypass _, [Q.Bypass _], _) -> (
(* if we end up here, it means QmlBypassHoisting wasn't called, or that someone
* introduced other bypasses in the meantime
* In any case, we eta expand them ourselves
*)
match expand_bypass env expr with
| None -> (
match expr with
| Q.Directive (_, `restricted_bypass pass, [Q.Bypass (_, key)], _) ->
(* value bypass *)
let v = IL.fresh_v () in
IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, Some pass)), Context.apply context v)
| Q.Bypass (_, key) ->
(* value bypass *)
let v = IL.fresh_v () in
IL.LetVal (v, IL.BasicBypass (IL.Bypass(key, None)), Context.apply context v)
| _ -> assert false (* not matched by the outer pattern *)
)
| Some e ->
aux_can_skip ~can_skip_lambda e context
)
| Q.Coerce (_, e, _) -> aux_can_skip ~can_skip_lambda e context
| Q.Path (_, _, _) ->
failwith "Internal error: At this stage, all first-class paths should have been compiled."
(* Concurrency-specific directive, and cps specific *)
| Q.Directive (_, `spawn, expr, _) ->
begin
match expr with
| [expr] ->
(* TODO there : restriction for Record only *)
let name = IL.fresh_v () in
let v = IL.fresh_v () in (* v is of type unit, ignored by the function *)
let k = IL.fresh_c () in
let expr = aux expr (Context.cont context k) in
let defs = [(name, [v], k, expr)] in
let func c =
let term = IL.ApplyBypass (il_bycps_call "spawn", [name], c) in
IL.LetFun (defs, term)
in
Context.insertLetCont context func
| _ -> assert false (* cannot be parsed *)
end
(* TODO: when the basic version passes the [fact_spawn*.qml] tests,
remove [@wait] and instead process concurrency as we do
with lazy records: perform @wait implicitely at dot access. *)
| Q.Directive (_, `wait, expr, _) ->
begin
match expr with
| [expr] ->
(*We use the result of [future] and [context]
to build the task which will be set up to*)
let c1 = IL.fresh_c () in
let future = IL.fresh_v () in
let parent = Context.current_cont context in
IL.LetCont((c1 , future,
(let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "wait"), [future], k, None) in
Context.insertLetCont context func),
aux expr (Context.cont context c1)), parent)
| _ -> assert false (* cannot be parsed *)
end
| Q.Directive (_, `atomic, exprs, tys) ->
let expr = List.get_only_element exprs in
let expr = aux expr context in
IL.Directive (`atomic, [expr], tys)
| Q.Directive (_, `callcc, [expr], _) ->
let c = IL.fresh_c () and f_callcc = IL.fresh_v () in
let parent = Context.current_cont context in
IL.LetCont ((c, f_callcc,
(let func k = IL.ApplyNary (IL.CpsBypass (il_bycps_call "callcc_directive"), [f_callcc], k, None) in
Context.insertLetCont context func),
aux expr (Context.cont context c)
), parent)
| Q.Directive (_, `immovable, _, _) ->
failwith "Internal error: CPS Directive @immovable is not yet implemented"
(* in particular : see if this directive should be removed by this pass,
or preserved (or transformed?) for a specific back-end directive *)
| Q.Directive (_, `assert_, [e], _) ->
if env.options.no_assert
then aux (QC.unit ()) context
else
let bool_result = IL.fresh_v () in
let assertion =
let message_value =
let message = string_of_pos (Q.Pos.expr expr) in
IL.Constant (Q.String message) in
let message = IL.fresh_v () in
let bypass =
(* FIXME: use opacapi *)
"bslpervasives.assertion"
in
let term c =
IL.LetVal (message, message_value,
IL.ApplyBypass (il_other_call bypass, [bool_result; message], c)) in
Context.insertLetCont context term
in
let c = IL.fresh_c () in
let parent = Context.current_cont context in
IL.LetCont((c, bool_result, assertion, aux e (Context.cont context c)), parent)
| Q.Directive (_, `fail, args, _) -> (
(*
FIXME: skip in case of no message, or if the message is a static string
*)
let fail_cps = Opacapi.Opabsl.BslPervasives.fail_cps in
let position_value =
let pos = string_of_pos (Q.Pos.expr expr) in
IL.Constant (Q.String pos)
in
let position = IL.fresh_v () in
let message = IL.fresh_v () in
let body =
let term k =
IL.LetVal (position, position_value,
IL.ApplyNary (IL.CpsBypass (il_bypass fail_cps), [message ; position], k, None))
in
Context.insertLetCont context term
in
match args with
| [] ->
let message_value =
let mes = "" in
IL.Constant (Q.String mes)
in
IL.LetVal (message, message_value, body)
| e :: _ -> (
match e with
| Q.Const (_, ((Q.String _) as literal)) ->
IL.LetVal (message, IL.Constant literal, body)
| _ ->
let c = IL.fresh_c () in
let parent = Context.current_cont context in