-
Notifications
You must be signed in to change notification settings - Fork 86
/
Copy pathlambda_to_flambda.ml
1724 lines (1681 loc) · 69.5 KB
/
lambda_to_flambda.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
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Pierre Chambart, OCamlPro *)
(* Mark Shinwell and Leo White, Jane Street Europe *)
(* *)
(* Copyright 2016--2023 OCamlPro SAS *)
(* Copyright 2016--2023 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* "Use CPS". -- A. Kennedy, "Compiling with Continuations Continued", ICFP
2007. *)
module Env = Lambda_to_flambda_env
module L = Lambda
module CC = Closure_conversion
module P = Flambda_primitive
module IR = Closure_conversion.IR
module Expr_with_acc = Closure_conversion_aux.Expr_with_acc
module Function_decl = Closure_conversion_aux.Function_decls.Function_decl
module CCenv = Closure_conversion_aux.Env
(* CR pchambart: Replace uses by CC.Acc.t *)
module Acc = Closure_conversion_aux.Acc
type primitive_transform_result =
| Primitive of L.primitive * L.lambda list * L.scoped_location
| Transformed of L.lambda
let must_be_singleton_simple simples =
match simples with
| [simple] -> simple
| [] | _ :: _ ->
Misc.fatal_errorf "Expected singleton Simple but got: %a"
(Format.pp_print_list ~pp_sep:Format.pp_print_space IR.print_simple)
simples
let print_compact_location ppf (loc : Location.t) =
if loc.loc_start.pos_fname = "//toplevel//"
then ()
else
let file, line, startchar = Location.get_pos_info loc.loc_start in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
Format.fprintf ppf "%a:%i" Location.print_filename file line;
if startchar >= 0 then Format.fprintf ppf ",%i--%i" startchar endchar
let name_for_function (func : Lambda.lfunction) =
(* Name anonymous functions by their source location, if known. *)
match func.loc with
| Loc_unknown -> "fn"
| Loc_known { loc; _ } ->
if Flambda_features.Expert.shorten_symbol_names ()
then "fn"
else Format.asprintf "fn[%a]" print_compact_location loc
let extra_args_for_exn_continuation env exn_handler =
List.map
(fun (ident, kind) -> IR.Var ident, kind)
(Env.extra_args_for_continuation_with_kinds env exn_handler)
let _print_stack ppf stack =
Format.fprintf ppf "%a"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "; ")
(fun ppf (_id, cont) -> Format.fprintf ppf "%a" Continuation.print cont))
stack
(* Uses of [Lstaticfail] that jump out of try-with handlers need special care:
the correct number of pop trap operations must be inserted. A similar thing
is also necessary for closing local allocation regions. *)
let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args :
Expr_with_acc.t =
let try_stack_at_handler = Env.get_try_stack_at_handler env continuation in
let try_stack_now = Env.get_try_stack env in
let dbg =
Debuginfo.none
(* CR mshinwell: should probably be fixed in Lambda (on Lstaticraise) *)
in
if List.length try_stack_at_handler > List.length try_stack_now
then
Misc.fatal_errorf
"Cannot jump to continuation %a: it would involve jumping into a \
try-with body"
Continuation.print continuation;
assert (
Continuation.Set.subset
(Continuation.Set.of_list try_stack_at_handler)
(Continuation.Set.of_list try_stack_now));
let rec add_pop_traps acc ~try_stack_now =
let add_pop cont ~try_stack_now after_pop =
let mk_remaining_traps acc = add_pop_traps acc ~try_stack_now in
let wrapper_cont = Continuation.create () in
let trap_action : IR.trap_action = Pop { exn_handler = cont } in
let handler = mk_remaining_traps acc after_pop in
let body acc ccenv =
CC.close_apply_cont acc ccenv ~dbg wrapper_cont (Some trap_action) []
in
fun acc env ->
CC.close_let_cont acc env ~name:wrapper_cont ~is_exn_handler:false
~params:[] ~recursive:Nonrecursive ~body ~handler
in
let no_pop after_pop = after_pop in
match try_stack_now, try_stack_at_handler with
| [], [] -> no_pop
| cont1 :: try_stack_now, cont2 :: _ ->
if Continuation.equal cont1 cont2
then no_pop
else add_pop cont1 ~try_stack_now
| cont :: try_stack_now, [] -> add_pop cont ~try_stack_now
| [], _ :: _ -> assert false
(* see above *)
in
let region_stack_at_handler =
Env.region_stack_in_cont_scope env continuation
in
let region_stack_now = Env.region_stack env in
if List.length region_stack_at_handler > List.length region_stack_now
then
Misc.fatal_errorf
"Cannot jump to continuation %a: it would involve jumping into a local \
allocation region"
Continuation.print continuation;
let rec add_end_regions acc ~region_stack_now =
(* This can maybe only be exercised right now using "match with exception",
since that causes jumps out of try-regions (but not normal regions). *)
(* CR pchambart: This closes all the regions between region_stack_now and
region_stack_at_handler, but closing only the last one should be
sufficient. *)
let add_end_region (region : Env.region_stack_element) ~region_stack_now
after_everything =
let add_remaining_end_regions acc =
add_end_regions acc ~region_stack_now
in
let body = add_remaining_end_regions acc after_everything in
fun acc ccenv ->
CC.close_let acc ccenv
[Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate]
Not_user_visible
(End_region { is_try_region = false; region })
~body
in
let no_end_region after_everything = after_everything in
match
Env.pop_region region_stack_now, Env.pop_region region_stack_at_handler
with
| None, None -> no_end_region
| Some (region1, region_stack_now), Some (region2, _) ->
if Env.same_region region1 region2
then no_end_region
else add_end_region region1 ~region_stack_now
| Some (region, region_stack_now), None ->
add_end_region region ~region_stack_now
| None, Some _ -> assert false
(* see above *)
in
add_pop_traps acc ~try_stack_now
(fun acc ccenv ->
add_end_regions acc ~region_stack_now
(fun acc ccenv ->
CC.close_apply_cont acc ccenv ~dbg continuation None args)
acc ccenv)
acc ccenv
let rec try_to_find_location (lam : L.lambda) =
(* This is very much best-effort and may overshoot, but will still likely be
better than nothing. *)
match lam with
| Lprim (_, _, loc)
| Lfunction { loc; _ }
| Lapply { ap_loc = loc; _ }
| Lfor { for_loc = loc; _ }
| Lswitch (_, _, loc, _)
| Lstringswitch (_, _, _, loc, _)
| Lsend (_, _, _, _, _, _, loc, _)
| Levent (_, { lev_loc = loc; _ }) ->
loc
| Llet (_, _, _, lam, _)
| Lmutlet (_, _, lam, _)
| Lletrec ((_, lam) :: _, _)
| Lifthenelse (lam, _, _, _)
| Lstaticcatch (lam, _, _, _)
| Lstaticraise (_, lam :: _)
| Lwhile { wh_cond = lam; _ }
| Lsequence (lam, _)
| Lassign (_, lam)
| Lifused (_, lam)
| Lregion (lam, _)
| Lexclave lam
| Ltrywith (lam, _, _, _) ->
try_to_find_location lam
| Lvar _ | Lmutvar _ | Lconst _ | Lletrec _ | Lstaticraise (_, []) ->
Debuginfo.Scoped_location.Loc_unknown
let try_to_find_debuginfo lam =
Debuginfo.from_location (try_to_find_location lam)
let switch_for_if_then_else ~cond ~ifso ~ifnot ~kind =
let switch : Lambda.lambda_switch =
{ sw_numconsts = 2;
sw_consts = [0, ifnot; 1, ifso];
sw_numblocks = 0;
sw_blocks = [];
sw_failaction = None
}
in
L.Lswitch (cond, switch, try_to_find_location cond, kind)
let transform_primitive env (prim : L.primitive) args loc =
match prim, args with
| Psequor, [arg1; arg2] ->
let const_true = Ident.create_local "const_true" in
let cond = Ident.create_local "cond_sequor" in
Transformed
(L.Llet
( Strict,
Lambda.layout_int,
const_true,
Lconst (Const_base (Const_int 1)),
L.Llet
( Strict,
Lambda.layout_int,
cond,
arg1,
switch_for_if_then_else ~cond:(L.Lvar cond)
~ifso:(L.Lvar const_true) ~ifnot:arg2 ~kind:Lambda.layout_int
) ))
| Psequand, [arg1; arg2] ->
let const_false = Ident.create_local "const_false" in
let cond = Ident.create_local "cond_sequand" in
Transformed
(L.Llet
( Strict,
Lambda.layout_int,
const_false,
Lconst (Const_base (Const_int 0)),
L.Llet
( Strict,
Lambda.layout_int,
cond,
arg1,
switch_for_if_then_else ~cond:(L.Lvar cond) ~ifso:arg2
~ifnot:(L.Lvar const_false) ~kind:Lambda.layout_int ) ))
| (Psequand | Psequor), _ ->
Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
| ( (Pbytes_to_string | Pbytes_of_string | Parray_of_iarray | Parray_to_iarray),
[arg] ) ->
Transformed arg
| Pignore, [arg] ->
let result = L.Lconst (Const_base (Const_int 0)) in
Transformed (L.Lsequence (arg, result))
| Pfield _, [L.Lprim (Pgetglobal cu, [], _)]
when Compilation_unit.equal cu (Env.current_unit env) ->
Misc.fatal_error
"[Pfield (Pgetglobal ...)] for the current compilation unit is forbidden \
upon entry to the middle end"
| Psetfield (_, _, _), [L.Lprim (Pgetglobal _, [], _); _] ->
Misc.fatal_error
"[Psetfield (Pgetglobal ...)] is forbidden upon entry to the middle end"
| Pfield (index, _, _), _ when index < 0 ->
Misc.fatal_error "Pfield with negative field index"
| Pfloatfield (i, _, _), _ when i < 0 ->
Misc.fatal_error "Pfloatfield with negative field index"
| Psetfield (index, _, _), _ when index < 0 ->
Misc.fatal_error "Psetfield with negative field index"
| Pmakeblock (tag, _, _, _), _ when tag < 0 || tag >= Obj.no_scan_tag ->
Misc.fatal_errorf "Pmakeblock with wrong or non-scannable block tag %d" tag
| Pmakefloatblock (_mut, _mode), args when List.length args < 1 ->
Misc.fatal_errorf "Pmakefloatblock must have at least one argument"
| Pfloatcomp CFnlt, args ->
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFlt, args, loc)], loc)
| Pfloatcomp CFngt, args ->
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFgt, args, loc)], loc)
| Pfloatcomp CFnle, args ->
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFle, args, loc)], loc)
| Pfloatcomp CFnge, args ->
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFge, args, loc)], loc)
| Punboxed_float_comp CFnlt, args ->
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFlt, args, loc)], loc)
| Punboxed_float_comp CFngt, args ->
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFgt, args, loc)], loc)
| Punboxed_float_comp CFnle, args ->
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFle, args, loc)], loc)
| Punboxed_float_comp CFnge, args ->
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFge, args, loc)], loc)
| Pbigarrayref (_unsafe, num_dimensions, kind, layout), args -> (
match
P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout
with
| Some _, Some _ -> Primitive (prim, args, loc)
| None, None | None, Some _ | Some _, None ->
if 1 <= num_dimensions && num_dimensions <= 3
then
let arity = 1 + num_dimensions in
let name = "caml_ba_get_" ^ string_of_int num_dimensions in
let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
Primitive (L.Pccall desc, args, loc)
else
Misc.fatal_errorf
"Lambda_to_flambda.transform_primitive: Pbigarrayref with unknown \
layout and elements should only have dimensions between 1 and 3 \
(see translprim).")
| Pbigarrayset (_unsafe, num_dimensions, kind, layout), args -> (
match
P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout
with
| Some _, Some _ -> Primitive (prim, args, loc)
| None, None | None, Some _ | Some _, None ->
if 1 <= num_dimensions && num_dimensions <= 3
then
let arity = 2 + num_dimensions in
let name = "caml_ba_set_" ^ string_of_int num_dimensions in
let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in
Primitive (L.Pccall desc, args, loc)
else
Misc.fatal_errorf
"Lambda_to_flambda.transform_primitive: Pbigarrayset with unknown \
layout and elements should only have dimensions between 1 and 3 \
(see translprim).")
| _, _ -> Primitive (prim, args, loc)
[@@ocaml.warning "-fragile-match"]
let rec_catch_for_while_loop env cond body =
let cont = L.next_raise_count () in
let env = Env.mark_as_recursive_static_catch env cont in
let cond_result = Ident.create_local "while_cond_result" in
let lam : L.lambda =
Lstaticcatch
( Lstaticraise (cont, []),
(cont, []),
Llet
( Strict,
Lambda.layout_int,
cond_result,
cond,
Lifthenelse
( Lvar cond_result,
Lsequence (body, Lstaticraise (cont, [])),
Lconst (Const_base (Const_int 0)),
Lambda.layout_unit ) ),
Lambda.layout_unit )
in
env, lam
let rec_catch_for_for_loop env loc ident start stop
(dir : Asttypes.direction_flag) body =
let cont = L.next_raise_count () in
let env = Env.mark_as_recursive_static_catch env cont in
let start_ident = Ident.create_local "for_start" in
let stop_ident = Ident.create_local "for_stop" in
let first_test : L.lambda =
match dir with
| Upto -> Lprim (Pintcomp Cle, [L.Lvar start_ident; L.Lvar stop_ident], loc)
| Downto ->
Lprim (Pintcomp Cge, [L.Lvar start_ident; L.Lvar stop_ident], loc)
in
let subsequent_test : L.lambda =
Lprim (Pintcomp Cne, [L.Lvar ident; L.Lvar stop_ident], loc)
in
let one : L.lambda = Lconst (Const_base (Const_int 1)) in
let next_value_of_counter =
match dir with
| Upto -> L.Lprim (Paddint, [L.Lvar ident; one], loc)
| Downto -> L.Lprim (Psubint, [L.Lvar ident; one], loc)
in
let lam : L.lambda =
(* Care needs to be taken here not to cause overflow if, for an incrementing
for-loop, the upper bound is [max_int]; likewise, for a decrementing
for-loop, if the lower bound is [min_int]. *)
Llet
( Strict,
Lambda.layout_int,
start_ident,
start,
Llet
( Strict,
Lambda.layout_int,
stop_ident,
stop,
Lifthenelse
( first_test,
Lstaticcatch
( Lstaticraise (cont, [L.Lvar start_ident]),
(cont, [ident, Lambda.layout_int]),
Lsequence
( body,
Lifthenelse
( subsequent_test,
Lstaticraise (cont, [next_value_of_counter]),
L.lambda_unit,
Lambda.layout_unit ) ),
Lambda.layout_unit ),
L.lambda_unit,
Lambda.layout_unit ) ) )
in
env, lam
let is_user_visible env id : IR.user_visible =
if Ident.stamp id >= Env.ident_stamp_upon_starting env
then Not_user_visible
else
let name = Ident.name id in
if String.starts_with ~prefix:"*opt*" name
then User_visible
else
let len = String.length name in
if len > 0 && Char.equal name.[0] '*'
then Not_user_visible
else User_visible
let let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler
~params
~(body : Acc.t -> Env.t -> CCenv.t -> Continuation.t -> Expr_with_acc.t)
~(handler : Acc.t -> Env.t -> CCenv.t -> Expr_with_acc.t) : Expr_with_acc.t
=
let cont = Continuation.create () in
let { Env.body_env; handler_env; extra_params } =
Env.add_continuation env cont ~push_to_try_stack:is_exn_handler Nonrecursive
in
let handler_env, params_rev =
List.fold_left
(fun (handler_env, params_rev) (id, visible, layout) ->
let arity_component =
Flambda_arity.Component_for_creation.from_lambda layout
in
match arity_component with
| Singleton kind ->
let param = id, visible, kind in
handler_env, param :: params_rev
| Unboxed_product _ ->
let arity = Flambda_arity.create [arity_component] in
let fields =
List.mapi
(fun n kind ->
let field =
Ident.create_local
(Printf.sprintf "%s_unboxed%d" (Ident.unique_name id) n)
in
field, kind)
(Flambda_arity.unarize arity)
in
let handler_env =
Env.register_unboxed_product handler_env ~unboxed_product:id
~before_unarization:arity_component ~fields
in
let new_params_rev =
List.map (fun (id, kind) -> id, IR.Not_user_visible, kind) fields
|> List.rev
in
handler_env, new_params_rev @ params_rev)
(handler_env, []) params
in
let params = List.rev params_rev in
let extra_params =
List.map (fun (id, kind) -> id, is_user_visible env id, kind) extra_params
in
let handler acc ccenv = handler acc handler_env ccenv in
let body acc ccenv = body acc body_env ccenv cont in
CC.close_let_cont acc ccenv ~name:cont ~is_exn_handler
~params:(params @ extra_params) ~recursive:Nonrecursive ~body ~handler
let restore_continuation_context acc env ccenv cont ~close_early body =
match Env.pop_regions_up_to_context env cont with
| None -> body acc ccenv cont
| Some region ->
(* If we need to close regions early then do it now; otherwise redirect the
return continuation to the one closing such regions, if any exist. See
comment in [cps] on the [Lregion] case. *)
if close_early
then
CC.close_let acc ccenv
[Ident.create_local "unit", Flambda_kind.With_subkind.tagged_immediate]
Not_user_visible
(End_region { is_try_region = false; region })
~body:(fun acc ccenv -> body acc ccenv cont)
else
let ({ continuation_closing_region; continuation_after_closing_region }
: Env.region_closure_continuation) =
Env.region_closure_continuation env region
in
if not (Continuation.equal cont continuation_after_closing_region)
then
Misc.fatal_errorf
"The continuation %a following the region closure should be the \
current continuation %a"
Continuation.print continuation_after_closing_region
Continuation.print cont;
body acc ccenv continuation_closing_region
let restore_continuation_context_for_switch_arm env cont =
match Env.pop_regions_up_to_context env cont with
| None -> cont
| Some region ->
let ({ continuation_closing_region; continuation_after_closing_region }
: Env.region_closure_continuation) =
Env.region_closure_continuation env region
in
if not (Continuation.equal cont continuation_after_closing_region)
then
Misc.fatal_errorf
"The continuation %a following the region closure should be the \
current continuation %a"
Continuation.print continuation_after_closing_region Continuation.print
cont;
continuation_closing_region
let apply_cont_with_extra_args acc env ccenv ~dbg cont traps args =
let extra_args =
List.map
(fun var : IR.simple -> Var var)
(Env.extra_args_for_continuation env cont)
in
restore_continuation_context acc env ccenv cont ~close_early:false
(fun acc ccenv cont ->
CC.close_apply_cont acc ~dbg ccenv cont traps (args @ extra_args))
let wrap_return_continuation acc env ccenv (apply : IR.apply) =
let extra_args = Env.extra_args_for_continuation env apply.continuation in
let close_early, region =
match apply.region_close with
| Rc_normal | Rc_nontail -> false, apply.region
| Rc_close_at_apply -> true, Env.my_region env
in
let body acc ccenv continuation =
match extra_args with
| [] -> CC.close_apply acc ccenv { apply with continuation; region }
| _ :: _ ->
let wrapper_cont = Continuation.create () in
let return_kinds = Flambda_arity.unarized_components apply.return_arity in
let return_value_components =
List.mapi
(fun i _ -> Ident.create_local (Printf.sprintf "return_val%d" i))
return_kinds
in
let args =
List.map
(fun var : IR.simple -> Var var)
(return_value_components @ extra_args)
in
let dbg = Debuginfo.none in
let handler acc ccenv =
CC.close_apply_cont acc ccenv ~dbg continuation None args
in
let body acc ccenv =
CC.close_apply acc ccenv
{ apply with continuation = wrapper_cont; region }
in
(* CR mshinwell: Think about DWARF support for unboxed products, here and
elsewhere. *)
let params =
List.map2
(fun return_value_component kind ->
return_value_component, IR.Not_user_visible, kind)
return_value_components return_kinds
in
CC.close_let_cont acc ccenv ~name:wrapper_cont ~is_exn_handler:false
~params ~recursive:Nonrecursive ~body ~handler
in
restore_continuation_context acc env ccenv apply.continuation ~close_early
body
let primitive_can_raise (prim : Lambda.primitive) =
match prim with
| Pccall _ | Praise _ | Parrayrefs _ | Parraysets _ | Pmodint _ | Pdivint _
| Pstringrefs | Pbytesrefs | Pbytessets
| Pstring_load_16 false
| Pstring_load_32 (false, _)
| Pstring_load_64 (false, _)
| Pstring_load_128 { unsafe = false; _ }
| Pbytes_load_16 false
| Pbytes_load_32 (false, _)
| Pbytes_load_64 (false, _)
| Pbytes_load_128 { unsafe = false; _ }
| Pbytes_set_16 false
| Pbytes_set_32 false
| Pbytes_set_64 false
| Pbytes_set_128 { unsafe = false; _ }
| Pbigstring_load_16 false
| Pbigstring_load_32 (false, _)
| Pbigstring_load_64 (false, _)
| Pbigstring_load_128 { unsafe = false; _ }
| Pbigstring_set_16 false
| Pbigstring_set_32 false
| Pbigstring_set_64 false
| Pbigstring_set_128 { unsafe = false; _ }
| Pdivbint { is_safe = Safe; _ }
| Pmodbint { is_safe = Safe; _ }
| Pbigarrayref (false, _, _, _)
| Pbigarrayset (false, _, _, _)
(* These bigarray primitives are translated into c-calls which may raise even
if the unsafe flag is true *)
| Pbigarrayref (_, _, Pbigarray_unknown, _)
| Pbigarrayset (_, _, Pbigarray_unknown, _)
| Pbigarrayref (_, _, _, Pbigarray_unknown_layout)
| Pbigarrayset (_, _, _, Pbigarray_unknown_layout) ->
true
| Pbytes_to_string | Pbytes_of_string | Parray_of_iarray | Parray_to_iarray
| Pignore | Pgetglobal _ | Psetglobal _ | Pgetpredef _ | Pmakeblock _
| Pmakefloatblock _ | Pfield _ | Pfield_computed _ | Psetfield _
| Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
| Pmakeufloatblock _ | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor
| Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint
| Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats
| Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _
| Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
| Pdivfloat _ | Pfloatcomp _ | Punboxed_float_comp _ | Pstringlength
| Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu | Pmakearray _
| Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _
| Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
| Psubbint _ | Pmulbint _
| Pdivbint { is_safe = Unsafe; _ }
| Pmodbint { is_safe = Unsafe; _ }
| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _
| Pbintcomp _ | Pbigarraydim _
| Pbigarrayref
( true,
_,
( Pbigarray_float32 | Pbigarray_float64 | Pbigarray_sint8
| Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16
| Pbigarray_int32 | Pbigarray_int64 | Pbigarray_caml_int
| Pbigarray_native_int | Pbigarray_complex32 | Pbigarray_complex64 ),
_ )
| Pbigarrayset
( true,
_,
( Pbigarray_float32 | Pbigarray_float64 | Pbigarray_sint8
| Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16
| Pbigarray_int32 | Pbigarray_int64 | Pbigarray_caml_int
| Pbigarray_native_int | Pbigarray_complex32 | Pbigarray_complex64 ),
(Pbigarray_c_layout | Pbigarray_fortran_layout) )
| Pstring_load_16 true
| Pstring_load_32 (true, _)
| Pstring_load_64 (true, _)
| Pstring_load_128 { unsafe = true; _ }
| Pbytes_load_16 true
| Pbytes_load_32 (true, _)
| Pbytes_load_64 (true, _)
| Pbytes_load_128 { unsafe = true; _ }
| Pbytes_set_16 true
| Pbytes_set_32 true
| Pbytes_set_64 true
| Pbytes_set_128 { unsafe = true; _ }
| Pbigstring_load_16 true
| Pbigstring_load_32 (true, _)
| Pbigstring_load_64 (true, _)
| Pbigstring_load_128 { unsafe = true; _ }
| Pbigstring_set_16 true
| Pbigstring_set_32 true
| Pbigstring_set_64 true
| Pbigstring_set_128 { unsafe = true; _ }
| Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque _
| Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float
| Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _
| Punboxed_product_field _ | Pget_header _ ->
false
| Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false
| Prunstack | Pperform | Presume | Preperform | Pdls_get ->
Misc.fatal_errorf "Primitive %a is not yet supported by Flambda 2"
Printlambda.primitive prim
type non_tail_continuation =
Acc.t ->
Env.t ->
CCenv.t ->
IR.simple list ->
[`Complex] Flambda_arity.Component_for_creation.t ->
Expr_with_acc.t
type non_tail_list_continuation =
Acc.t ->
Env.t ->
CCenv.t ->
IR.simple list list ->
[`Complex] Flambda_arity.Component_for_creation.t list ->
Expr_with_acc.t
type cps_continuation =
| Tail of Continuation.t
| Non_tail of non_tail_continuation
let apply_cps_cont_simple k ?(dbg = Debuginfo.none) acc env ccenv simples
(arity_component : [`Complex] Flambda_arity.Component_for_creation.t) =
match k with
| Tail k -> apply_cont_with_extra_args acc env ccenv ~dbg k None simples
| Non_tail k -> k acc env ccenv simples arity_component
let apply_cps_cont k ?dbg acc env ccenv id
(arity_component : [`Complex] Flambda_arity.Component_for_creation.t) =
apply_cps_cont_simple k ?dbg acc env ccenv [IR.Var id] arity_component
let maybe_insert_let_cont result_var_name layout k acc env ccenv body =
match k with
| Tail k -> body acc env ccenv k
| Non_tail k ->
let arity_component =
Flambda_arity.Component_for_creation.from_lambda layout
in
let arity = Flambda_arity.create [arity_component] in
if Flambda_arity.cardinal_unarized arity < 1
then
let_cont_nonrecursive_with_extra_params acc env ccenv
~is_exn_handler:false ~params:[]
~handler:(fun acc env ccenv -> k acc env ccenv [] arity_component)
~body
else
let result_var = Ident.create_local result_var_name in
let_cont_nonrecursive_with_extra_params acc env ccenv
~is_exn_handler:false
~params:[result_var, IR.Not_user_visible, layout]
~handler:(fun acc env ccenv ->
k acc env ccenv [IR.Var result_var] arity_component)
~body
let name_if_not_var acc ccenv name simple kind body =
match simple with
| IR.Var id -> body id acc ccenv
| IR.Const _ ->
let id = Ident.create_local name in
CC.close_let acc ccenv
[id, kind]
Not_user_visible (IR.Simple simple) ~body:(body id)
let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
(k_exn : Continuation.t) : Expr_with_acc.t =
match lam with
| Lvar id -> (
assert (not (Env.is_mutable env id));
match Env.get_unboxed_product_fields env id with
| None ->
let kind =
match CCenv.find_simple_to_substitute_exn ccenv id with
| exception Not_found -> snd (CCenv.find_var ccenv id)
| _, kind -> kind
in
let arity_component =
Flambda_arity.Component_for_creation.Singleton kind
in
apply_cps_cont k acc env ccenv id arity_component
| Some (before_unarization, fields) ->
let fields = List.map (fun id -> IR.Var id) fields in
apply_cps_cont_simple k acc env ccenv fields before_unarization)
| Lmutvar id ->
(* CR mshinwell: note: mutable variables of non-singleton layouts are not
supported *)
let return_id, kind = Env.get_mutable_variable_with_kind env id in
apply_cps_cont k acc env ccenv return_id
(Flambda_arity.Component_for_creation.Singleton kind)
| Lconst const ->
apply_cps_cont_simple k acc env ccenv [IR.Const const]
(Singleton
(Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
(Lambda.structured_constant_layout const)))
| Lapply
{ ap_func;
ap_args;
ap_result_layout;
ap_region_close;
ap_mode;
ap_loc;
ap_tailcall = _;
ap_inlined;
ap_specialised = _;
ap_probe
} ->
(* Note that we don't need kind information about [ap_args] since we already
have it on the corresponding [Simple]s in the environment. *)
maybe_insert_let_cont "apply_result" ap_result_layout k acc env ccenv
(fun acc env ccenv k ->
cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode
ap_loc ap_inlined ap_probe ap_result_layout k k_exn)
| Lfunction func ->
let id = Ident.create_local (name_for_function func) in
let dbg = Debuginfo.from_location func.loc in
let func =
cps_function env ~fid:id ~recursive:(Non_recursive : Recursive.t) func
in
let body acc ccenv =
apply_cps_cont k ~dbg acc env ccenv id
(Singleton Flambda_kind.With_subkind.any_value)
in
CC.close_let_rec acc ccenv ~function_declarations:[func] ~body
~current_region:(Env.current_region env)
| Lmutlet (value_kind, id, defining_expr, body) ->
(* CR mshinwell: user-visibleness needs thinking about here *)
let temp_id = Ident.create_local "let_mutable" in
let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false
~params:[temp_id, IR.Not_user_visible, value_kind]
~body:(fun acc env ccenv after_defining_expr ->
cps_tail acc env ccenv defining_expr after_defining_expr k_exn)
~handler:(fun acc env ccenv ->
let kind =
Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
value_kind
in
let env, new_id = Env.register_mutable_variable env id kind in
let body acc ccenv = cps acc env ccenv body k k_exn in
CC.close_let acc ccenv
[new_id, kind]
User_visible (Simple (Var temp_id)) ~body)
| Llet ((Strict | Alias | StrictOpt), _, fun_id, Lfunction func, body) ->
(* This case is here to get function names right. *)
let bindings = cps_function_bindings env [fun_id, L.Lfunction func] in
let body acc ccenv = cps acc env ccenv body k k_exn in
let let_expr =
List.fold_left
(fun body func acc ccenv ->
CC.close_let_rec acc ccenv ~function_declarations:[func] ~body
~current_region:(Env.current_region env))
body bindings
in
let_expr acc ccenv
| Llet ((Strict | Alias | StrictOpt), layout, id, Lconst const, body) ->
(* This case avoids extraneous continuations. *)
let body acc ccenv = cps acc env ccenv body k k_exn in
let kind =
Flambda_kind.With_subkind.from_lambda_values_and_unboxed_numbers_only
layout
in
CC.close_let acc ccenv
[id, kind]
(is_user_visible env id) (Simple (Const const)) ~body
| Llet
( ((Strict | Alias | StrictOpt) as let_kind),
layout,
id,
Lprim (prim, args, loc),
body ) -> (
match transform_primitive env prim args loc with
| Primitive (prim, args, loc) ->
(* This case avoids extraneous continuations. *)
let exn_continuation : IR.exn_continuation option =
if primitive_can_raise prim
then
Some
{ exn_handler = k_exn;
extra_args = extra_args_for_exn_continuation env k_exn
}
else None
in
cps_non_tail_list acc env ccenv args
(fun acc env ccenv args _arity ->
let env, ids_with_kinds =
match layout with
| Ptop | Pbottom ->
Misc.fatal_error "Cannot bind layout [Ptop] or [Pbottom]"
| Pvalue _ | Punboxed_int _ | Punboxed_float | Punboxed_vector _ ->
( env,
[ ( id,
Flambda_kind.With_subkind
.from_lambda_values_and_unboxed_numbers_only layout ) ] )
| Punboxed_product layouts ->
let arity_component =
Flambda_arity.Component_for_creation.Unboxed_product
(List.map Flambda_arity.Component_for_creation.from_lambda
layouts)
in
let arity = Flambda_arity.create [arity_component] in
let fields = Flambda_arity.fresh_idents_unarized ~id arity in
let env =
Env.register_unboxed_product env ~unboxed_product:id
~before_unarization:arity_component ~fields
in
env, fields
in
let body acc ccenv = cps acc env ccenv body k k_exn in
let region = Env.current_region env in
CC.close_let acc ccenv ids_with_kinds (is_user_visible env id)
(Prim { prim; args; loc; exn_continuation; region })
~body)
k_exn
| Transformed lam ->
cps acc env ccenv (L.Llet (let_kind, layout, id, lam, body)) k k_exn)
| Llet
( (Strict | Alias | StrictOpt),
_,
id,
Lassign (being_assigned, new_value),
body ) ->
(* This case is also to avoid extraneous continuations in code that relies
on the ref-conversion optimisation. *)
if not (Env.is_mutable env being_assigned)
then
Misc.fatal_errorf "Lassign on non-mutable variable %a" Ident.print
being_assigned;
cps_non_tail_simple acc env ccenv new_value
(fun acc env ccenv new_value _arity ->
let new_value = must_be_singleton_simple new_value in
let env, new_id = Env.update_mutable_variable env being_assigned in
let body acc ccenv =
let body acc ccenv = cps acc env ccenv body k k_exn in
CC.close_let acc ccenv
[id, Flambda_kind.With_subkind.tagged_immediate]
Not_user_visible (Simple (Const L.const_unit)) ~body
in
let value_kind =
snd (Env.get_mutable_variable_with_kind env being_assigned)
in
CC.close_let acc ccenv
[new_id, value_kind]
User_visible (Simple new_value) ~body)
k_exn
| Llet ((Strict | Alias | StrictOpt), _layout, id, defining_expr, Lvar id')
when Ident.same id id' ->
(* Simplif already simplifies such bindings, but we can generate new ones
when translating primitives (see the Lprim case below). *)
(* This case must not be moved above the case for let-bound primitives. *)
cps acc env ccenv defining_expr k k_exn
| Llet ((Strict | Alias | StrictOpt), layout, id, defining_expr, body) ->
let_cont_nonrecursive_with_extra_params acc env ccenv ~is_exn_handler:false
~params:[id, is_user_visible env id, layout]
~body:(fun acc env ccenv after_defining_expr ->
cps_tail acc env ccenv defining_expr after_defining_expr k_exn)
~handler:(fun acc env ccenv -> cps acc env ccenv body k k_exn)
(* CR pchambart: This version would avoid one let cont, but would miss the
value kind. It should be used when CC.close_let can propagate the
value_kind. *)
(* let k acc env ccenv value =
* let body acc ccenv = cps acc env ccenv body k k_exn in
* CC.close_let acc ccenv id User_visible value_kind (Simple value) ~body
* in
* cps_non_tail_simple acc env ccenv defining_expr k k_exn *)
| Lletrec (bindings, body) -> (
let free_vars_kind id =
let _, kind_with_subkind = CCenv.find_var ccenv id in
Some
(Flambda_kind.to_lambda
(Flambda_kind.With_subkind.kind kind_with_subkind))
in
match Dissect_letrec.dissect_letrec ~bindings ~body ~free_vars_kind with
| Unchanged ->
let function_declarations = cps_function_bindings env bindings in
let body acc ccenv = cps acc env ccenv body k k_exn in
CC.close_let_rec acc ccenv ~function_declarations ~body
~current_region:(Env.current_region env)
| Dissected lam -> cps acc env ccenv lam k k_exn)
| Lprim (prim, args, loc) -> (
match[@ocaml.warning "-fragile-match"] prim with
| Praise raise_kind -> (
match args with
| [_] ->
cps_non_tail_list acc env ccenv args
(fun acc _env ccenv args _arity ->
if List.compare_length_with (List.hd args) 1 <> 0
then Misc.fatal_error "Lraise takes only one unarized argument";
let exn_continuation : IR.exn_continuation =
{ exn_handler = k_exn;
extra_args = extra_args_for_exn_continuation env k_exn
}
in
let dbg = Debuginfo.from_location loc in
CC.close_raise acc ccenv ~raise_kind
~arg:(List.hd (List.hd args))
~dbg exn_continuation)
k_exn
| [] | _ :: _ ->
Misc.fatal_errorf "Wrong number of arguments for Lraise: %a"
Printlambda.primitive prim)
| _ ->
(* The code for translating primitives needs a let binding, so we
introduce such a binding explicitly. *)
(* For primitives like [Psequand], which are transformed instead, this
binding is useless and can move calls out of tail position, so we rely
on a special case above that removes such bindings when the bound
expression isn't a primitive. *)
let name = Printlambda.name_of_primitive prim in
let id = Ident.create_local name in
let result_layout = L.primitive_result_layout prim in
(match result_layout with
| Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _
| Punboxed_product _ ->
()
| Ptop | Pbottom ->
Misc.fatal_errorf "Invalid result layout %a for primitive %a"
Printlambda.layout result_layout Printlambda.primitive prim);
cps acc env ccenv
(L.Llet (Strict, result_layout, id, lam, L.Lvar id))
k k_exn)
| Lswitch (scrutinee, switch, loc, kind) ->
maybe_insert_let_cont "switch_result" kind k acc env ccenv
(fun acc env ccenv k ->
cps_switch acc env ccenv switch
~condition_dbg:(Debuginfo.from_location loc)
~scrutinee k k_exn)
| Lstringswitch (scrutinee, cases, default, loc, kind) ->
cps acc env ccenv
(Matching.expand_stringswitch loc kind scrutinee cases default)
k k_exn
| Lstaticraise (static_exn, args) ->
let continuation = Env.get_static_exn_continuation env static_exn in
cps_non_tail_list acc env ccenv args
(fun acc env ccenv args _arity ->
let extra_args =
List.map
(fun var : IR.simple -> Var var)
(Env.extra_args_for_continuation env continuation)