-
Notifications
You must be signed in to change notification settings - Fork 85
/
Copy pathlambda_to_flambda_primitives.ml
2091 lines (2003 loc) · 88.1 KB
/
lambda_to_flambda_primitives.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 2013--2019 OCamlPro SAS *)
(* Copyright 2014--2019 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. *)
(* *)
(**************************************************************************)
module H = Lambda_to_flambda_primitives_helpers
module K = Flambda_kind
module I = K.Standard_int
module I_or_f = K.Standard_int_or_float
module L = Lambda
module P = Flambda_primitive
let convert_signed signed = if signed then P.Signed else P.Unsigned
let convert_integer_comparison_prim (comp : L.integer_comparison)
(signed : bool) :
P.binary_primitive =
let signed = convert_signed signed in
match comp with
| Ceq -> Phys_equal Eq
| Cne -> Phys_equal Neq
| Clt -> Int_comp (Tagged_immediate, Yielding_bool (Lt signed))
| Cgt -> Int_comp (Tagged_immediate, Yielding_bool (Gt signed))
| Cle -> Int_comp (Tagged_immediate, Yielding_bool (Le signed))
| Cge -> Int_comp (Tagged_immediate, Yielding_bool (Ge signed))
let convert_boxed_integer_comparison_prim (kind : L.boxed_integer)
(comp : L.integer_comparison) (signed : bool) : P.binary_primitive =
let signed = convert_signed signed in
match kind, comp with
| Pint32, Ceq -> Int_comp (Naked_int32, Yielding_bool Eq)
| Pint32, Cne -> Int_comp (Naked_int32, Yielding_bool Neq)
| Pint32, Clt -> Int_comp (Naked_int32, Yielding_bool (Lt signed))
| Pint32, Cgt -> Int_comp (Naked_int32, Yielding_bool (Gt signed))
| Pint32, Cle -> Int_comp (Naked_int32, Yielding_bool (Le signed))
| Pint32, Cge -> Int_comp (Naked_int32, Yielding_bool (Ge signed))
| Pint64, Ceq -> Int_comp (Naked_int64, Yielding_bool Eq)
| Pint64, Cne -> Int_comp (Naked_int64, Yielding_bool Neq)
| Pint64, Clt -> Int_comp (Naked_int64, Yielding_bool (Lt signed))
| Pint64, Cgt -> Int_comp (Naked_int64, Yielding_bool (Gt signed))
| Pint64, Cle -> Int_comp (Naked_int64, Yielding_bool (Le signed))
| Pint64, Cge -> Int_comp (Naked_int64, Yielding_bool (Ge signed))
| Pnativeint, Ceq -> Int_comp (Naked_nativeint, Yielding_bool Eq)
| Pnativeint, Cne -> Int_comp (Naked_nativeint, Yielding_bool Neq)
| Pnativeint, Clt -> Int_comp (Naked_nativeint, Yielding_bool (Lt signed))
| Pnativeint, Cgt -> Int_comp (Naked_nativeint, Yielding_bool (Gt signed))
| Pnativeint, Cle -> Int_comp (Naked_nativeint, Yielding_bool (Le signed))
| Pnativeint, Cge -> Int_comp (Naked_nativeint, Yielding_bool (Ge signed))
let convert_float_comparison (comp : L.float_comparison) : unit P.comparison =
match comp with
| CFeq -> Eq
| CFneq -> Neq
| CFlt -> Lt ()
| CFgt -> Gt ()
| CFle -> Le ()
| CFge -> Ge ()
| CFnlt | CFngt | CFnle | CFnge ->
Misc.fatal_error
"Negated floating-point comparisons should have been removed by \
[Lambda_to_flambda]"
let boxable_number_of_boxed_integer (bint : L.boxed_integer) :
K.Boxable_number.t =
match bint with
| Pnativeint -> Naked_nativeint
| Pint32 -> Naked_int32
| Pint64 -> Naked_int64
let standard_int_of_boxed_integer (bint : L.boxed_integer) : K.Standard_int.t =
match bint with
| Pnativeint -> Naked_nativeint
| Pint32 -> Naked_int32
| Pint64 -> Naked_int64
let standard_int_or_float_of_boxed_integer (bint : L.boxed_integer) :
K.Standard_int_or_float.t =
match bint with
| Pnativeint -> Naked_nativeint
| Pint32 -> Naked_int32
| Pint64 -> Naked_int64
let convert_block_access_field_kind i_or_p : P.Block_access_field_kind.t =
match i_or_p with L.Immediate -> Immediate | L.Pointer -> Any_value
let convert_init_or_assign (i_or_a : L.initialization_or_assignment) :
P.Init_or_assign.t =
match i_or_a with
| Assignment mode -> Assignment (Alloc_mode.For_assignments.from_lambda mode)
| Heap_initialization -> Initialization
| Root_initialization ->
Misc.fatal_error "[Root_initialization] should not appear in Flambda input"
let convert_block_shape (shape : L.block_shape) ~num_fields =
match shape with
| None -> List.init num_fields (fun _field -> K.With_subkind.any_value)
| Some shape ->
let shape_length = List.length shape in
if num_fields <> shape_length
then
Misc.fatal_errorf
"Flambda_arity.of_block_shape: num_fields is %d yet the shape has %d \
fields"
num_fields shape_length;
List.map K.With_subkind.from_lambda_value_kind shape
let check_float_array_optimisation_enabled name =
if not (Flambda_features.flat_float_array ())
then
Misc.fatal_errorf
"[%s] is not expected when the float array optimisation is disabled" name
()
type converted_array_kind =
| Array_kind of P.Array_kind.t
| Float_array_opt_dynamic
let convert_array_kind (kind : L.array_kind) : converted_array_kind =
match kind with
| Pgenarray ->
check_float_array_optimisation_enabled "Pgenarray";
Float_array_opt_dynamic
| Paddrarray -> Array_kind Values
| Pintarray -> Array_kind Immediates
| Pfloatarray | Punboxedfloatarray Pfloat64 -> Array_kind Naked_floats
| Punboxedfloatarray Pfloat32 -> Array_kind Naked_float32s
| Punboxedintarray Pint32 -> Array_kind Naked_int32s
| Punboxedintarray Pint64 -> Array_kind Naked_int64s
| Punboxedintarray Pnativeint -> Array_kind Naked_nativeints
let convert_array_kind_for_length kind : P.Array_kind_for_length.t =
match convert_array_kind kind with
| Array_kind array_kind -> Array_kind array_kind
| Float_array_opt_dynamic -> Float_array_opt_dynamic
module Array_ref_kind = struct
type t =
| Immediates
| Values
| Naked_floats_to_be_boxed of L.alloc_mode
| Naked_floats
| Naked_float32s
| Naked_int32s
| Naked_int64s
| Naked_nativeints
end
type converted_array_ref_kind =
| Array_ref_kind of Array_ref_kind.t
| Float_array_opt_dynamic_ref of L.alloc_mode
let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind
=
match kind with
| Pgenarray_ref mode ->
(* CR mshinwell: We can't check this because of the translations of
primitives for Obj.size, Obj.field and Obj.set_field, which can be used
both on arrays and blocks. We should probably propagate the "%obj_..."
primitives which these functions use all the way to the middle end. Then
this check could be reinstated for all normal cases.
check_float_array_optimisation_enabled (); *)
Float_array_opt_dynamic_ref mode
| Paddrarray_ref -> Array_ref_kind Values
| Pintarray_ref -> Array_ref_kind Immediates
| Pfloatarray_ref mode -> Array_ref_kind (Naked_floats_to_be_boxed mode)
| Punboxedfloatarray_ref Pfloat64 -> Array_ref_kind Naked_floats
| Punboxedfloatarray_ref Pfloat32 -> Array_ref_kind Naked_float32s
| Punboxedintarray_ref Pint32 -> Array_ref_kind Naked_int32s
| Punboxedintarray_ref Pint64 -> Array_ref_kind Naked_int64s
| Punboxedintarray_ref Pnativeint -> Array_ref_kind Naked_nativeints
let convert_array_ref_kind_for_length array_ref_kind : P.Array_kind_for_length.t
=
match convert_array_ref_kind array_ref_kind with
| Float_array_opt_dynamic_ref _ -> Float_array_opt_dynamic
| Array_ref_kind Values -> Array_kind Values
| Array_ref_kind Immediates -> Array_kind Immediates
| Array_ref_kind (Naked_floats | Naked_floats_to_be_boxed _) ->
Array_kind Naked_floats
| Array_ref_kind Naked_float32s -> Array_kind Naked_float32s
| Array_ref_kind Naked_int32s -> Array_kind Naked_int32s
| Array_ref_kind Naked_int64s -> Array_kind Naked_int64s
| Array_ref_kind Naked_nativeints -> Array_kind Naked_nativeints
module Array_set_kind = struct
type t =
| Immediates
| Values of P.Init_or_assign.t
| Naked_floats
| Naked_floats_to_be_unboxed
| Naked_float32s
| Naked_int32s
| Naked_int64s
| Naked_nativeints
end
type converted_array_set_kind =
| Array_set_kind of Array_set_kind.t
| Float_array_opt_dynamic_set of Alloc_mode.For_assignments.t
let convert_intermediate_array_set_kind (kind : Array_set_kind.t) :
P.Array_set_kind.t =
match kind with
| Immediates -> Immediates
| Values init_or_assign -> Values init_or_assign
| Naked_floats | Naked_floats_to_be_unboxed -> Naked_floats
| Naked_float32s -> Naked_float32s
| Naked_int32s -> Naked_int32s
| Naked_int64s -> Naked_int64s
| Naked_nativeints -> Naked_nativeints
let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind
=
match kind with
| Pgenarray_set mode ->
(* CR mshinwell: see CR in [convert_array_ref_kind] above
check_float_array_optimisation_enabled (); *)
Float_array_opt_dynamic_set (Alloc_mode.For_assignments.from_lambda mode)
| Paddrarray_set mode ->
Array_set_kind
(Values (Assignment (Alloc_mode.For_assignments.from_lambda mode)))
| Pintarray_set -> Array_set_kind Immediates
| Pfloatarray_set -> Array_set_kind Naked_floats_to_be_unboxed
| Punboxedfloatarray_set Pfloat64 -> Array_set_kind Naked_floats
| Punboxedfloatarray_set Pfloat32 -> Array_set_kind Naked_float32s
| Punboxedintarray_set Pint32 -> Array_set_kind Naked_int32s
| Punboxedintarray_set Pint64 -> Array_set_kind Naked_int64s
| Punboxedintarray_set Pnativeint -> Array_set_kind Naked_nativeints
let convert_array_set_kind_for_length array_set_kind : P.Array_kind_for_length.t
=
match convert_array_set_kind array_set_kind with
| Float_array_opt_dynamic_set _ -> Float_array_opt_dynamic
| Array_set_kind (Values _) -> Array_kind Values
| Array_set_kind Immediates -> Array_kind Immediates
| Array_set_kind (Naked_floats | Naked_floats_to_be_unboxed) ->
Array_kind Naked_floats
| Array_set_kind Naked_float32s -> Array_kind Naked_float32s
| Array_set_kind Naked_int32s -> Array_kind Naked_int32s
| Array_set_kind Naked_int64s -> Array_kind Naked_int64s
| Array_set_kind Naked_nativeints -> Array_kind Naked_nativeints
type converted_duplicate_array_kind =
| Duplicate_array_kind of P.Duplicate_array_kind.t
| Float_array_opt_dynamic
let convert_array_kind_to_duplicate_array_kind (kind : L.array_kind) :
converted_duplicate_array_kind =
match kind with
| Pgenarray ->
check_float_array_optimisation_enabled "Pgenarray";
Float_array_opt_dynamic
| Paddrarray -> Duplicate_array_kind Values
| Pintarray -> Duplicate_array_kind Immediates
| Pfloatarray | Punboxedfloatarray Pfloat64 ->
Duplicate_array_kind (Naked_floats { length = None })
| Punboxedfloatarray Pfloat32 ->
Duplicate_array_kind (Naked_float32s { length = None })
| Punboxedintarray Pint32 ->
Duplicate_array_kind (Naked_int32s { length = None })
| Punboxedintarray Pint64 ->
Duplicate_array_kind (Naked_int64s { length = None })
| Punboxedintarray Pnativeint ->
Duplicate_array_kind (Naked_nativeints { length = None })
let convert_field_read_semantics (sem : L.field_read_semantics) : Mutability.t =
match sem with Reads_agree -> Immutable | Reads_vary -> Mutable
let bigarray_dim_bound b dimension =
H.Prim (Unary (Bigarray_length { dimension }, b))
let tag_int (arg : H.expr_primitive) : H.expr_primitive =
Unary (Tag_immediate, Prim arg)
let untag_int (arg : H.simple_or_prim) : H.simple_or_prim =
Prim (Unary (Untag_immediate, arg))
let unbox_float32 (arg : H.simple_or_prim) : H.simple_or_prim =
Prim (Unary (Unbox_number K.Boxable_number.Naked_float32, arg))
let box_float32 (mode : L.alloc_mode) (arg : H.expr_primitive) ~current_region :
H.expr_primitive =
Unary
( Box_number
( K.Boxable_number.Naked_float32,
Alloc_mode.For_allocations.from_lambda mode ~current_region ),
Prim arg )
let box_float (mode : L.alloc_mode) (arg : H.expr_primitive) ~current_region :
H.expr_primitive =
Unary
( Box_number
( K.Boxable_number.Naked_float,
Alloc_mode.For_allocations.from_lambda mode ~current_region ),
Prim arg )
let unbox_float (arg : H.simple_or_prim) : H.simple_or_prim =
Prim (Unary (Unbox_number K.Boxable_number.Naked_float, arg))
let box_bint bi mode (arg : H.expr_primitive) ~current_region : H.expr_primitive
=
Unary
( Box_number
( boxable_number_of_boxed_integer bi,
Alloc_mode.For_allocations.from_lambda mode ~current_region ),
Prim arg )
let unbox_bint bi (arg : H.simple_or_prim) : H.simple_or_prim =
Prim (Unary (Unbox_number (boxable_number_of_boxed_integer bi), arg))
let box_vec128 mode (arg : H.expr_primitive) ~current_region : H.expr_primitive
=
Unary
( Box_number
( Naked_vec128,
Alloc_mode.For_allocations.from_lambda mode ~current_region ),
Prim arg )
let unbox_vec128 (arg : H.simple_or_prim) : H.simple_or_prim =
Prim (Unary (Unbox_number Naked_vec128, arg))
let bint_unary_prim bi mode prim arg1 =
box_bint bi mode
(Unary
(Int_arith (standard_int_of_boxed_integer bi, prim), unbox_bint bi arg1))
let bint_binary_prim bi mode prim arg1 arg2 =
box_bint bi mode
(Binary
( Int_arith (standard_int_of_boxed_integer bi, prim),
unbox_bint bi arg1,
unbox_bint bi arg2 ))
let bint_shift bi mode prim arg1 arg2 =
box_bint bi mode
(Binary
( Int_shift (standard_int_of_boxed_integer bi, prim),
unbox_bint bi arg1,
untag_int arg2 ))
let convert_index_to_tagged_int index (index_kind : Lambda.array_index_kind) =
match index_kind with
| Ptagged_int_index -> index
| Punboxed_int_index bint ->
H.Prim
(Unary
( Num_conv
{ src = standard_int_or_float_of_boxed_integer bint;
dst = Tagged_immediate
},
index ))
let check_non_negative_imm imm prim_name =
if not (Targetint_31_63.is_non_negative imm)
then
Misc.fatal_errorf "%s with negative index %a" prim_name
Targetint_31_63.print imm
(* Smart constructor for checked accesses *)
let checked_access ~dbg ~primitive ~conditions : H.expr_primitive =
Checked
{ primitive;
validity_conditions = conditions;
failure = Index_out_of_bounds;
dbg
}
let checked_alignment ~dbg ~primitive ~conditions : H.expr_primitive =
Checked
{ primitive;
validity_conditions = conditions;
failure = Address_was_misaligned;
dbg
}
let check_bound_tagged tagged_index bound : H.expr_primitive =
Binary
( Int_comp (I.Naked_immediate, Yielding_bool (Lt Unsigned)),
untag_int tagged_index,
bound )
(* This computes the maximum of a given value [x] with zero, in an optimized
way. It takes as named argument the size (in bytes) of an integer register on
the target architecture.
It is equivalent to the `max_or_zero` function in `cmm_helpers.ml` *)
let max_with_zero ~size_int x =
let register_bitsize_minus_one =
H.Simple
(Simple.const
(Reg_width_const.naked_immediate
(Targetint_31_63.of_int ((size_int * 8) - 1))))
in
let sign =
H.Prim
(Binary (Int_shift (Naked_nativeint, Asr), x, register_bitsize_minus_one))
in
let minus_one =
H.Simple
(Simple.const
(Reg_width_const.naked_nativeint (Targetint_32_64.of_int (-1))))
in
let sign_negation =
H.Prim (Binary (Int_arith (Naked_nativeint, Xor), sign, minus_one))
in
let ret =
H.Prim (Binary (Int_arith (Naked_nativeint, And), sign_negation, x))
in
ret
(* actual (strict) upper bound for an index in a string-like read/write *)
let actual_max_length_for_string_like_access ~size_int ~access_size length =
(* offset to subtract from the length depending on the size of the
read/write *)
let length_offset_of_size size =
let offset =
match (size : Flambda_primitive.string_accessor_width) with
| Eight -> 0
| Sixteen -> 1
| Thirty_two | Single -> 3
| Sixty_four -> 7
| One_twenty_eight _ -> 15
in
Targetint_31_63.of_int offset
in
match (access_size : Flambda_primitive.string_accessor_width) with
| Eight -> length (* micro-optimization *)
| Sixteen | Thirty_two | Single | Sixty_four | One_twenty_eight _ ->
let offset = length_offset_of_size access_size in
let reduced_length =
H.Prim
(Binary
( Int_arith (Naked_immediate, Sub),
length,
Simple (Simple.const (Reg_width_const.naked_immediate offset)) ))
in
(* We need to convert the length into a naked_nativeint because the
optimised version of the max_with_zero function needs to be on
machine-width integers to work (or at least on an integer number of bytes
to work). *)
let reduced_length_nativeint =
H.Prim
(Unary
( Num_conv { src = Naked_immediate; dst = Naked_nativeint },
reduced_length ))
in
let nativeint_res = max_with_zero ~size_int reduced_length_nativeint in
H.Prim
(Unary
( Num_conv { src = Naked_nativeint; dst = Naked_immediate },
nativeint_res ))
(* String-like validity conditions *)
let string_like_access_validity_condition ~size_int ~access_size ~length index :
H.expr_primitive =
check_bound_tagged index
(actual_max_length_for_string_like_access ~size_int ~access_size length)
let string_or_bytes_access_validity_condition ~size_int str kind access_size
index : H.expr_primitive =
string_like_access_validity_condition index ~size_int ~access_size
~length:(Prim (Unary (String_length kind, str)))
let bigstring_access_validity_condition ~size_int big_str access_size index :
H.expr_primitive =
string_like_access_validity_condition index ~size_int ~access_size
~length:(bigarray_dim_bound big_str 1)
let bigstring_alignment_validity_condition bstr alignment tagged_index :
H.expr_primitive =
Binary
( Int_comp (I.Naked_immediate, Yielding_bool Eq),
Prim
(Binary (Bigarray_get_alignment alignment, bstr, untag_int tagged_index)),
Simple Simple.untagged_const_zero )
let checked_string_or_bytes_access ~dbg ~size_int ~access_size ~primitive kind
string index =
(match (access_size : P.string_accessor_width) with
| One_twenty_eight { aligned = true } ->
Misc.fatal_error
"flambda2 cannot yet check string/bytes aligned access safety"
| Eight | Sixteen | Thirty_two | Single | Sixty_four
| One_twenty_eight { aligned = false } ->
());
checked_access ~dbg ~primitive
~conditions:
[ string_or_bytes_access_validity_condition ~size_int string kind
access_size index ]
let checked_bigstring_access ~dbg ~size_int ~access_size ~primitive arg1 arg2 =
let primitive =
match (access_size : P.string_accessor_width) with
| One_twenty_eight { aligned = true } ->
checked_alignment ~dbg ~primitive
~conditions:[bigstring_alignment_validity_condition arg1 16 arg2]
| Eight | Sixteen | Thirty_two | Single | Sixty_four
| One_twenty_eight { aligned = false } ->
primitive
in
checked_access ~dbg ~primitive
~conditions:
[bigstring_access_validity_condition ~size_int arg1 access_size arg2]
(* String-like loads *)
let string_like_load_unsafe ~access_size kind mode ~boxed string index
~current_region =
let wrap =
match (access_size : Flambda_primitive.string_accessor_width), mode with
| (Eight | Sixteen), None ->
assert (not boxed);
tag_int
| Thirty_two, Some mode ->
if boxed then box_bint Pint32 mode ~current_region else Fun.id
| Single, Some mode ->
if boxed then box_float32 mode ~current_region else Fun.id
| Sixty_four, Some mode ->
if boxed then box_bint Pint64 mode ~current_region else Fun.id
| One_twenty_eight _, Some mode ->
if boxed then box_vec128 mode ~current_region else Fun.id
| (Eight | Sixteen), Some _
| (Thirty_two | Single | Sixty_four | One_twenty_eight _), None ->
Misc.fatal_error "Inconsistent alloc_mode for string or bytes load"
in
wrap (Binary (String_or_bigstring_load (kind, access_size), string, index))
let get_header obj mode ~current_region =
let wrap hd = box_bint Pnativeint mode hd ~current_region in
wrap (Unary (Get_header, obj))
let string_like_load_safe ~dbg ~size_int ~access_size kind mode ~boxed str index
~current_region =
match (kind : P.string_like_value) with
| String ->
checked_string_or_bytes_access ~dbg ~size_int ~access_size String
~primitive:
(string_like_load_unsafe ~access_size String mode ~boxed str index
~current_region)
str index
| Bytes ->
checked_string_or_bytes_access ~dbg ~size_int ~access_size Bytes
~primitive:
(string_like_load_unsafe ~access_size Bytes mode ~boxed str index
~current_region)
str index
| Bigstring ->
checked_bigstring_access ~dbg ~size_int ~access_size
~primitive:
(string_like_load_unsafe ~access_size Bigstring mode ~boxed str index
~current_region)
str index
(* Bytes-like set *)
let bytes_like_set_unsafe ~access_size kind ~boxed bytes index new_value =
let wrap =
match (access_size : Flambda_primitive.string_accessor_width) with
| Eight | Sixteen ->
assert (not boxed);
untag_int
| Thirty_two -> if boxed then unbox_bint Pint32 else Fun.id
| Single -> if boxed then unbox_float32 else Fun.id
| Sixty_four -> if boxed then unbox_bint Pint64 else Fun.id
| One_twenty_eight _ -> if boxed then unbox_vec128 else Fun.id
in
H.Ternary
(Bytes_or_bigstring_set (kind, access_size), bytes, index, wrap new_value)
let bytes_like_set_safe ~dbg ~size_int ~access_size kind ~boxed bytes index
new_value =
match (kind : P.bytes_like_value) with
| Bytes ->
checked_string_or_bytes_access ~dbg ~size_int ~access_size Bytes
~primitive:
(bytes_like_set_unsafe ~access_size Bytes ~boxed bytes index new_value)
bytes index
| Bigstring ->
checked_bigstring_access ~dbg ~size_int ~access_size
~primitive:
(bytes_like_set_unsafe ~access_size Bigstring ~boxed bytes index
new_value)
bytes index
(* Array vector load/store *)
let array_vector_access_validity_condition array ~size_int
(array_kind : P.Array_kind.t) index =
let width_in_scalars =
match array_kind with
| Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2
| Naked_int32s | Naked_float32s -> 4
| Values ->
Misc.fatal_error
"Attempted to load/store a SIMD vector from/to a value array."
in
let length_untagged =
untag_int (H.Prim (Unary (Array_length (Array_kind array_kind), array)))
in
let reduced_length_untagged =
H.Prim
(Binary
( Int_arith (Naked_immediate, Sub),
length_untagged,
Simple
(Simple.untagged_const_int
(Targetint_31_63.of_int (width_in_scalars - 1))) ))
in
(* We need to convert the length into a naked_nativeint because the optimised
version of the max_with_zero function needs to be on machine-width integers
to work (or at least on an integer number of bytes to work). *)
let reduced_length_nativeint =
H.Prim
(Unary
( Num_conv { src = Naked_immediate; dst = Naked_nativeint },
reduced_length_untagged ))
in
let check_nativeint = max_with_zero ~size_int reduced_length_nativeint in
let check_untagged =
H.Prim
(Unary
( Num_conv { src = Naked_nativeint; dst = Naked_immediate },
check_nativeint ))
in
check_bound_tagged index check_untagged
let check_array_vector_access ~dbg ~size_int ~array array_kind ~index primitive
: H.expr_primitive =
checked_access ~primitive
~conditions:
[array_vector_access_validity_condition ~size_int array array_kind index]
~dbg
let array_like_load_128 ~dbg ~size_int ~unsafe ~mode ~current_region array_kind
array index =
let primitive =
box_vec128 mode ~current_region
(H.Binary (Array_load (array_kind, Vec128, Mutable), array, index))
in
if unsafe
then primitive
else
check_array_vector_access ~dbg ~size_int ~array array_kind ~index primitive
let array_like_set_128 ~dbg ~size_int ~unsafe array_kind array index new_value =
let primitive =
H.Ternary
(Array_set (array_kind, Vec128), array, index, unbox_vec128 new_value)
in
if unsafe
then primitive
else
check_array_vector_access ~dbg ~size_int ~array
(P.Array_set_kind.array_kind array_kind)
~index primitive
(* Bigarray accesses *)
let bigarray_box_or_tag_raw_value_to_read kind alloc_mode =
let error what =
Misc.fatal_errorf "Don't know how to box %s after reading it in a bigarray"
what
in
match P.Bigarray_kind.element_kind kind with
| Value -> Fun.id
| Naked_number Naked_immediate -> fun arg -> H.Unary (Tag_immediate, Prim arg)
| Naked_number Naked_float32 ->
fun arg -> H.Unary (Box_number (Naked_float32, alloc_mode), Prim arg)
| Naked_number Naked_float ->
fun arg -> H.Unary (Box_number (Naked_float, alloc_mode), Prim arg)
| Naked_number Naked_int32 ->
fun arg -> H.Unary (Box_number (Naked_int32, alloc_mode), Prim arg)
| Naked_number Naked_int64 ->
fun arg -> H.Unary (Box_number (Naked_int64, alloc_mode), Prim arg)
| Naked_number Naked_nativeint ->
fun arg -> H.Unary (Box_number (Naked_nativeint, alloc_mode), Prim arg)
| Naked_number Naked_vec128 ->
fun arg -> H.Unary (Box_number (Naked_vec128, alloc_mode), Prim arg)
| Region -> error "a region expression"
| Rec_info -> error "recursion info"
let bigarray_unbox_or_untag_value_to_store kind =
let error what =
Misc.fatal_errorf "Don't know how to unbox %s to store it in a bigarray"
what
in
match P.Bigarray_kind.element_kind kind with
| Value -> Fun.id
| Naked_number Naked_immediate ->
fun arg -> H.Prim (Unary (Untag_immediate, arg))
| Naked_number Naked_float32 ->
fun arg -> H.Prim (Unary (Unbox_number Naked_float32, arg))
| Naked_number Naked_float ->
fun arg -> H.Prim (Unary (Unbox_number Naked_float, arg))
| Naked_number Naked_int32 ->
fun arg -> H.Prim (Unary (Unbox_number Naked_int32, arg))
| Naked_number Naked_int64 ->
fun arg -> H.Prim (Unary (Unbox_number Naked_int64, arg))
| Naked_number Naked_nativeint ->
fun arg -> H.Prim (Unary (Unbox_number Naked_nativeint, arg))
| Naked_number Naked_vec128 ->
fun arg -> H.Prim (Unary (Unbox_number Naked_vec128, arg))
| Region -> error "a region expression"
| Rec_info -> error "recursion info"
(* CR Gbury: this function in effect duplicates the bigarray_length access: one
is done in the validity check, and one in the final offset computation,
whereas cmmgen let-binds this access. It might matter for the performance,
although the processor cache might make it not matter at all. *)
let bigarray_indexing layout b args =
let num_dim = List.length args in
let rec aux dim delta_dim = function
| [] -> assert false
| [idx] ->
let bound = bigarray_dim_bound b dim in
let check = check_bound_tagged idx bound in
[check], idx
| idx :: r ->
let checks, rem = aux (dim + delta_dim) delta_dim r in
let bound = bigarray_dim_bound b dim in
let check = check_bound_tagged idx bound in
(* CR gbury: because we tag bound, and the tagged multiplication untags
it, we might be left with a needless zero-extend here. *)
let tmp =
H.Prim
(Binary
( Int_arith (I.Tagged_immediate, Mul),
rem,
Prim (Unary (Tag_immediate, bound)) ))
in
let offset =
H.Prim (Binary (Int_arith (I.Tagged_immediate, Add), tmp, idx))
in
check :: checks, offset
in
match (layout : P.Bigarray_layout.t) with
| C -> aux num_dim (-1) (List.rev args)
| Fortran ->
aux 1 1
(List.map
(fun idx ->
H.Prim
(Binary
( Int_arith (I.Tagged_immediate, Sub),
idx,
H.Simple (Simple.const_int Targetint_31_63.one) )))
args)
let bigarray_access ~dbg ~unsafe ~access layout b indexes =
let num_dim = List.length indexes in
let checks, offset = bigarray_indexing layout b indexes in
let primitive = access num_dim offset in
if unsafe
then primitive
else checked_access ~dbg ~conditions:checks ~primitive
let bigarray_load ~dbg ~unsafe kind layout b indexes =
let access num_dim offset =
H.Binary (Bigarray_load (num_dim, kind, layout), b, offset)
in
bigarray_access ~dbg ~unsafe ~access layout b indexes
let bigarray_set ~dbg ~unsafe kind layout b indexes value =
let access num_dim offset =
H.Ternary (Bigarray_set (num_dim, kind, layout), b, offset, value)
in
bigarray_access ~dbg ~unsafe ~access layout b indexes
(* Array accesses *)
let array_access_validity_condition array array_kind index
(index_kind : L.array_index_kind) =
let arr_len_as_tagged_imm = H.Prim (Unary (Array_length array_kind, array)) in
(* The reason why we convert the array length instead of the index value is
because of edge cases around large negative numbers.
Given [-9223372036854775807] as a [Naked_int64] index, its bit
representation is
[0b1000000000000000000000000000000000000000000000000000000000000001]. If we
convert that into a [Tagged_immediate], it becomes [0b11] and the bounds
check would pass in cases that we should reject.
This also has the added benefit of producing better assembly code. Usually
saving one instruction compared to tagging the index value. *)
let (comp_kind : I.t), arr_len =
match index_kind with
| Ptagged_int_index -> I.Tagged_immediate, arr_len_as_tagged_imm
| Punboxed_int_index bint ->
( standard_int_of_boxed_integer bint,
H.Prim
(Unary
( Num_conv
{ src = Tagged_immediate;
dst = standard_int_or_float_of_boxed_integer bint
},
arr_len_as_tagged_imm )) )
in
[H.Binary (Int_comp (comp_kind, Yielding_bool (Lt Unsigned)), index, arr_len)]
let check_array_access ~dbg ~array array_kind ~index ~index_kind primitive :
H.expr_primitive =
checked_access ~primitive
~conditions:
(array_access_validity_condition array array_kind index index_kind)
~dbg
let array_load_unsafe ~array ~index (array_ref_kind : Array_ref_kind.t)
~current_region : H.expr_primitive =
match array_ref_kind with
| Immediates -> Binary (Array_load (Immediates, Scalar, Mutable), array, index)
| Values -> Binary (Array_load (Values, Scalar, Mutable), array, index)
| Naked_floats_to_be_boxed mode ->
box_float mode
(Binary (Array_load (Naked_floats, Scalar, Mutable), array, index))
~current_region
| Naked_floats ->
Binary (Array_load (Naked_floats, Scalar, Mutable), array, index)
| Naked_float32s ->
Binary (Array_load (Naked_float32s, Scalar, Mutable), array, index)
| Naked_int32s ->
Binary (Array_load (Naked_int32s, Scalar, Mutable), array, index)
| Naked_int64s ->
Binary (Array_load (Naked_int64s, Scalar, Mutable), array, index)
| Naked_nativeints ->
Binary (Array_load (Naked_nativeints, Scalar, Mutable), array, index)
let array_set_unsafe ~array ~index ~new_value
(array_set_kind : Array_set_kind.t) : H.expr_primitive =
let new_value =
match array_set_kind with
| Immediates | Values _ | Naked_floats | Naked_float32s | Naked_int32s
| Naked_int64s | Naked_nativeints ->
new_value
| Naked_floats_to_be_unboxed -> unbox_float new_value
in
let array_set_kind = convert_intermediate_array_set_kind array_set_kind in
Ternary (Array_set (array_set_kind, Scalar), array, index, new_value)
let[@inline always] match_on_array_ref_kind ~array array_ref_kind f :
H.expr_primitive =
match convert_array_ref_kind array_ref_kind with
| Array_ref_kind array_ref_kind -> f array_ref_kind
| Float_array_opt_dynamic_ref mode ->
(* CR keryan: we should push the ITE as low as possible to avoid duplicating
too much *)
If_then_else
( Unary (Is_flat_float_array, array),
f (Array_ref_kind.Naked_floats_to_be_boxed mode),
f Array_ref_kind.Values )
let[@inline always] match_on_array_set_kind ~array array_ref_kind f :
H.expr_primitive =
match convert_array_set_kind array_ref_kind with
| Array_set_kind array_set_kind -> f array_set_kind
| Float_array_opt_dynamic_set mode ->
(* CR keryan: we should push the ITE as low as possible to avoid duplicating
too much *)
If_then_else
( Unary (Is_flat_float_array, array),
f Array_set_kind.Naked_floats_to_be_unboxed,
f (Array_set_kind.Values (Assignment mode)) )
(* Safe arith (div/mod by zero) *)
let checked_arith_op ~dbg (bi : Lambda.boxed_integer option) op mode arg1 arg2
~current_region : H.expr_primitive =
let primitive, kind, zero, arg_wrap =
match bi, mode with
| None, None ->
( H.Binary (Int_arith (I.Tagged_immediate, op), arg1, arg2),
I.Tagged_immediate,
Reg_width_const.tagged_immediate Targetint_31_63.zero,
Fun.id )
| Some bi, Some mode ->
let kind, zero =
match bi with
| Pint32 -> I.Naked_int32, Reg_width_const.naked_int32 0l
| Pint64 -> I.Naked_int64, Reg_width_const.naked_int64 0L
| Pnativeint ->
( I.Naked_nativeint,
Reg_width_const.naked_nativeint Targetint_32_64.zero )
in
( bint_binary_prim bi mode op arg1 arg2 ~current_region,
kind,
zero,
unbox_bint bi )
| _, _ -> Misc.fatal_error "Inconsistent allocation mode"
in
(* CR gbury: try and avoid the unboxing duplication of arg2. (the simplifier
might cse the duplication away, but it won't be the case for classic
mode). *)
Checked
{ primitive;
validity_conditions =
[ Binary
( Int_comp (kind, Yielding_bool Neq),
arg_wrap arg2,
Simple (Simple.const zero) ) ];
failure = Division_by_zero;
dbg
}
let bbswap bi si mode arg ~current_region : H.expr_primitive =
let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in
Unary
( Box_number (bi, mode),
Prim
(Unary
( Int_arith (si, Swap_byte_endianness),
Prim (Unary (Unbox_number bi, arg)) )) )
let opaque layout arg ~middle_end_only : H.expr_primitive list =
let kinds = Flambda_arity.unarize (Flambda_arity.from_lambda_list [layout]) in
if List.compare_lengths kinds arg <> 0
then
Misc.fatal_error
"Popaque/Pobj_magic layout does not have the same length as unarized \
argument";
List.map2
(fun arg_component kind : H.expr_primitive ->
let kind = K.With_subkind.kind kind in
Unary (Opaque_identity { middle_end_only; kind }, arg_component))
arg kinds
(* Primitive conversion *)
let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
(dbg : Debuginfo.t) ~current_region : H.expr_primitive list =
let orig_args = args in
let args =
List.map (List.map (fun arg : H.simple_or_prim -> Simple arg)) args
in
let size_int =
assert (Targetint.size mod 8 = 0);
Targetint.size / 8
in
match prim, args with
| Pmakeblock (tag, mutability, shape, mode), _ ->
let args = List.flatten args in
let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in
let tag = Tag.Scannable.create_exn tag in
let shape = convert_block_shape shape ~num_fields:(List.length args) in
let mutability = Mutability.from_lambda mutability in
[Variadic (Make_block (Values (tag, shape), mutability, mode), args)]
| Pmake_unboxed_product layouts, _ ->
if List.compare_lengths layouts args <> 0
then
Misc.fatal_errorf "Pmake_unboxed_product: expected %d arguments, got %d"
(List.length layouts) (List.length args);
List.map (fun arg : H.expr_primitive -> Simple arg) (List.flatten orig_args)
| Punboxed_product_field (n, layouts), [_] ->
let layouts_array = Array.of_list layouts in
if n < 0 || n >= Array.length layouts_array
then Misc.fatal_errorf "Invalid field index %d for Punboxed_product_field" n;
let field_arity_component =
(* N.B. The arity of the field being projected may in itself be an unboxed
product. *)
layouts_array.(n) |> Flambda_arity.Component_for_creation.from_lambda
in
let field_arity = Flambda_arity.create [field_arity_component] in
let num_fields_prior_to_projected_fields =
Misc.Stdlib.List.split_at n layouts
|> fst
|> List.map Flambda_arity.Component_for_creation.from_lambda
|> Flambda_arity.create |> Flambda_arity.cardinal_unarized
in
let num_projected_fields = Flambda_arity.cardinal_unarized field_arity in
let projected_args =
List.hd orig_args |> Array.of_list
|> (fun a ->
Array.sub a num_fields_prior_to_projected_fields num_projected_fields)
|> Array.to_list
in
List.map (fun arg : H.expr_primitive -> Simple arg) projected_args
| Pmakefloatblock (mutability, mode), _ ->
let args = List.flatten args in
let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in
let mutability = Mutability.from_lambda mutability in
[ Variadic
(Make_block (Naked_floats, mutability, mode), List.map unbox_float args)
]
| Pmakeufloatblock (mutability, mode), _ ->
let args = List.flatten args in
let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in
let mutability = Mutability.from_lambda mutability in
[Variadic (Make_block (Naked_floats, mutability, mode), args)]
| Pmakemixedblock (tag, mutability, shape, mode), _ ->
let args = List.flatten args in
let args =
List.mapi
(fun i arg ->
match Lambda.get_mixed_block_element shape i with