forked from colinbenner/ocaml-llvm
/
cmmgen.ml
2457 lines (2247 loc) · 90.1 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Translation from closed lambda to C-- *)
open Misc
open Arch
open Asttypes
open Primitive
open Lambda
open Clambda
open Cmm
open Cmx_format
(* Local binding of complex expressions *)
let bind name arg fn =
match arg with
Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
| Cconst_pointer _ | Cconst_natpointer _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
let bind_nonvar name arg fn =
match arg with
Cconst_int _ | Cconst_natint _ | Cconst_symbol _
| Cconst_pointer _ | Cconst_natpointer _ -> fn arg
| _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
(* Block headers. Meaning of the tag field: see stdlib/obj.ml *)
let float_tag = Cconst_int Obj.double_tag
let floatarray_tag = Cconst_int Obj.double_array_tag
let block_header tag sz =
Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10)
(Nativeint.of_int tag)
let closure_header sz = block_header Obj.closure_tag sz
let infix_header ofs = block_header Obj.infix_tag ofs
let float_header = block_header Obj.double_tag (size_float / size_addr)
let floatarray_header len =
block_header Obj.double_array_tag (len * size_float / size_addr)
let string_header len =
block_header Obj.string_tag ((len + size_addr) / size_addr)
let boxedint32_header = block_header Obj.custom_tag 2
let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
let boxedintnat_header = block_header Obj.custom_tag 2
let alloc_block_header tag sz = Cconst_natint(block_header tag sz)
let alloc_float_header = Cconst_natint(float_header)
let alloc_floatarray_header len = Cconst_natint(floatarray_header len)
let alloc_closure_header sz = Cconst_natint(closure_header sz)
let alloc_infix_header ofs = Cconst_natint(infix_header ofs)
let alloc_boxedint32_header = Cconst_natint(boxedint32_header)
let alloc_boxedint64_header = Cconst_natint(boxedint64_header)
let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header)
(* Integers *)
let max_repr_int = max_int asr 1
let min_repr_int = min_int asr 1
let int_const n =
if n <= max_repr_int && n >= min_repr_int
then Cconst_int((n lsl 1) + 1)
else Cconst_natint
(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
let add_const c n =
if n = 0 then c
else match c with
| Cconst_int x when no_overflow_add x n -> Cconst_int (x + n)
| c -> Cop(Caddi, [c; Cconst_int n])
let incr_int = function
Cconst_int n when n < max_int -> Cconst_int(n+1)
| Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1)
| c -> add_const c 1
let decr_int = function
Cconst_int n when n > min_int -> Cconst_int(n-1)
| Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1)
| c -> add_const c (-1)
let add_int c1 c2 =
match (c1, c2) with
(Cop(Caddi, [c1; Cconst_int n1]),
Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 ->
add_const (Cop(Caddi, [c1; c2])) (n1 + n2)
| (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
add_const (Cop(Caddi, [c1; c2])) n1
| (c1, Cop(Caddi, [c2; Cconst_int n2])) ->
add_const (Cop(Caddi, [c1; c2])) n2
| (Cconst_int _, _) ->
Cop(Caddi, [c2; c1])
| (_, _) ->
Cop(Caddi, [c1; c2])
let sub_int c1 c2 =
match (c1, c2) with
(Cop(Caddi, [c1; Cconst_int n1]),
Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 ->
add_const (Cop(Csubi, [c1; c2])) (n1 - n2)
| (Cop(Caddi, [c1; Cconst_int n1]), c2) ->
add_const (Cop(Csubi, [c1; c2])) n1
| (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int ->
add_const (Cop(Csubi, [c1; c2])) (-n2)
| (c1, Cconst_int n) when n <> min_int ->
add_const c1 (-n)
| (c1, c2) ->
Cop(Csubi, [c1; c2])
let mul_int c1 c2 =
match (c1, c2) with
(Cconst_int 0, _) -> c1
| (Cconst_int 1, _) -> c2
| (_, Cconst_int 0) -> c2
| (_, Cconst_int 1) -> c1
| (_, _) -> Cop(Cmuli, [c1; c2])
let tag_int = function
Cconst_int n -> int_const n
| c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
let force_tag_int = function
Cconst_int n -> int_const n
| c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1])
let untag_int = function
Cconst_int n -> Cconst_int(n asr 1)
| Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
| Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1])
when n > 0 && n < size_int * 8 ->
Cop(Casr, [c; Cconst_int (n+1)])
| Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1])
when n > 0 && n < size_int * 8 ->
Cop(Clsr, [c; Cconst_int (n+1)])
| Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1])
| c -> Cop(Casr, [c; Cconst_int 1])
let lsl_int c1 c2 =
match (c1, c2) with
(Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2)
when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 ->
Cop(Clsl, [c; Cconst_int (n1 + n2)])
| (_, _) ->
Cop(Clsl, [c1; c2])
let ignore_low_bit_int = function
Cop(Caddi, [(Cop(Clsl, [_; Cconst_int 1]) as c); Cconst_int 1]) -> c
| Cop(Cor, [c; Cconst_int 1]) -> c
| c -> c
(* Division or modulo on tagged integers. The overflow case min_int / -1
cannot occur, but we must guard against division by zero. *)
let is_different_from x = function
Cconst_int n -> n <> x
| Cconst_natint n -> n <> Nativeint.of_int x
| _ -> false
let safe_divmod op c1 c2 dbg =
if !Clflags.fast || is_different_from 0 c2 then
Cop(op, [c1; c2])
else
bind "divisor" c2 (fun c2 ->
Cifthenelse(c2,
Cop(op, [c1; c2]),
Cop(Craise dbg,
[Cconst_symbol ("caml_bucket_Division_by_zero", Cconstant_kind)])))
(* Division or modulo on boxed integers. The overflow case min_int / -1
can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
let safe_divmod_bi mkop mkm1 c1 c2 bi dbg =
bind "dividend" c1 (fun c1 ->
bind "divisor" c2 (fun c2 ->
let c3 =
if Arch.division_crashes_on_overflow
&& (size_int = 4 || bi <> Pint32)
&& not (is_different_from (-1) c2)
then
Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1)
else
mkop c1 c2 in
if !Clflags.fast || is_different_from 0 c2 then
c3
else
Cifthenelse(c2, c3,
Cop(Craise dbg,
[Cconst_symbol ("caml_bucket_Division_by_zero", Cconstant_kind)]))))
let safe_div_bi =
safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2]))
(fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
let safe_mod_bi =
safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2]))
(fun c1 -> Cconst_int 0)
(* Bool *)
let test_bool = function
Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c
| Cop(Clsl, [c; Cconst_int 1]) -> c
| c -> Cop(Ccmpi Cne, [c; Cconst_int 1])
(* Float *)
let box_float c = Cop(Calloc, [alloc_float_header; c])
let rec unbox_float = function
Cop(Calloc, [header; c]) -> c
| Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
| Cifthenelse(cond, e1, e2) ->
Cifthenelse(cond, unbox_float e1, unbox_float e2)
| Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
| Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
| Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
| Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
| c -> Cop(Cload Double_u, [c])
(* Complex *)
let box_complex c_re c_im =
Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im])
let complex_re c = Cop(Cload Double_u, [c])
let complex_im c = Cop(Cload Double_u,
[Cop(Cadda, [c; Cconst_int size_float])])
(* Unit *)
let return_unit c = Csequence(c, Cconst_pointer 1)
let rec remove_unit = function
Cconst_pointer 1 -> Ctuple []
| Csequence(c, Cconst_pointer 1) -> c
| Csequence(c1, c2) ->
Csequence(c1, remove_unit c2)
| Cifthenelse(cond, ifso, ifnot) ->
Cifthenelse(cond, remove_unit ifso, remove_unit ifnot)
| Cswitch(sel, index, cases) ->
Cswitch(sel, index, Array.map remove_unit cases)
| Ccatch(io, ids, body, handler) ->
Ccatch(io, ids, remove_unit body, remove_unit handler)
| Ctrywith(body, exn, handler) ->
Ctrywith(remove_unit body, exn, remove_unit handler)
| Clet(id, c1, c2) ->
Clet(id, c1, remove_unit c2)
| Cop(Capply (mty, dbg), args) ->
Cop(Capply (typ_void, dbg), args)
| Cop(Cextcall(proc, mty, alloc, ctx, dbg), args) ->
Cop(Cextcall(proc, typ_void, alloc, ctx, dbg), args)
| Cexit (_,_) as c -> c
| Ctuple [] as c -> c
| c -> Csequence(c, Ctuple [])
(* Access to block fields *)
let field_address ptr n =
if n = 0
then ptr
else Cop(Cadda, [ptr; Cconst_int(n * size_addr)])
let get_field ptr n =
Cop(Cload Word, [field_address ptr n])
let set_field ptr n newval =
Cop(Cstore Word, [field_address ptr n; newval])
let header ptr =
Cop(Cload Word, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
let tag_offset =
if big_endian then -1 else -size_int
let get_tag ptr =
if Proc.word_addressed then (* If byte loads are slow *)
Cop(Cand, [header ptr; Cconst_int 255])
else (* If byte loads are efficient *)
Cop(Cload Byte_unsigned,
[Cop(Cadda, [ptr; Cconst_int(tag_offset)])])
let get_size ptr =
Cop(Clsr, [header ptr; Cconst_int 10])
(* Array indexing *)
let log2_size_addr = Misc.log2 size_addr
let log2_size_float = Misc.log2 size_float
let wordsize_shift = 9
let numfloat_shift = 9 + log2_size_float - log2_size_addr
let is_addr_array_hdr hdr =
Cop(Ccmpi Cne, [Cop(Cand, [hdr; Cconst_int 255]); floatarray_tag])
let is_addr_array_ptr ptr =
Cop(Ccmpi Cne, [get_tag ptr; floatarray_tag])
let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift])
let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift])
let lsl_const c n =
Cop(Clsl, [c; Cconst_int n])
let array_indexing log2size ptr ofs =
match ofs with
Cconst_int n ->
let i = n asr 1 in
if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)])
| Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) ->
Cop(Cadda, [ptr; lsl_const c log2size])
| Cop(Caddi, [c; Cconst_int n]) ->
Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]);
Cconst_int((n-1) lsl (log2size - 1))])
| _ ->
Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]);
Cconst_int((-1) lsl (log2size - 1))])
let addr_array_ref arr ofs =
Cop(Cload Word, [array_indexing log2_size_addr arr ofs])
let unboxed_float_array_ref arr ofs =
Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
let float_array_ref arr ofs =
box_float(unboxed_float_array_ref arr ofs)
let addr_array_set arr ofs newval =
Cop(Cextcall("caml_modify_r", typ_void, false, true, Debuginfo.none),
[array_indexing log2_size_addr arr ofs; newval])
let int_array_set arr ofs newval =
Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval])
let float_array_set arr ofs newval =
Cop(Cstore Double_u, [array_indexing log2_size_float arr ofs; newval])
(* String length *)
let string_length exp =
bind "str" exp (fun str ->
let tmp_var = Ident.create "tmp" in
Clet(tmp_var,
Cop(Csubi,
[Cop(Clsl,
[Cop(Clsr, [header str; Cconst_int 10]);
Cconst_int log2_size_addr]);
Cconst_int 1]),
Cop(Csubi,
[Cvar tmp_var;
Cop(Cload Byte_unsigned,
[Cop(Cadda, [str; Cvar tmp_var])])])))
(* Message sending *)
let lookup_tag obj tag =
bind "tag" tag (fun tag ->
Cop(Cextcall("caml_get_public_method", typ_addr, false, false, Debuginfo.none),
[obj; tag]))
let lookup_label obj lab =
bind "lab" lab (fun lab ->
let table = Cop (Cload Word, [obj]) in
addr_array_ref table lab)
let call_cached_method obj tag cache pos args dbg =
let arity = List.length args in
let cache = array_indexing log2_size_addr cache pos in
Compilenv.need_send_fun arity;
Cop(Capply (typ_addr, dbg),
Cconst_symbol(("caml_send" ^ string_of_int arity), Cglobal_kind) ::
obj :: tag :: cache :: args)
(* Allocation *)
let make_alloc_generic set_fn tag wordsize args =
if wordsize <= Config.max_young_wosize then
Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args)
else begin
let id = Ident.create "alloc" in
let rec fill_fields idx = function
[] -> Cvar id
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
fill_fields (idx + 2) el) in
Clet(id,
Cop(Cextcall("caml_alloc_r", typ_addr, true, true, Debuginfo.none),
[Cconst_int wordsize; Cconst_int tag]),
fill_fields 1 args)
end
let make_alloc tag args =
make_alloc_generic addr_array_set tag (List.length args) args
let make_float_alloc tag args =
make_alloc_generic float_array_set tag
(List.length args * size_float / size_addr) args
(* Bounds checking *)
let make_checkbound dbg = function
| [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n ->
Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)])
| args ->
Cop(Ccheckbound dbg, args)
(* To compile "let rec" over values *)
let fundecls_size fundecls =
let sz = ref (-1) in
List.iter
(fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3))
fundecls;
!sz
type rhs_kind =
| RHS_block of int
| RHS_floatblock of int
| RHS_nonrec
;;
let rec expr_size = function
| Uclosure(fundecls, clos_vars) ->
RHS_block (fundecls_size fundecls + List.length clos_vars)
| Ulet(id, exp, body) ->
expr_size body
| Uletrec(bindings, body) ->
expr_size body
| Uprim(Pmakeblock(tag, mut), 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)
| Usequence(exp, exp') ->
expr_size exp'
| _ -> RHS_nonrec
(* Record application and currying functions *)
let apply_function n =
Compilenv.need_apply_fun n; "caml_apply" ^ string_of_int n
let curry_function n =
Compilenv.need_curry_fun n;
if n >= 0
then "caml_curry" ^ string_of_int n
else "caml_tuplify" ^ string_of_int (-n)
(* Comparisons *)
let transl_comparison = function
Lambda.Ceq -> Ceq
| Lambda.Cneq -> Cne
| Lambda.Cge -> Cge
| Lambda.Cgt -> Cgt
| Lambda.Cle -> Cle
| Lambda.Clt -> Clt
(* Translate structured constants *)
(* Fabrice: moved to compilenv.ml ----
let const_label = ref 0
let new_const_label () =
incr const_label;
!const_label
let new_const_symbol () =
incr const_label;
Compilenv.make_symbol (Some (string_of_int !const_label))
let structured_constants = ref ([] : (string * structured_constant) list)
*)
let transl_constant = function
Const_base(Const_int n) ->
int_const n
| Const_base(Const_char c) ->
Cconst_int(((Char.code c) lsl 1) + 1)
| Const_pointer n ->
if n <= max_repr_int && n >= min_repr_int
then Cconst_pointer((n lsl 1) + 1)
else Cconst_natpointer
(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
| cst ->
Cconst_symbol ((Compilenv.new_structured_constant cst false), Cconstant_kind)
(* Translate constant closures *)
let constant_closures =
ref ([] : (string * ufunction list) list)
(* Boxed integers *)
let box_int_constant bi n =
match bi with
Pnativeint -> Const_base(Const_nativeint n)
| Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n))
| Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n))
let operations_boxed_int bi =
match bi with
Pnativeint -> "caml_nativeint_ops"
| Pint32 -> "caml_int32_ops"
| Pint64 -> "caml_int64_ops"
let alloc_header_boxed_int bi =
match bi with
Pnativeint -> alloc_boxedintnat_header
| Pint32 -> alloc_boxedint32_header
| Pint64 -> alloc_boxedint64_header
let box_int bi arg =
match arg with
Cconst_int n ->
transl_constant (box_int_constant bi (Nativeint.of_int n))
| Cconst_natint n ->
transl_constant (box_int_constant bi n)
| _ ->
let arg' =
if bi = Pint32 && size_int = 8 && big_endian
then Cop(Clsl, [arg; Cconst_int 32])
else arg in
Cop(Calloc, [alloc_header_boxed_int bi;
Cconst_symbol((operations_boxed_int bi), Cconstant_kind);
arg'])
let rec unbox_int bi arg =
match arg with
Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
when bi = Pint32 && size_int = 8 && big_endian ->
(* Force sign-extension of low 32 bits *)
Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
| Cop(Calloc, [hdr; ops; contents])
when bi = Pint32 && size_int = 8 && not big_endian ->
(* Force sign-extension of low 32 bits *)
Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
| Cop(Calloc, [hdr; ops; contents]) ->
contents
| Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
| Cifthenelse(cond, e1, e2) ->
Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
| Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
| Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
| Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
| Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
| _ ->
Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
[Cop(Cadda, [arg; Cconst_int size_addr])])
let make_unsigned_int bi arg =
if bi = Pint32 && size_int = 8
then Cop(Cand, [arg; Cconst_natint 0xFFFFFFFFn])
else arg
(* Big arrays *)
let bigarray_elt_size = function
Pbigarray_unknown -> assert false
| Pbigarray_float32 -> 4
| Pbigarray_float64 -> 8
| Pbigarray_sint8 -> 1
| Pbigarray_uint8 -> 1
| Pbigarray_sint16 -> 2
| Pbigarray_uint16 -> 2
| Pbigarray_int32 -> 4
| Pbigarray_int64 -> 8
| Pbigarray_caml_int -> size_int
| Pbigarray_native_int -> size_int
| Pbigarray_complex32 -> 8
| Pbigarray_complex64 -> 16
let bigarray_indexing unsafe elt_kind layout b args dbg =
let check_bound a1 a2 k =
if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in
let rec ba_indexing dim_ofs delta_ofs = function
[] -> assert false
| [arg] ->
bind "idx" (untag_int arg)
(fun idx ->
check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx)
| arg1 :: argl ->
let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
bind "idx" (untag_int arg1)
(fun idx ->
bind "bound" (Cop(Cload Word, [field_address b dim_ofs]))
(fun bound ->
check_bound bound idx (add_int (mul_int rem bound) idx))) in
let offset =
match layout with
Pbigarray_unknown_layout ->
assert false
| Pbigarray_c_layout ->
ba_indexing (4 + List.length args) (-1) (List.rev args)
| Pbigarray_fortran_layout ->
ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args)
and elt_size =
bigarray_elt_size elt_kind in
let byte_offset =
if elt_size = 1
then offset
else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in
Cop(Cadda, [Cop(Cload Word, [field_address b 1]); byte_offset])
let bigarray_word_kind = function
Pbigarray_unknown -> assert false
| Pbigarray_float32 -> Single
| Pbigarray_float64 -> Double
| Pbigarray_sint8 -> Byte_signed
| Pbigarray_uint8 -> Byte_unsigned
| Pbigarray_sint16 -> Sixteen_signed
| Pbigarray_uint16 -> Sixteen_unsigned
| Pbigarray_int32 -> Thirtytwo_signed
| Pbigarray_int64 -> Word
| Pbigarray_caml_int -> Word
| Pbigarray_native_int -> Word
| Pbigarray_complex32 -> Single
| Pbigarray_complex64 -> Double
let bigarray_get unsafe elt_kind layout b args dbg =
bind "ba" b (fun b ->
match elt_kind with
Pbigarray_complex32 | Pbigarray_complex64 ->
let kind = bigarray_word_kind elt_kind in
let sz = bigarray_elt_size elt_kind / 2 in
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
box_complex
(Cop(Cload kind, [addr]))
(Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
| _ ->
Cop(Cload (bigarray_word_kind elt_kind),
[bigarray_indexing unsafe elt_kind layout b args dbg]))
let bigarray_set unsafe elt_kind layout b args newval dbg =
bind "ba" b (fun b ->
match elt_kind with
Pbigarray_complex32 | Pbigarray_complex64 ->
let kind = bigarray_word_kind elt_kind in
let sz = bigarray_elt_size elt_kind / 2 in
bind "newval" newval (fun newv ->
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
Csequence(
Cop(Cstore kind, [addr; complex_re newv]),
Cop(Cstore kind,
[Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
| _ ->
Cop(Cstore (bigarray_word_kind elt_kind),
[bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
(* Simplification of some primitives into C calls *)
(* FIXME: 2013-09: ask Fabrice: is this *only* used for reentrant primitives? I think so. --Luca Saiu *)
(* let default_prim name = *)
(* { prim_name = name ^ "_r"; *)
(* prim_arity = 0 (\*ignored*\); prim_ctx = true; *)
(* prim_alloc = true; prim_native_name = ""; prim_native_float = false } *)
(* VERY experimental: BEGIN ================================================== *)
let default_prim =
if Config.multicontext_supported then
fun name ->
{ prim_name = name ^ "_r";
prim_arity = 0 (*ignored*); prim_ctx = true;
prim_alloc = true; prim_native_name = ""; prim_native_float = false }
else
fun name ->
{ prim_name = name ;
prim_arity = 0 (*ignored*); prim_ctx = false;
prim_alloc = true; prim_native_name = ""; prim_native_float = false }
(* VERY experimental: END ================================================== *)
let simplif_primitive_32bits = function
Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
| Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
| Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
| Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
| Pcvtbint(Pnativeint, Pint64) ->
Pccall (default_prim "caml_int64_of_nativeint")
| Pcvtbint(Pint64, Pnativeint) ->
Pccall (default_prim "caml_int64_to_nativeint")
| Pnegbint Pint64 -> Pccall (default_prim "caml_int64_neg")
| Paddbint Pint64 -> Pccall (default_prim "caml_int64_add")
| Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub")
| Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul")
| Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div")
| Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod")
| Pandbint Pint64 -> Pccall (default_prim "caml_int64_and")
| Porbint Pint64 -> Pccall (default_prim "caml_int64_or")
| Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor")
| Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
| Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
| Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
| Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
| Pbintcomp(Pint64, Lambda.Cneq) -> Pccall (default_prim "caml_notequal")
| Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
| Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
| Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
| Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
| Pbigarrayref(unsafe, n, Pbigarray_int64, layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| p -> p
let simplif_primitive p =
match p with
| Pduprecord _ ->
Pccall (default_prim "caml_obj_dup")
| Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
| Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) ->
Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
| p ->
if size_int = 8 then p else simplif_primitive_32bits p
(* Build switchers both for constants and blocks *)
(* constants first *)
let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg]))
let make_switch_gen arg cases acts =
let lcases = Array.length cases in
let new_cases = Array.create lcases 0 in
let store = Switch.mk_store (=) in
for i = 0 to Array.length cases-1 do
let act = cases.(i) in
let new_act = store.Switch.act_store act in
new_cases.(i) <- new_act
done ;
Cswitch
(arg, new_cases,
Array.map
(fun n -> acts.(n))
(store.Switch.act_get ()))
(* Then for blocks *)
module SArgBlocks =
struct
type primitive = operation
let eqint = Ccmpi Ceq
let neint = Ccmpi Cne
let leint = Ccmpi Cle
let ltint = Ccmpi Clt
let geint = Ccmpi Cge
let gtint = Ccmpi Cgt
type act = expression
let default = Cexit (0,[])
let make_prim p args = Cop (p,args)
let make_offset arg n = add_const arg n
let make_isout h arg = Cop (Ccmpa Clt, [h ; arg])
let make_isin h arg = Cop (Ccmpa Cge, [h ; arg])
let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
let make_switch arg cases actions =
make_switch_gen arg cases actions
let bind arg body = bind "switcher" arg body
end
module SwitcherBlocks = Switch.Make(SArgBlocks)
(* Auxiliary functions for optimizing "let" of boxed numbers (floats and
boxed integers *)
type unboxed_number_kind =
No_unboxing
| Boxed_float
| Boxed_integer of boxed_integer
let is_unboxed_number = function
Uconst(Const_base(Const_float f), _) ->
Boxed_float
| Uprim(p, _, _) ->
begin match simplif_primitive p with
Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing
| Pfloatfield _ -> Boxed_float
| Pfloatofint -> Boxed_float
| Pnegfloat -> Boxed_float
| Pabsfloat -> Boxed_float
| Paddfloat -> Boxed_float
| Psubfloat -> Boxed_float
| Pmulfloat -> Boxed_float
| Pdivfloat -> Boxed_float
| Parrayrefu Pfloatarray -> Boxed_float
| Parrayrefs Pfloatarray -> Boxed_float
| Pbintofint bi -> Boxed_integer bi
| Pcvtbint(src, dst) -> Boxed_integer dst
| Pnegbint bi -> Boxed_integer bi
| Paddbint bi -> Boxed_integer bi
| Psubbint bi -> Boxed_integer bi
| Pmulbint bi -> Boxed_integer bi
| Pdivbint bi -> Boxed_integer bi
| Pmodbint bi -> Boxed_integer bi
| Pandbint bi -> Boxed_integer bi
| Porbint bi -> Boxed_integer bi
| Pxorbint bi -> Boxed_integer bi
| Plslbint bi -> Boxed_integer bi
| Plsrbint bi -> Boxed_integer bi
| Pasrbint bi -> Boxed_integer bi
| Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) ->
Boxed_float
| Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32
| Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64
| Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
| _ -> No_unboxing
end
| _ -> No_unboxing
let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
let need_boxed = ref false in
let assigned = ref false in
let rec subst = function
Cvar id as e ->
if Ident.same id boxed_id then need_boxed := true; e
| Clet(id, arg, body) -> Clet(id, subst arg, subst body)
| Cassign(id, arg) ->
if Ident.same id boxed_id then begin
assigned := true;
Cassign(unboxed_id, subst(unbox_fn arg))
end else
Cassign(id, subst arg)
| Ctuple argv -> Ctuple(List.map subst argv)
| Cop(Cload _, [Cvar id]) as e ->
if Ident.same id boxed_id then Cvar unboxed_id else e
| Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e ->
if Ident.same id boxed_id then Cvar unboxed_id else e
| Cop(op, argv) -> Cop(op, List.map subst argv)
| Csequence(e1, e2) -> Csequence(subst e1, subst e2)
| Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3)
| Cswitch(arg, index, cases) ->
Cswitch(subst arg, index, Array.map subst cases)
| Cloop e -> Cloop(subst e)
| Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
| Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
| Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
| e -> e in
let res = subst exp in
(res, !need_boxed, !assigned)
(* Translate an expression *)
let functions = (Queue.create() : ufunction Queue.t)
let print_ident ident =
Printf.printf " %i: %s \"%s\" \"%s\" [%s]\n" ((Obj.magic ident).(0)) (Ident.name ident) (Ident.unique_name ident) (Ident.unique_toplevel_name ident) (* (Compilenv.symbol_for_global ident) *) ""
let is_a_builtin_exception_ident ident =
List.exists
(fun (a_name, _) -> ("caml_exn_" ^ a_name) = (Ident.name ident))
Predef.builtin_idents
let rec transl = function
Uvar id ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a variable\n" ((Obj.magic id).(1)); *)
Cvar id
(* BEGIN: I have split the "Uconst (sc, Some const_label)" case according to the shape of sc --Luca Saiu REENTRANTRUNTIME *)
| Uconst ((Const_base _), Some const_label) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a Const_base (which includes strings)\n" const_label; *)
Cconst_symbol (const_label, Cconstant_kind)
| Uconst ((Const_pointer _), Some const_label) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a Const_pointer\n" const_label; *)
Cconst_symbol (const_label, Cconstant_kind)
| Uconst ((Const_block _), Some const_label) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a Const_block\n" const_label; *)
Cconst_symbol (const_label, Cconstant_kind)
| Uconst ((Const_float_array _), Some const_label) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a Const_float_array\n" const_label; *)
Cconst_symbol (const_label, Cconstant_kind)
| Uconst ((Const_immstring _), Some const_label) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "Q: %s is a Const_immstring\n" const_label; *)
Cconst_symbol (const_label, Cconstant_kind)
(* | Uconst (_, Some const_label) -> *)
(* Printf.printf "Q: %s is something else\n" const_label; *)
(* Cconst_symbol (const_label, Cglobal_kind) *)
(* END: I have split the "Uconst (sc, Some const_label)" case according to the shape of sc --Luca Saiu REENTRANTRUNTIME *) | Uconst (sc, None) ->
transl_constant sc
| Uclosure(fundecls, []) ->
let lbl = Compilenv.new_const_symbol() in
constant_closures := (lbl, fundecls) :: !constant_closures;
List.iter (fun f -> Queue.add f functions) fundecls;
Cconst_symbol (lbl, Cconstant_kind)
| Uclosure(fundecls, clos_vars) ->
let block_size =
fundecls_size fundecls + List.length clos_vars in
let rec transl_fundecls pos = function
[] ->
List.map transl clos_vars
| f :: rem ->
Queue.add f functions;
let header =
if pos = 0
then alloc_closure_header block_size
else alloc_infix_header pos in
if f.arity = 1 then
header ::
Cconst_symbol (f.label, Cconstant_kind) ::
int_const 1 ::
transl_fundecls (pos + 3) rem
else
header ::
Cconst_symbol((curry_function f.arity), Cconstant_kind) ::
int_const f.arity ::
Cconst_symbol (f.label, Cconstant_kind) ::
transl_fundecls (pos + 4) rem in
Cop(Calloc, transl_fundecls 0 fundecls)
| Uoffset(arg, offset) ->
field_address (transl arg) offset
| Udirect_apply(lbl, args, dbg) ->
Cop(Capply(typ_addr, dbg), Cconst_symbol (lbl, Cconstant_kind) :: List.map transl args)
| Ugeneric_apply(clos, [arg], dbg) ->
bind "fun" (transl clos) (fun clos ->
Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos]))
| Ugeneric_apply(clos, args, dbg) ->
let arity = List.length args in
let cargs = Cconst_symbol(apply_function arity, Cconstant_kind) ::
List.map transl (args @ [clos]) in
Cop(Capply(typ_addr, dbg), cargs)
| Usend(kind, met, obj, args, dbg) ->
let call_met obj args clos =
if args = [] then
Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos])
else
let arity = List.length args + 1 in
let cargs = Cconst_symbol(apply_function arity, Cconstant_kind) :: obj ::
(List.map transl args) @ [clos] in
Cop(Capply(typ_addr, dbg), cargs)
in
bind "obj" (transl obj) (fun obj ->
match kind, args with
Self, _ ->
bind "met" (lookup_label obj (transl met)) (call_met obj args)
| Cached, cache :: pos :: args ->
call_cached_method obj (transl met) (transl cache) (transl pos)
(List.map transl args) dbg
| _ ->
bind "met" (lookup_tag obj (transl met)) (call_met obj args))
| Ulet(id, exp, body) ->
begin match is_unboxed_number exp with
No_unboxing ->
Clet(id, transl exp, transl body)
| Boxed_float ->
transl_unbox_let box_float unbox_float transl_unbox_float
id exp body
| Boxed_integer bi ->
transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi)
id exp body
end
| Uletrec(bindings, body) ->
transl_letrec bindings (transl body)
(* Primitives *)
| Uprim(prim, args, dbg) ->
begin match (simplif_primitive prim, args) with
(* If id is a builtin exception, pre-allocated within
builtin_values [FIXME: left or right? Test], then it's a constant *)
(Pgetglobal id, []) when is_a_builtin_exception_ident id ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "AAAAAAA: This IS a builtin exception name: %s\n" (Ident.name id); *)
Cconst_symbol (Ident.name id, Cconstant_kind)
| (Pgetglobal id, []) ->
(* --Luca Saiu REENTRANTRUNTIME DEBUG *)
(* Printf.printf "AAAAAAA: This is NOT a builtin exception name: %s\n" (Ident.name id); *)
Cconst_symbol (Ident.name id, Cglobal_kind)
| (Pmakeblock(tag, mut), []) ->
transl_constant(Const_block(tag, []))
| (Pmakeblock(tag, mut), args) ->
make_alloc tag (List.map transl args)
| (Pccall prim, args) ->
if prim.prim_native_float then
box_float
(Cop(Cextcall(prim.prim_native_name, typ_float, false, false, dbg),
List.map transl_unbox_float args))
else
Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, prim.prim_ctx, dbg),
List.map transl args)
| (Pmakearray kind, []) ->
transl_constant(Const_block(0, []))
| (Pmakearray kind, args) ->