-
Notifications
You must be signed in to change notification settings - Fork 86
/
Copy pathcmmgen.ml
1595 lines (1506 loc) · 59.6 KB
/
cmmgen.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 *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* 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. *)
(* *)
(**************************************************************************)
(* Translation from closed lambda to C-- *)
[@@@ocaml.warning "-40"]
open Misc
open Arch
open Asttypes
open Primitive
open Types
open Lambda
open Clambda
open Clambda_primitives
open Cmm
module String = Misc.Stdlib.String
module IntMap = Map.Make(Int)
module V = Backend_var
module VP = Backend_var.With_provenance
open Cmm_helpers
(* Environments used for translation to Cmm. *)
type boxed_number =
| Boxed_float of alloc_mode * Debuginfo.t
| Boxed_integer of boxed_integer * alloc_mode * Debuginfo.t
type env = {
unboxed_ids : (V.t * boxed_number) V.tbl;
notify_catch : (Cmm.expression list -> unit) IntMap.t;
environment_param : V.t option;
trywith_depth : int;
catch_trywith_depths : int IntMap.t;
}
(* notify_catch associates to each catch handler a callback
which will be passed the list of arguments of each
staticfail instruction pointing to that handler. This
allows transl_catch to observe concrete arguments passed to each
handler parameter and decide whether to unbox them accordingly.
Other ways to achieve the same result would be to either (1) traverse
the body of the catch block after translation (this would be costly
and could easily lead to quadratric behavior) or (2) return
a description of arguments passed to each catch handler as an extra
value to be threaded through all transl_* functions (this would be
quite heavy, and probably less efficient that the callback approach).
*)
let empty_env =
{
unboxed_ids = V.empty;
notify_catch = IntMap.empty;
environment_param = None;
trywith_depth = 0;
catch_trywith_depths = IntMap.empty;
}
let create_env ~environment_param =
{ empty_env with
environment_param;
}
let is_unboxed_id id env =
try Some (V.find_same id env.unboxed_ids)
with Not_found -> None
let add_unboxed_id id unboxed_id bn env =
{ env with
unboxed_ids = V.add id (unboxed_id, bn) env.unboxed_ids;
}
let add_notify_catch n f env =
{ env with
notify_catch = IntMap.add n f env.notify_catch;
}
let notify_catch i env l =
match IntMap.find_opt i env.notify_catch with
| Some f -> f l
| None -> ()
let incr_depth env =
{ env with trywith_depth = succ env.trywith_depth; }
let enter_catch_body env nfail =
{ env with
catch_trywith_depths =
IntMap.add nfail env.trywith_depth env.catch_trywith_depths;
}
let mk_traps env nfail =
let handler_depth =
match IntMap.find_opt nfail env.catch_trywith_depths with
| None -> Misc.fatal_errorf "Cmmgen.mk_traps: Unknown handler %d" nfail
| Some d -> d
in
if handler_depth = env.trywith_depth then []
else begin
assert (handler_depth <= env.trywith_depth);
List.init (env.trywith_depth - handler_depth) (fun _ -> Pop)
end
(* Description of the "then" and "else" continuations in [transl_if]. If
the "then" continuation is true and the "else" continuation is false then
we can use the condition directly as the result. Similarly, if the "then"
continuation is false and the "else" continuation is true then we can use
the negation of the condition directly as the result. *)
type then_else =
| Then_true_else_false
| Then_false_else_true
| Unknown
let invert_then_else = function
| Then_true_else_false -> Then_false_else_true
| Then_false_else_true -> Then_true_else_false
| Unknown -> Unknown
let mut_from_env env ptr =
match env.environment_param with
| None -> Asttypes.Mutable
| Some environment_param ->
match ptr with
| Cvar ptr ->
(* Loads from the current function's closure are immutable. *)
if V.same environment_param ptr then Asttypes.Immutable
else Asttypes.Mutable
| _ -> Asttypes.Mutable
let get_field env ptr n dbg =
let mut = mut_from_env env ptr in
get_field_gen mut ptr n dbg
type rhs_kind =
| RHS_block of int
| RHS_infix of { blocksize : int; offset : int }
| RHS_floatblock of int
| RHS_nonrec
;;
let rec expr_size env = function
| Uvar id ->
begin try V.find_same id env with Not_found -> RHS_nonrec end
| Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
RHS_block (fundecls_size functions + List.length not_scanned_slots
+ List.length scanned_slots)
| Ulet(_str, _kind, id, exp, body) ->
expr_size (V.add (VP.var id) (expr_size env exp) env) body
| Uletrec(bindings, body) ->
let env =
List.fold_right
(fun (id, exp) env -> V.add (VP.var id) (expr_size env exp) env)
bindings env
in
expr_size env body
| Uprim(Pmakeblock _, args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _, _), args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray(Pfloatarray, _, _), args, _) ->
RHS_floatblock (List.length args)
| Uprim(Pmakearray(Pgenarray, _, _), _, _) ->
(* Pgenarray is excluded from recursive bindings by the
check in Translcore.check_recursive_lambda *)
RHS_nonrec
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
RHS_block sz
| Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false
| Uprim (Pduprecord (Record_extension _, sz), _, _) ->
RHS_block (sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock sz
| Uprim (Pccall { prim_name; _ }, closure::_, _)
when prim_name = "caml_check_value_is_closure" ->
(* Used for "-clambda-checks". *)
expr_size env closure
| Usequence(_exp, exp') ->
expr_size env exp'
| Uoffset (exp, offset) ->
(match expr_size env exp with
| RHS_block blocksize -> RHS_infix { blocksize; offset }
| RHS_nonrec -> RHS_nonrec
| _ -> assert false)
| Uregion exp ->
expr_size env exp
| Utail exp ->
expr_size env exp
| _ -> RHS_nonrec
(* Translate structured constants to Cmm data items *)
let transl_constant dbg = function
| Uconst_int n ->
int_const dbg n
| Uconst_ref (label, def_opt) ->
Option.iter
(fun def -> Cmmgen_state.add_structured_constant label def)
def_opt;
Cconst_symbol (label, dbg)
let emit_constant cst cont =
match cst with
| Uconst_int n ->
cint_const n
:: cont
| Uconst_ref (sym, _) ->
Csymbol_address sym :: cont
let emit_structured_constant ((_sym, is_global) as symb) cst cont =
match cst with
| Uconst_float s ->
emit_float_constant symb s cont
| Uconst_string s ->
emit_string_constant symb s cont
| Uconst_int32 n ->
emit_int32_constant symb n cont
| Uconst_int64 n ->
emit_int64_constant symb n cont
| Uconst_nativeint n ->
emit_nativeint_constant symb n cont
| Uconst_block (tag, csts) ->
let cont = List.fold_right emit_constant csts cont in
emit_block symb (block_header tag (List.length csts)) cont
| Uconst_float_array fields ->
emit_float_array_constant symb fields cont
| Uconst_closure(fundecls, lbl, fv) ->
Cmmgen_state.add_constant lbl (Const_closure (is_global, fundecls, fv));
List.iter (fun f -> Cmmgen_state.add_function f) fundecls;
cont
(* Boxed integers *)
let box_int_constant sym bi n =
match bi with
Pnativeint ->
emit_nativeint_constant (sym, Local) n []
| Pint32 ->
let n = Nativeint.to_int32 n in
emit_int32_constant (sym, Local) n []
| Pint64 ->
let n = Int64.of_nativeint n in
emit_int64_constant (sym, Local) n []
let box_int dbg bi mode arg =
match arg with
| Cconst_int (n, _) ->
let sym = Compilenv.new_const_symbol () in
let data_items = box_int_constant sym bi (Nativeint.of_int n) in
Cmmgen_state.add_data_items data_items;
Cconst_symbol (sym, dbg)
| Cconst_natint (n, _) ->
let sym = Compilenv.new_const_symbol () in
let data_items = box_int_constant sym bi n in
Cmmgen_state.add_data_items data_items;
Cconst_symbol (sym, dbg)
| _ ->
box_int_gen dbg bi mode arg
(* Boxed numbers *)
let typ_of_boxed_number = function
| Boxed_float _ -> Cmm.typ_float
| Boxed_integer (Pint64, _,_) when size_int = 4 -> [|Int;Int|]
| Boxed_integer _ -> Cmm.typ_int
let equal_unboxed_integer ui1 ui2 =
match ui1, ui2 with
| Pnativeint, Pnativeint -> true
| Pint32, Pint32 -> true
| Pint64, Pint64 -> true
| _, _ -> false
let equal_boxed_number bn1 bn2 =
match bn1, bn2 with
| Boxed_float _, Boxed_float _ -> true
| Boxed_integer(ui1, m, _), Boxed_integer(ui2, m', _) ->
equal_unboxed_integer ui1 ui2 && Lambda.eq_mode m m'
| _, _ -> false
let box_number bn arg =
match bn with
| Boxed_float (m, dbg) -> box_float dbg m arg
| Boxed_integer (bi, m, dbg) -> box_int dbg bi m arg
(* Returns the unboxed representation of a boxed float or integer.
For Pint32 on 64-bit archs, the high 32 bits of the result are undefined. *)
let unbox_number dbg bn arg =
match bn with
| Boxed_float (_, dbg) ->
unbox_float dbg arg
| Boxed_integer (Pint32, _, _) ->
low_32 dbg (unbox_int dbg Pint32 arg)
| Boxed_integer (bi, _, _) ->
unbox_int dbg bi arg
(* Auxiliary functions for optimizing "let" of boxed numbers (floats and
boxed integers *)
type unboxed_number_kind =
No_unboxing
| Boxed of boxed_number * bool (* true: boxed form available at no cost *)
| No_result (* expression never returns a result *)
(* Given unboxed_number_kind from two branches of the code, returns the
resulting unboxed_number_kind.
If [strict=false], one knows that the type of the expression
is an unboxable number, and we decide to return an unboxed value
if this indeed eliminates at least one allocation.
If [strict=true], we need to ensure that all possible branches
return an unboxable number (of the same kind). This could not
be the case in presence of GADTs.
*)
let join_unboxed_number_kind ~strict k1 k2 =
match k1, k2 with
| Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 ->
Boxed (b1, c1 && c2)
| No_result, k | k, No_result ->
k (* if a branch never returns, it is safe to unbox it *)
| No_unboxing, k | k, No_unboxing when not strict ->
k
| _, _ -> No_unboxing
let is_strict = function
| Pfloatval | Pboxedintval _ -> false
| Pintval | Pgenval | Pvariant _ | Parrayval _ -> true
let rec is_unboxed_number_cmm = function
| Cop(Calloc mode, [Cconst_natint (hdr, _); _], dbg)
when Nativeint.equal hdr float_header ->
Boxed (Boxed_float (mode, dbg), false)
| Cop(Calloc mode, [Cconst_natint (hdr, _); Cconst_symbol (ops, _); _], dbg) ->
if Nativeint.equal hdr boxedintnat_header
&& String.equal ops caml_nativeint_ops
then
Boxed (Boxed_integer (Pnativeint, mode, dbg), false)
else
if Nativeint.equal hdr boxedint32_header
&& String.equal ops caml_int32_ops
then
Boxed (Boxed_integer (Pint32, mode, dbg), false)
else
if Nativeint.equal hdr boxedint64_header
&& String.equal ops caml_int64_ops
then
Boxed (Boxed_integer (Pint64, mode, dbg), false)
else
No_unboxing
| Cconst_symbol (s, _) ->
begin match Cmmgen_state.structured_constant_of_sym s with
| Some (Uconst_float _) ->
Boxed (Boxed_float (alloc_heap, Debuginfo.none), true)
| Some (Uconst_nativeint _) ->
Boxed (Boxed_integer (Pnativeint, alloc_heap, Debuginfo.none), true)
| Some (Uconst_int32 _) ->
Boxed (Boxed_integer (Pint32, alloc_heap, Debuginfo.none), true)
| Some (Uconst_int64 _) ->
Boxed (Boxed_integer (Pint64, alloc_heap, Debuginfo.none), true)
| _ ->
No_unboxing
end
| Cexit _ | Cop (Craise _, _, _) -> No_result
| Csequence (_, a) | Cregion a | Ctail a
| Clet (_, _, a) | Cphantom_let (_, _, a) | Clet_mut (_, _, _, a) ->
is_unboxed_number_cmm a
| Cconst_int _
| Cconst_natint _
| Cconst_float _
| Cvar _
| Cassign _
| Ctuple _
| Cop _ -> No_unboxing
| Cifthenelse (_, _, _, _, _, _, Vval (Pintval | Pvariant _))
| Cswitch (_, _, _, _, Vval (Pintval | Pvariant _))
| Ctrywith (_, _, _, _, _, Vval (Pintval | Pvariant _))
| Ccatch (_, _, _, Vval (Pintval | Pvariant _)) ->
No_unboxing
| Cifthenelse (_, _, a, _, b, _, Vval kind) ->
join_unboxed_number_kind ~strict:(is_strict kind)
(is_unboxed_number_cmm a)
(is_unboxed_number_cmm b)
| Cswitch (_, _, cases, _, Vval kind) ->
let cases = Array.map (fun (x, _) -> is_unboxed_number_cmm x) cases in
let strict = is_strict kind in
Array.fold_left (join_unboxed_number_kind ~strict) No_result cases
| Ctrywith (a, _, _, b, _, Vval kind) ->
join_unboxed_number_kind ~strict:(is_strict kind)
(is_unboxed_number_cmm a)
(is_unboxed_number_cmm b)
| Ccatch (_, handlers, body, Vval kind) ->
let strict = is_strict kind in
List.fold_left
(join_unboxed_number_kind ~strict)
(is_unboxed_number_cmm body)
(List.map (fun (_, _, e, _) -> is_unboxed_number_cmm e) handlers)
| Cifthenelse (_, _, _, _, _, _, _)
| Cswitch (_, _, _, _, _)
| Ctrywith (_, _, _, _, _, _)
| Ccatch (_, _, _, _) ->
No_unboxing
(* Translate an expression *)
let rec transl env e =
match e with
Uvar id ->
begin match is_unboxed_id id env with
| None -> Cvar id
| Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id)
end
| Uconst sc ->
transl_constant Debuginfo.none sc
| Uclosure { functions ; not_scanned_slots = [] ; scanned_slots = [] } ->
let sym = Compilenv.new_const_symbol() in
Cmmgen_state.add_constant sym (Const_closure (Local, functions, []));
List.iter (fun f -> Cmmgen_state.add_function f) functions;
let dbg =
match functions with
| [] -> Debuginfo.none
| fundecl::_ -> fundecl.dbg
in
Cconst_symbol (sym, dbg)
| Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
let startenv = fundecls_size functions + List.length not_scanned_slots in
let mode =
Option.get @@
List.fold_left (fun s { mode; dbg; _ } ->
match s with
| None -> Some mode
| Some m' ->
if not (Lambda.eq_mode mode m') then
Misc.fatal_errorf "Inconsistent modes in let rec at %s"
(Debuginfo.to_string dbg);
s) None functions in
let rec transl_fundecls pos = function
[] ->
List.map (transl env) (not_scanned_slots @ scanned_slots)
| f :: rem ->
let is_last = match rem with [] -> true | _::_ -> false in
Cmmgen_state.add_function f;
let dbg = f.dbg in
let without_header =
match f.arity with
| Curried _, (1|0) as arity ->
Cconst_symbol (f.label, dbg) ::
alloc_closure_info ~arity
~startenv:(startenv - pos) ~is_last dbg ::
transl_fundecls (pos + 3) rem
| arity ->
Cconst_symbol (curry_function_sym arity, dbg) ::
alloc_closure_info ~arity
~startenv:(startenv - pos) ~is_last dbg ::
Cconst_symbol (f.label, dbg) ::
transl_fundecls (pos + 4) rem
in
if pos = 0
then without_header
else alloc_infix_header pos f.dbg :: without_header
in
let dbg =
match functions with
| [] -> Debuginfo.none
| fundecl::_ -> fundecl.dbg
in
make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 functions)
| Uoffset(arg, offset) ->
(* produces a valid Caml value, pointing just after an infix header *)
let ptr = transl env arg in
let dbg = Debuginfo.none in
ptr_offset ptr offset dbg
| Udirect_apply(handler_code_sym, args, Some { name; }, _, dbg) ->
let args = List.map (transl env) args in
return_unit dbg
(Cop(Cprobe { name; handler_code_sym; }, args, dbg))
| Udirect_apply(lbl, args, None, kind, dbg) ->
let args = List.map (transl env) args in
direct_apply lbl args kind dbg
| Ugeneric_apply(clos, args, kind, dbg) ->
let clos = transl env clos in
let args = List.map (transl env) args in
generic_apply (mut_from_env env clos) clos args kind dbg
| Usend(kind, met, obj, args, pos, dbg) ->
let met = transl env met in
let obj = transl env obj in
let args = List.map (transl env) args in
send kind met obj args pos dbg
| Ulet(str, kind, id, exp, body) ->
transl_let env str kind id exp (fun env -> transl env body)
| Uphantom_let (var, defining_expr, body) ->
let defining_expr =
match defining_expr with
| None -> None
| Some defining_expr ->
let defining_expr =
match defining_expr with
| Uphantom_const (Uconst_ref (sym, _defining_expr)) ->
Cphantom_const_symbol sym
| Uphantom_read_symbol_field { sym; field; } ->
Cphantom_read_symbol_field { sym; field; }
| Uphantom_const (Uconst_int i) ->
Cphantom_const_int (targetint_const i)
| Uphantom_var var -> Cphantom_var var
| Uphantom_read_field { var; field; } ->
Cphantom_read_field { var; field; }
| Uphantom_offset_var { var; offset_in_words; } ->
Cphantom_offset_var { var; offset_in_words; }
| Uphantom_block { tag; fields; } ->
Cphantom_block { tag; fields; }
in
Some defining_expr
in
Cphantom_let (var, defining_expr, transl env body)
| Uletrec(bindings, body) ->
transl_letrec env bindings (transl env body)
(* Primitives *)
| Uprim(prim, args, dbg) ->
begin match (simplif_primitive prim, args) with
| (Pread_symbol sym, []) ->
Cconst_symbol (sym, dbg)
| (Pmakeblock _, []) ->
assert false
| (Pmakeblock(tag, _mut, _kind, mode), args) ->
make_alloc ~mode dbg tag (List.map (transl env) args)
| (Pccall prim, args) ->
transl_ccall env prim args dbg
| (Pduparray (kind, _), [Uprim (Pmakearray (kind', _, _), args, _dbg)]) ->
(* We arrive here in two cases:
1. When using Closure, all the time.
2. When using Flambda, if a float array longer than
[Translcore.use_dup_for_constant_arrays_bigger_than] turns out
to be non-constant.
If for some reason Flambda fails to lift a constant array we
could in theory also end up here.
Note that [kind] above is unconstrained, but with the current
state of [Translcore], we will in fact only get here with
[Pfloatarray]s. *)
assert (kind = kind');
transl_make_array dbg env kind alloc_heap args
| (Pduparray _, [arg]) ->
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
in
transl_ccall env prim_obj_dup [arg] dbg
| (Pmakearray _, []) ->
Misc.fatal_error "Pmakearray is not allowed for an empty array"
| (Pmakearray (kind, _, mode), args) ->
transl_make_array dbg env kind mode args
| (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
let elt =
bigarray_get unsafe elt_kind layout
(transl env arg1) (List.map (transl env) argl) dbg in
begin match elt_kind with
(* TODO: local allocation of bigarray elements *)
Pbigarray_float32 | Pbigarray_float64 -> box_float dbg alloc_heap elt
| Pbigarray_complex32 | Pbigarray_complex64 -> elt
| Pbigarray_int32 -> box_int dbg Pint32 alloc_heap elt
| Pbigarray_int64 -> box_int dbg Pint64 alloc_heap elt
| Pbigarray_native_int -> box_int dbg Pnativeint alloc_heap elt
| Pbigarray_caml_int -> tag_int elt dbg
| Pbigarray_sint8 | Pbigarray_uint8
| Pbigarray_sint16 | Pbigarray_uint16 -> tag_int elt dbg
| Pbigarray_unknown -> assert false
end
| (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
let (argidx, argnewval) = split_last argl in
return_unit dbg (bigarray_set unsafe elt_kind layout
(transl env arg1)
(List.map (transl env) argidx)
(match elt_kind with
Pbigarray_float32 | Pbigarray_float64 ->
transl_unbox_float dbg env argnewval
| Pbigarray_complex32 | Pbigarray_complex64 -> transl env argnewval
| Pbigarray_int32 -> transl_unbox_int dbg env Pint32 argnewval
| Pbigarray_int64 -> transl_unbox_int dbg env Pint64 argnewval
| Pbigarray_native_int ->
transl_unbox_int dbg env Pnativeint argnewval
| Pbigarray_caml_int ->
untag_int (transl env argnewval) dbg
| Pbigarray_sint8 | Pbigarray_uint8
| Pbigarray_sint16 | Pbigarray_uint16 ->
ignore_high_bit_int (untag_int (transl env argnewval) dbg)
| Pbigarray_unknown -> assert false)
dbg)
| (Pbigarraydim(n), [b]) ->
let dim_ofs = 4 + n in
tag_int (Cop(Cload (Word_int, Mutable),
[field_address (transl env b) dim_ofs dbg],
dbg)) dbg
| (Pprobe_is_enabled {name}, []) ->
tag_int (Cop(Cprobe_is_enabled {name}, [], dbg)) dbg
| (p, [arg]) ->
transl_prim_1 env p arg dbg
| (p, [arg1; arg2]) ->
transl_prim_2 env p arg1 arg2 dbg
| (p, [arg1; arg2; arg3]) ->
transl_prim_3 env p arg1 arg2 arg3 dbg
| (Pread_symbol _, _::_::_::_::_)
| (Pbigarrayset (_, _, _, _), [])
| (Pbigarrayref (_, _, _, _), [])
| ((Pbigarraydim _ | Pduparray (_, _)), ([] | _::_::_::_::_))
| (Pprobe_is_enabled _, _)
->
fatal_error "Cmmgen.transl:prim, wrong arity"
| ((Pfield_computed|Psequand
| Psequor | Pnot | Pnegint | Paddint | Psubint
| Pmulint | Pandint | Porint | Pxorint | Plslint
| Plsrint | Pasrint | Pintoffloat | Pfloatofint _
| Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _
| Pmulfloat _ | Pdivfloat _ | Pstringlength | Pstringrefu
| Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu
| Pbytesrefs | Pbytessets | Pisint | Pisout
| Pbswap16 | Pint_as_pointer | Popaque | Pfield _
| Psetfield (_, _, _) | Psetfield_computed (_, _)
| Pfloatfield _ | Psetfloatfield (_, _) | Pduprecord (_, _)
| Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ | Poffsetint _
| Pcompare_ints | Pcompare_floats | Pcompare_bints _
| Poffsetref _ | Pfloatcomp _ | Parraylength _
| Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _
| Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
| Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _
| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
| Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
| Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
| Pbbswap _), _)
->
fatal_error "Cmmgen.transl:prim"
end
(* Control structures *)
| Uswitch(arg, s, dbg, kind) ->
(* As in the bytecode interpreter, only matching against constants
can be checked *)
if Array.length s.us_index_blocks = 0 then
make_switch
(untag_int (transl env arg) dbg)
s.us_index_consts
(Array.map (fun expr -> transl env expr, dbg) s.us_actions_consts)
dbg (Vval kind)
else if Array.length s.us_index_consts = 0 then
bind "switch" (transl env arg) (fun arg ->
transl_switch dbg (Vval kind) env (get_tag arg dbg)
s.us_index_blocks s.us_actions_blocks)
else
bind "switch" (transl env arg) (fun arg ->
Cifthenelse(
Cop(Cand, [arg; Cconst_int (1, dbg)], dbg),
dbg,
transl_switch dbg (Vval kind) env
(untag_int arg dbg) s.us_index_consts s.us_actions_consts,
dbg,
transl_switch dbg (Vval kind) env
(get_tag arg dbg) s.us_index_blocks s.us_actions_blocks,
dbg, Vval kind))
| Ustringswitch(arg,sw,d, kind) ->
let dbg = Debuginfo.none in
bind "switch" (transl env arg)
(fun arg ->
strmatch_compile dbg (Vval kind) arg (Option.map (transl env) d)
(List.map (fun (s,act) -> s,transl env act) sw))
| Ustaticfail (nfail, args) ->
let cargs = List.map (transl env) args in
notify_catch nfail env cargs;
let traps = mk_traps env nfail in
Cexit (Lbl nfail, cargs, traps)
| Ucatch(nfail, [], body, handler, kind) ->
let dbg = Debuginfo.none in
let env_body = enter_catch_body env nfail in
make_catch (Vval kind) nfail
(transl env_body body)
(transl env handler) dbg
| Ucatch(nfail, ids, body, handler, kind) ->
let dbg = Debuginfo.none in
transl_catch (Vval kind) env nfail ids body handler dbg
| Utrywith(body, exn, handler, kind) ->
let dbg = Debuginfo.none in
let new_body = transl (incr_depth env) body in
Ctrywith(new_body, Regular, exn, transl env handler, dbg, Vval kind)
| Uifthenelse(cond, ifso, ifnot, kind) ->
let ifso_dbg = Debuginfo.none in
let ifnot_dbg = Debuginfo.none in
let dbg = Debuginfo.none in
transl_if env (Vval kind) Unknown dbg cond
ifso_dbg (transl env ifso) ifnot_dbg (transl env ifnot)
| Usequence(exp1, exp2) ->
Csequence(remove_unit(transl env exp1), transl env exp2)
| Uwhile(cond, body) ->
let dbg = Debuginfo.none in
let raise_num = next_raise_count () in
return_unit dbg
(ccatch
(raise_num, [],
create_loop(transl_if env (Vval Pgenval) Unknown dbg cond
dbg (remove_unit(transl env body))
dbg (Cexit (Lbl raise_num,[],[]))
)
dbg,
Ctuple [],
dbg, Vval Pgenval))
| Ufor(id, low, high, dir, body) ->
let dbg = Debuginfo.none in
let tst = match dir with Upto -> Cgt | Downto -> Clt in
let inc = match dir with Upto -> Caddi | Downto -> Csubi in
let raise_num = next_raise_count () in
let id_prev = VP.create (V.create_local "*id_prev*") in
return_unit dbg
(Clet_mut
(id, typ_int, transl env low,
bind_nonvar "bound" (transl env high) (fun high ->
ccatch
(raise_num, [],
Cifthenelse
(Cop(Ccmpi tst, [Cvar (VP.var id); high], dbg),
dbg,
Cexit (Lbl raise_num, [], []),
dbg,
create_loop
(Csequence
(remove_unit(transl env body),
Clet(id_prev, Cvar (VP.var id),
Csequence
(Cassign(VP.var id,
Cop(inc, [Cvar (VP.var id); Cconst_int (2, dbg)],
dbg)),
Cifthenelse
(Cop(Ccmpi Ceq, [Cvar (VP.var id_prev); high],
dbg),
dbg, Cexit (Lbl raise_num,[],[]),
dbg, Ctuple [],
dbg, Vint (* unit *))))))
dbg,
dbg, Vint (* unit*)),
Ctuple [],
dbg, Vint (* unit *)))))
| Uassign(id, exp) ->
let dbg = Debuginfo.none in
let cexp = transl env exp in
begin match is_unboxed_id id env with
| None ->
return_unit dbg (Cassign(id, cexp))
| Some (unboxed_id, bn) ->
return_unit dbg (Cassign(unboxed_id, unbox_number dbg bn cexp))
end
| Uunreachable ->
let dbg = Debuginfo.none in
Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg)
| Uregion e ->
region (transl env e)
| Utail e ->
Ctail (transl env e)
and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in
(* Translate the body, and while doing so, collect the "unboxing type" for
each argument. *)
let report args =
List.iter2
(fun (_id, kind, u) c ->
let strict = is_strict kind in
u := join_unboxed_number_kind ~strict !u
(is_unboxed_number_cmm c)
)
ids args
in
let env_body = enter_catch_body (add_notify_catch nfail report env) nfail in
let body = transl env_body body in
let new_env, rewrite, ids =
List.fold_right
(fun (id, _kind, u) (env, rewrite, ids) ->
match !u with
| No_unboxing | Boxed (_, true) | No_result ->
env,
(fun x -> x) :: rewrite,
(id, Cmm.typ_val) :: ids
| Boxed (bn, false) ->
let unboxed_id = V.create_local (VP.name id) in
add_unboxed_id (VP.var id) unboxed_id bn env,
(unbox_number Debuginfo.none bn) :: rewrite,
(VP.create unboxed_id, typ_of_boxed_number bn) :: ids
)
ids (env, [], [])
in
if env == new_env then
(* No unboxing *)
ccatch (nfail, ids, body, transl env handler, dbg, kind)
else
(* allocate new "nfail" to catch errors more easily *)
let new_nfail = next_raise_count () in
let body =
(* Rewrite the body to unbox the call sites *)
let rec aux e =
match Cmm.map_shallow aux e with
| Cexit (Lbl n, el, traps) when n = nfail ->
Cexit (Lbl new_nfail, List.map2 (fun f e -> f e) rewrite el, traps)
| c -> c
in
aux body
in
ccatch (new_nfail, ids, body, transl new_env handler, dbg, kind)
and transl_make_array dbg env kind mode args =
match kind with
| Pgenarray ->
let func =
match (mode : Lambda.alloc_mode) with
| Alloc_heap -> "caml_make_array"
| Alloc_local -> "caml_make_array_local"
in
Cop(Cextcall { func;
builtin = false;
returns = true;
effects = Arbitrary_effects;
coeffects = Has_coeffects;
ty = typ_val; alloc = true; ty_args = []},
[make_alloc ~mode dbg 0 (List.map (transl env) args)], dbg)
| Paddrarray | Pintarray ->
make_alloc ~mode dbg 0 (List.map (transl env) args)
| Pfloatarray ->
make_float_alloc ~mode dbg Obj.double_array_tag
(List.map (transl_unbox_float dbg env) args)
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
match native_repr with
| Same_as_ocaml_repr ->
(XInt, transl env arg)
| Unboxed_float ->
(XFloat, transl_unbox_float dbg env arg)
| Unboxed_integer bi ->
let xty =
match bi with
| Pnativeint -> XInt
| Pint32 -> XInt32
| Pint64 -> XInt64 in
(xty, transl_unbox_int dbg env bi arg)
| Untagged_int ->
(XInt, untag_int (transl env arg) dbg)
in
let rec transl_args native_repr_args args =
match native_repr_args, args with
| [], args ->
(* We don't require the two lists to be of the same length as
[default_prim] always sets the arity to [0]. *)
(List.map (fun _ -> XInt) args, List.map (transl env) args)
| _, [] ->
assert false
| (_, native_repr) :: native_repr_args, arg :: args ->
let (ty1, arg') = transl_arg native_repr arg in
let (tys, args') = transl_args native_repr_args args in
(ty1 :: tys, arg' :: args')
in
let typ_res, wrap_result =
match prim.prim_native_repr_res with
| _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
(* TODO: Allow Alloc_local on suitably typed C stubs *)
| _, Unboxed_float -> (typ_float, box_float dbg alloc_heap)
| _, Unboxed_integer Pint64 when size_int = 4 ->
([|Int; Int|], box_int dbg Pint64 alloc_heap)
| _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap)
| _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
in
let typ_args, args = transl_args prim.prim_native_repr_args args in
let op = cextcall prim args dbg typ_res typ_args true in
wrap_result op
and transl_prim_1 env p arg dbg =
match p with
(* Generic operations *)
Popaque ->
opaque (transl env arg) dbg
(* Heap operations *)
| Pfield n ->
get_field env (transl env arg) n dbg
| Pfloatfield (n,mode) ->
let ptr = transl env arg in
box_float dbg mode (floatfield n ptr dbg)
| Pint_as_pointer ->
int_as_pointer (transl env arg) dbg
(* Exceptions *)
| Praise rkind ->
raise_prim rkind (transl env arg) dbg
(* Integer operations *)
| Pnegint ->
negint (transl env arg) dbg
| Poffsetint n ->
offsetint n (transl env arg) dbg
| Poffsetref n ->
offsetref n (transl env arg) dbg
(* Floating-point operations *)
| Pfloatofint m ->
box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
| Pintoffloat ->
tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg
| Pnegfloat m ->
box_float dbg m (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg))
| Pabsfloat m ->
box_float dbg m (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg))
(* String operations *)
| Pstringlength | Pbyteslength ->
tag_int(string_length (transl env arg) dbg) dbg
(* Array operations *)
| Parraylength kind ->
arraylength kind (transl env arg) dbg
(* Boolean operations *)
| Pnot ->
transl_if env Vint Then_false_else_true
dbg arg
dbg (Cconst_int (1, dbg))
dbg (Cconst_int (3, dbg))
(* Test integer/block *)
| Pisint ->
tag_int(Cop(Cand, [transl env arg; Cconst_int (1, dbg)], dbg)) dbg
(* Boxed integers *)
| Pbintofint (bi, m) ->
box_int dbg bi m (untag_int (transl env arg) dbg)
| Pintofbint bi ->
tag_int (transl_unbox_int dbg env bi arg) dbg
| Pcvtbint(bi1, bi2, m) ->
box_int dbg bi2 m (transl_unbox_int dbg env bi1 arg)
| Pnegbint (bi, m) ->
box_int dbg bi m
(Cop(Csubi, [Cconst_int (0, dbg); transl_unbox_int dbg env bi arg],
dbg))
| Pbbswap (bi, m) ->
box_int dbg bi m (bbswap bi (transl_unbox_int dbg env bi arg) dbg)
| Pbswap16 ->
tag_int (bswap16 (ignore_high_bit_int (untag_int
(transl env arg) dbg)) dbg) dbg
| (Pfield_computed | Psequand | Psequor
| Paddint | Psubint | Pmulint | Pandint
| Porint | Pxorint | Plslint | Plsrint | Pasrint
| Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
| Pstringrefu | Pstringrefs | Pbytesrefu | Pbytessetu
| Pbytesrefs | Pbytessets | Pisout | Pread_symbol _
| Pmakeblock (_, _, _, _) | Psetfield (_, _, _) | Psetfield_computed (_, _)
| Psetfloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Pdivint _
| Pmodint _ | Pintcomp _ | Pfloatcomp _ | Pmakearray (_, _, _)
| Pcompare_ints | Pcompare_floats | Pcompare_bints _
| Pduparray (_, _) | Parrayrefu _ | Parraysetu _
| Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _
| Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _
| Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _)
| Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
| Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _
| Pbigstring_load _ | Pbigstring_set _ | Pprobe_is_enabled _)
->
fatal_errorf "Cmmgen.transl_prim_1: %a"
Printclambda_primitives.primitive p
and transl_prim_2 env p arg1 arg2 dbg =
match p with
(* Heap operations *)
| Pfield_computed ->
addr_array_ref (transl env arg1) (transl env arg2) dbg
| Psetfield(n, ptr, init) ->
setfield n ptr init (transl env arg1) (transl env arg2) dbg
| Psetfloatfield (n, init) ->
let ptr = transl env arg1 in
let float_val = transl_unbox_float dbg env arg2 in
setfloatfield n init ptr float_val dbg
(* Boolean operations *)
| Psequand ->
let dbg' = Debuginfo.none in
transl_sequand env Vint Then_true_else_false
dbg arg1
dbg' arg2
dbg (Cconst_int (3, dbg))
dbg' (Cconst_int (1, dbg))
(* let id = V.create_local "res1" in
Clet(id, transl env arg1,
Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *)
| Psequor ->
let dbg' = Debuginfo.none in
transl_sequor env Vint Then_true_else_false
dbg arg1
dbg' arg2
dbg (Cconst_int (3, dbg))
dbg' (Cconst_int (1, dbg))
(* Integer operations *)
| Paddint ->
add_int_caml (transl env arg1) (transl env arg2) dbg
| Psubint ->