-
Notifications
You must be signed in to change notification settings - Fork 1.2k
Expand file tree
/
Copy pathtranslcore.ml
More file actions
1331 lines (1259 loc) · 50.8 KB
/
translcore.ml
File metadata and controls
1331 lines (1259 loc) · 50.8 KB
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 typed abstract syntax to lambda terms,
for the core language *)
open Misc
open Asttypes
open Primitive
open Types
open Data_types
open Typedtree
open Typeopt
open Lambda
open Debuginfo.Scoped_location
type error =
Free_super_var
| Unreachable_reached
exception Error of Location.t * error
let use_dup_for_constant_mutable_arrays_bigger_than = 4
(* Forward declaration -- to be filled in by Translmod.transl_module *)
let transl_module =
ref((fun ~scopes:_ _cc _rootpath _modl -> assert false) :
scopes:scopes -> module_coercion -> Path.t option ->
module_expr -> lambda)
let transl_struct_item =
ref ((fun ~scopes:_ _fields _rootpath _stri _next -> assert false) :
scopes:scopes -> Ident.t list -> Path.t option ->
structure_item -> (Ident.t list -> lambda) -> lambda)
let transl_object =
ref (fun ~scopes:_ _id _s _cl -> assert false :
scopes:scopes -> Ident.t -> string list -> class_expr -> lambda)
(* Compile an exception/extension definition *)
let prim_fresh_oo_id =
Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
let transl_extension_constructor ~scopes env path ext =
let path =
Printtyp.wrap_printing_env env ~error:true (fun () ->
Option.map (Out_type.rewrite_double_underscore_paths env) path)
in
let name =
match path, !Clflags.for_package with
None, _ -> Ident.name ext.ext_id
| Some p, None -> Path.name p
| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
in
let loc = of_location ~scopes ext.ext_loc in
match ext.ext_kind with
Text_decl _ ->
Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
[Lconst (Const_immstring name);
Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)],
loc)
| Text_rebind(path, _lid) ->
transl_extension_path loc env path
(* To propagate structured constants *)
exception Not_constant
let extract_constant = function
Lconst sc -> sc
| _ -> raise Not_constant
let extract_float = function
Const_float f -> f
| _ -> fatal_error "Translcore.extract_float"
(* Insertion of debugging events *)
let event_before ~scopes exp lam =
Translprim.event_before (of_location ~scopes exp.exp_loc) exp lam
let event_after ~scopes exp lam =
Translprim.event_after (of_location ~scopes exp.exp_loc) exp lam
let event_function ~scopes exp lam =
if !Clflags.debug && not !Clflags.native_code then
let repr = Some (ref 0) in
let (info, body) = lam repr in
(info,
Levent(body, {lev_loc = of_location ~scopes exp.exp_loc;
lev_kind = Lev_function;
lev_repr = repr;
lev_env = exp.exp_env}))
else
lam None
(* Assertions *)
let assert_failed loc ~scopes exp =
let slot =
transl_extension_path Loc_unknown
Env.initial Predef.path_assert_failure
in
let (fname, line, char) =
Location.get_pos_info loc.Location.loc_start
in
let loc = of_location ~scopes exp.exp_loc in
Lprim(Praise Raise_regular, [event_after ~scopes exp
(Lprim(Pmakeblock(0, Immutable, None),
[slot;
Lconst(Const_block(0,
[Const_immstring fname;
Const_int line;
Const_int char]))], loc))], loc)
(* In cases where we're careful to preserve syntactic arity, we disable
the arity fusion attempted by simplif.ml *)
let function_attribute_disallowing_arity_fusion =
{ default_function_attribute with may_fuse_arity = false }
let rec cut n l =
if n = 0 then ([],l) else
match l with [] -> failwith "Translcore.cut"
| a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)
(* [fuse_method_arity] is what ensures that a n-ary method is compiled as a
(n+1)-ary function, where the first parameter is self. It fuses together the
self and method parameters.
Input: fun self -> fun method_param_1 ... method_param_n -> body
Output: fun self method_param_1 ... method_param_n -> body
It detects whether the AST is a method by the presence of [Texp_poly] on the
inner function. This is only ever added to methods.
*)
let fuse_method_arity parent_params parent_body =
match parent_body with
| Tfunction_body
{ exp_desc = Texp_function (method_params, method_body);
exp_extra;
}
when
List.exists
(function (Texp_poly _, _, _) -> true | _ -> false)
exp_extra
-> parent_params @ method_params, method_body
| _ -> parent_params, parent_body
(* Translation of expressions *)
let rec iter_exn_names f pat =
match pat.pat_desc with
| Tpat_var (id, _, _) -> f id
| Tpat_alias (p, id, _, _, _) ->
f id;
iter_exn_names f p
| _ -> ()
let transl_ident loc env ty path desc =
match desc.val_kind with
| Val_prim p ->
Translprim.transl_primitive loc p env ty (Some path)
| Val_anc _ ->
raise(Error(to_location loc, Free_super_var))
| Val_reg | Val_self _ ->
transl_value_path loc env path
| _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
let is_omitted = function
| Arg _ -> false
| Omitted () -> true
let rec transl_exp ~scopes e =
transl_exp1 ~scopes ~in_new_scope:false e
(* ~in_new_scope tracks whether we just opened a new scope.
When we just opened a new scope, we avoid introducing an extraneous anonymous
function scope and instead inherit the new scope. E.g., [let f x = ...] is
parsed as a let-bound Pexp_function node [let f = fun x -> ...].
We give it f's scope.
*)
and transl_exp1 ~scopes ~in_new_scope e =
let eval_once =
(* Whether classes for immediate objects must be cached *)
match e.exp_desc with
Texp_function _ | Texp_for _ | Texp_while _ -> false
| _ -> true
in
if eval_once then transl_exp0 ~scopes ~in_new_scope e else
Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes ~in_new_scope) e
and transl_exp0 ~in_new_scope ~scopes e =
match e.exp_desc with
| Texp_ident(path, _, desc) ->
transl_ident (of_location ~scopes e.exp_loc)
e.exp_env e.exp_type path desc
| Texp_constant cst ->
Lambda.lambda_of_const cst
| Texp_let(rec_flag, pat_expr_list, body) ->
transl_let ~scopes rec_flag pat_expr_list
(event_before ~scopes body (transl_exp ~scopes body))
| Texp_function (params, body) ->
let scopes =
if in_new_scope then scopes
else enter_anonymous_function ~scopes
in
transl_function ~scopes e params body
| Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
exp_type = prim_type } as funct, oargs)
when List.length oargs >= p.prim_arity
&& List.for_all (fun (_, arg) -> not (is_omitted arg)) oargs ->
let argl, extra_args = cut p.prim_arity oargs in
let arg_exps =
List.map (function _, Arg x -> x | _, Omitted () -> assert false) argl
in
let args = transl_list ~scopes arg_exps in
let prim_exp = if extra_args = [] then Some e else None in
let lam =
Translprim.transl_primitive_application
(of_location ~scopes e.exp_loc) p e.exp_env prim_type path
prim_exp args arg_exps
in
if extra_args = [] then lam
else begin
let tailcall = Translattribute.get_tailcall_attribute funct in
let inlined = Translattribute.get_inlined_attribute funct in
let specialised = Translattribute.get_specialised_attribute funct in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after ~scopes e
(transl_apply ~scopes ~tailcall ~inlined ~specialised
lam extra_args (of_location ~scopes e.exp_loc))
end
| Texp_apply(funct, oargs) ->
let tailcall = Translattribute.get_tailcall_attribute funct in
let inlined = Translattribute.get_inlined_attribute funct in
let specialised = Translattribute.get_specialised_attribute funct in
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
event_after ~scopes e
(transl_apply ~scopes ~tailcall ~inlined ~specialised
(transl_exp ~scopes funct) oargs (of_location ~scopes e.exp_loc))
| Texp_match(arg, pat_expr_list, [], partial) ->
transl_match ~scopes e arg pat_expr_list partial
| Texp_match(arg, pat_expr_list, eff_pat_expr_list, partial) ->
(* need to separate the values from exceptions for transl_handler *)
let split_case (val_cases, exn_cases as acc)
({ c_lhs; c_rhs } as case) =
if c_rhs.exp_desc = Texp_unreachable then acc else
let val_pat, exn_pat = split_pattern c_lhs in
match val_pat, exn_pat with
| None, None -> assert false
| Some pv, None ->
{ case with c_lhs = pv } :: val_cases, exn_cases
| None, Some pe ->
val_cases, { case with c_lhs = pe } :: exn_cases
| Some pv, Some pe ->
{ case with c_lhs = pv } :: val_cases,
{ case with c_lhs = pe } :: exn_cases
in
let pat_expr_list, exn_pat_expr_list =
let x, y = List.fold_left split_case ([], []) pat_expr_list in
List.rev x, List.rev y
in
transl_handler ~scopes e arg (Some (pat_expr_list, partial))
exn_pat_expr_list eff_pat_expr_list
| Texp_try(body, pat_expr_list, []) ->
let id = Typecore.name_cases "exn" pat_expr_list in
Ltrywith(transl_exp ~scopes body, id,
Matching.for_trywith ~scopes e.exp_loc (Lvar id)
(transl_cases_try ~scopes pat_expr_list))
| Texp_try(body, exn_pat_expr_list, eff_pat_expr_list) ->
transl_handler ~scopes e body None exn_pat_expr_list eff_pat_expr_list
| Texp_tuple el ->
let ll, shape = transl_list_with_shape ~scopes (List.map snd el) in
begin try
Lconst(Const_block(0, List.map extract_constant ll))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable, Some shape), ll,
(of_location ~scopes e.exp_loc))
end
| Texp_construct(_, cstr, args) ->
let ll, shape = transl_list_with_shape ~scopes args in
if cstr.cstr_inlined <> None then begin match ll with
| [x] -> x
| _ -> assert false
end else begin match cstr.cstr_tag with
Cstr_constant n ->
Lconst(const_int n)
| Cstr_unboxed ->
(match ll with [v] -> v | _ -> assert false)
| Cstr_block n ->
begin try
Lconst(Const_block(n, List.map extract_constant ll))
with Not_constant ->
Lprim(Pmakeblock(n, Immutable, Some shape), ll,
of_location ~scopes e.exp_loc)
end
| Cstr_extension(path, is_const) ->
let lam = transl_extension_path
(of_location ~scopes e.exp_loc) e.exp_env path in
if is_const then lam
else
Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
lam :: ll, of_location ~scopes e.exp_loc)
end
| Texp_extension_constructor (_, path) ->
transl_extension_path (of_location ~scopes e.exp_loc) e.exp_env path
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
begin match arg with
None -> Lconst(const_int tag)
| Some arg ->
let lam = transl_exp ~scopes arg in
try
Lconst(Const_block(0, [const_int tag;
extract_constant lam]))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable, None),
[Lconst(const_int tag); lam],
of_location ~scopes e.exp_loc)
end
| Texp_record {fields; representation; extended_expression} ->
transl_record ~scopes e.exp_loc e.exp_env
fields representation extended_expression
| Texp_atomic_loc (arg, _, lbl) ->
let shape = Some [Typeopt.value_kind arg.exp_env arg.exp_type; Pintval] in
let (arg, lbl) = transl_atomic_loc ~scopes arg lbl in
let loc = of_location ~scopes e.exp_loc in
Lprim (Pmakeblock (0, Immutable, shape), [arg; lbl], loc)
| Texp_field (arg, _, ({ lbl_atomic = Atomic; _ } as lbl)) ->
let arg, lbl = transl_atomic_loc ~scopes arg lbl in
let loc = of_location ~scopes e.exp_loc in
Lprim (Patomic_load, [arg; lbl], loc)
| Texp_field (arg, _, lbl) ->
let targ = transl_exp ~scopes arg in
begin match lbl.lbl_repres with
Record_regular | Record_inlined _ ->
Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, lbl.lbl_mut), [targ],
of_location ~scopes e.exp_loc)
| Record_unboxed _ -> targ
| Record_float ->
Lprim (Pfloatfield lbl.lbl_pos, [targ],
of_location ~scopes e.exp_loc)
| Record_extension _ ->
Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, lbl.lbl_mut), [targ],
of_location ~scopes e.exp_loc)
end
| Texp_setfield (arg, _, ({ lbl_atomic = Atomic; _ } as lbl), newval) ->
let prim =
Primitive.simple
~name:"caml_atomic_exchange_field" ~arity:3 ~alloc:false
in
let arg, lbl = transl_atomic_loc ~scopes arg lbl in
let newval = transl_exp ~scopes newval in
let loc = of_location ~scopes e.exp_loc in
Lprim (
Pignore,
[Lprim (Pccall prim, [arg; lbl; newval], loc)],
loc
)
| Texp_setfield(arg, _, lbl, newval) ->
let access =
match lbl.lbl_repres with
Record_regular
| Record_inlined _ ->
Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
| Record_unboxed _ -> assert false
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
| Record_extension _ ->
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
in
Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval],
of_location ~scopes e.exp_loc)
| Texp_array (amut, expr_list) ->
let kind = array_kind e in
let ll = transl_list ~scopes expr_list in
let loc = of_location ~scopes e.exp_loc in
let makearray mutability =
Lprim (Pmakearray (kind, mutability), ll, loc)
in
let duparray_to_mutable array =
Lprim (Pduparray (kind, Mutable), [array], loc)
in
let imm_array = makearray Immutable in
begin try
(* For native code the decision as to which compilation strategy to
use is made later. This enables the Flambda passes to lift certain
kinds of array definitions to symbols. *)
(* Deactivate constant optimization if array is small enough *)
if amut = Asttypes.Mutable &&
List.length ll <= use_dup_for_constant_mutable_arrays_bigger_than
then begin
raise Not_constant
end;
begin match List.map extract_constant ll with
| exception Not_constant
when kind = Pfloatarray && amut = Asttypes.Mutable ->
(* We cannot currently lift mutable [Pintarray] arrays safely in
Flambda because [caml_modify] might be called upon them
(e.g. from code operating on polymorphic arrays, or functions
such as [caml_array_blit].
To avoid having different Lambda code for bytecode/Closure
vs. Flambda, we always generate [Pduparray] for mutable arrays
here, and deal with it in [Bytegen] (or in the case of Closure,
in [Cmmgen], which already has to handle [Pduparray Pmakearray
Pfloatarray] in the case where the array turned out to be
inconstant).
When not [Pfloatarray], the exception propagates to the handler
below. *)
duparray_to_mutable imm_array
| cl ->
let const =
match kind with
| Paddrarray | Pintarray ->
Lconst(Const_block(0, cl))
| Pfloatarray ->
Lconst(Const_float_array(List.map extract_float cl))
| Pgenarray ->
raise Not_constant (* can this really happen? *)
in
match amut with
| Mutable -> duparray_to_mutable const
| Immutable -> const
end
with Not_constant ->
makearray amut
end
| Texp_ifthenelse(cond, ifso, Some ifnot) ->
Lifthenelse(transl_exp ~scopes cond,
event_before ~scopes ifso (transl_exp ~scopes ifso),
event_before ~scopes ifnot (transl_exp ~scopes ifnot))
| Texp_ifthenelse(cond, ifso, None) ->
Lifthenelse(transl_exp ~scopes cond,
event_before ~scopes ifso (transl_exp ~scopes ifso),
lambda_unit)
| Texp_sequence(expr1, expr2) ->
Lsequence(transl_exp ~scopes expr1,
event_before ~scopes expr2 (transl_exp ~scopes expr2))
| Texp_while(cond, body) ->
Lwhile(transl_exp ~scopes cond,
event_before ~scopes body (transl_exp ~scopes body))
| Texp_for(param, _, low, high, dir, body) ->
Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,
event_before ~scopes body (transl_exp ~scopes body))
| Texp_send(expr, met) ->
let lam =
let loc = of_location ~scopes e.exp_loc in
match met with
| Tmeth_val id ->
let obj = transl_exp ~scopes expr in
Lsend (Self, Lvar id, obj, [], loc)
| Tmeth_name nm ->
let obj = transl_exp ~scopes expr in
let (tag, cache) = Translobj.meth obj nm in
let kind = if cache = [] then Public else Cached in
Lsend (kind, tag, obj, cache, loc)
| Tmeth_ancestor(meth, path_self) ->
let self = transl_value_path loc e.exp_env path_self in
Lapply {ap_loc = loc;
ap_func = Lvar meth;
ap_args = [self];
ap_tailcall = Default_tailcall;
ap_inlined = Default_inline;
ap_specialised = Default_specialise}
in
event_after ~scopes e lam
| Texp_new (cl, {Location.loc=loc}, _) ->
let loc = of_location ~scopes loc in
Lapply{
ap_loc=loc;
ap_func=
Lprim(Pfield (0, Pointer, Mutable),
[transl_class_path loc e.exp_env cl], loc);
ap_args=[lambda_unit];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
}
| Texp_instvar(path_self, path, _) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
let var = transl_value_path loc e.exp_env path in
Lprim(Pfield_computed, [self; var], loc)
| Texp_setinstvar(path_self, path, _, expr) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
let var = transl_value_path loc e.exp_env path in
transl_setinstvar ~scopes loc self var expr
| Texp_override(path_self, modifs) ->
let loc = of_location ~scopes e.exp_loc in
let self = transl_value_path loc e.exp_env path_self in
let cpy = Ident.create_local "copy" in
Llet(Strict, Pgenval, cpy,
Lapply{
ap_loc=Loc_unknown;
ap_func=Translobj.oo_prim "copy";
ap_args=[self];
ap_tailcall=Default_tailcall;
ap_inlined=Default_inline;
ap_specialised=Default_specialise;
},
List.fold_right
(fun (id, _, expr) rem ->
Lsequence(transl_setinstvar ~scopes Loc_unknown
(Lvar cpy) (Lvar id) expr, rem))
modifs
(Lvar cpy))
| Texp_pack modl ->
!transl_module ~scopes Tcoerce_none None modl
| Texp_assert ({exp_desc=Texp_construct(_, {cstr_name="false"}, _)}, loc) ->
assert_failed loc ~scopes e
| Texp_assert (cond, loc) ->
if !Clflags.noassert
then lambda_unit
else Lifthenelse (transl_exp ~scopes cond, lambda_unit,
assert_failed loc ~scopes e)
| Texp_lazy e ->
begin match Typeopt.classify_lazy_argument e with
| Eager Shortcut ->
transl_exp ~scopes e
| Eager Forward ->
Lprim (Pmakelazyblock Forward_tag,
[transl_exp ~scopes e],
of_location ~scopes e.exp_loc)
| Lazy_thunk ->
let fn = lfunction ~kind:Curried
~params:[Ident.create_local "param", Pgenval]
~return:Pgenval
(* The translation of [e] may be a function, in
which case disallowing arity fusion gives a very
small performance improvement.
*)
~attr:function_attribute_disallowing_arity_fusion
~loc:(of_location ~scopes e.exp_loc)
~body:(transl_exp ~scopes e) in
Lprim(Pmakelazyblock Lazy_tag, [fn],
of_location ~scopes e.exp_loc)
end
| Texp_object (cs, meths) ->
let cty = cs.cstr_type in
let cl = Ident.create_local "object" in
!transl_object ~scopes cl meths
{ cl_desc = Tcl_structure cs;
cl_loc = e.exp_loc;
cl_type = Cty_signature cty;
cl_env = e.exp_env;
cl_attributes = [];
}
| Texp_letop{let_; ands; param; body; partial} ->
event_after ~scopes e
(transl_letop ~scopes e.exp_loc e.exp_env let_ ands param body partial)
| Texp_unreachable ->
raise (Error (e.exp_loc, Unreachable_reached))
| Texp_struct_item (si, e) ->
!transl_struct_item ~scopes [] None si (fun _ -> transl_exp ~scopes e)
and pure_module m =
match m.mod_desc with
Tmod_ident _ -> Alias
| Tmod_constraint (m,_,_,_) -> pure_module m
| _ -> Strict
and transl_list ~scopes expr_list =
List.map (transl_exp ~scopes) expr_list
and transl_list_with_shape ~scopes expr_list =
let transl_with_shape e =
let shape = Typeopt.value_kind e.exp_env e.exp_type in
transl_exp ~scopes e, shape
in
List.split (List.map transl_with_shape expr_list)
and transl_guard ~scopes guard rhs =
let expr = event_before ~scopes rhs (transl_exp ~scopes rhs) in
match guard with
| None -> expr
| Some cond ->
event_before ~scopes cond
(Lifthenelse(transl_exp ~scopes cond, expr, staticfail))
and transl_cont cont c_cont body =
match cont, c_cont with
| Some id1, Some id2 -> Llet(Alias, Pgenval, id2, Lvar id1, body)
| None, None
| Some _, None -> body
| None, Some _ -> assert false
and transl_case ~scopes ?cont {c_lhs; c_cont; c_guard; c_rhs} =
(c_lhs, transl_cont cont c_cont (transl_guard ~scopes c_guard c_rhs))
and transl_cases ~scopes ?cont cases =
let cases =
List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
List.map (transl_case ~scopes ?cont) cases
and transl_case_try ~scopes {c_lhs; c_guard; c_rhs} =
iter_exn_names Translprim.add_exception_ident c_lhs;
Misc.try_finally
(fun () -> c_lhs, transl_guard ~scopes c_guard c_rhs)
~always:(fun () ->
iter_exn_names Translprim.remove_exception_ident c_lhs)
and transl_cases_try ~scopes cases =
let cases =
List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
List.map (transl_case_try ~scopes) cases
and transl_tupled_cases ~scopes patl_expr_list =
let patl_expr_list =
List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)
patl_expr_list in
List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr))
patl_expr_list
and transl_apply ~scopes
?(tailcall=Default_tailcall)
?(inlined = Default_inline)
?(specialised = Default_specialise)
lam sargs loc
=
let lapply funct args =
match funct with
Lsend(k, lmet, lobj, largs, _) ->
Lsend(k, lmet, lobj, largs @ args, loc)
| Levent(Lsend(k, lmet, lobj, largs, _), _) ->
Lsend(k, lmet, lobj, largs @ args, loc)
| Lapply ap ->
Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
| lexp ->
Lapply {
ap_loc=loc;
ap_func=lexp;
ap_args=args;
ap_tailcall=tailcall;
ap_inlined=inlined;
ap_specialised=specialised;
}
in
(* Build a function application.
Particular care is required for out-of-order partial applications.
The following code guarantees that:
* arguments are evaluated right-to-left according to their order in
the type of the function, before the function is called;
* side-effects occurring after receiving a non-optional parameter
will occur exactly when all the arguments up to this parameter
have been received;
* side-effects occurring after receiving an optional parameter
will occur at the latest when all the arguments up to the first
non-optional parameter that follows it have been received.
*)
let rec build_apply lam args = function
(Omitted (), optional) :: l ->
(* Out-of-order partial application; we will need to build a closure *)
let defs = ref [] in
let protect name lam =
match lam with
Lvar _ | Lconst _ -> lam
| _ ->
let id = Ident.create_local name in
defs := (id, lam) :: !defs;
Lvar id
in
(* If all arguments in [args] were optional, delay their application
until after this one is received *)
let args, args' =
if List.for_all (fun (_,opt) -> opt) args then [], args
else args, []
in
let lam =
if args = [] then lam else lapply lam (List.rev_map fst args)
in
(* Evaluate the function, applied to the arguments in [args] *)
let handle = protect "func" lam in
(* Evaluate the arguments whose applications was delayed;
if we already passed here this is a no-op. *)
let args' =
List.map (fun (arg, opt) -> protect "arg" arg, opt) args'
in
(* Evaluate the remaining arguments;
if we already passed here this is a no-op. *)
let l =
List.map
(fun (arg, opt) -> Typedtree.map_apply_arg (protect "arg") arg, opt)
l
in
let id_arg = Ident.create_local "param" in
(* Process remaining arguments and build closure *)
let body =
match build_apply handle ((Lvar id_arg, optional)::args') l with
Lfunction{kind = Curried; params = ids; return; body; attr; loc}
when List.length ids < Lambda.max_arity () ->
lfunction ~kind:Curried ~params:((id_arg, Pgenval)::ids)
~return ~body ~attr ~loc
| body ->
lfunction ~kind:Curried ~params:[id_arg, Pgenval]
~return:Pgenval ~body
~attr:default_stub_attribute ~loc
in
(* Wrap "protected" definitions, starting from the left,
so that evaluation is right-to-left. *)
List.fold_right
(fun (id, lam) body -> Llet(Strict, Pgenval, id, lam, body))
!defs body
| (Arg arg, optional) :: l ->
build_apply lam ((arg, optional) :: args) l
| [] ->
lapply lam (List.rev_map fst args)
in
let transl_arg arg = Typedtree.map_apply_arg (transl_exp ~scopes) arg in
(build_apply lam [] (List.map (fun (l, arg) ->
transl_arg arg,
Btype.is_optional l)
sargs)
: Lambda.lambda)
(* There are two cases in function translation:
- [Tupled]. It takes a tupled argument, and we can flatten it.
- [Curried]. It takes each argument individually.
We first try treating the function as taking a flattened tupled argument (in
[trans_tupled_function]) and, if that doesn't work, we fall back to treating
the function as taking each argument individually (in
[trans_curried_function]).
*)
and transl_function_without_attributes ~scopes loc repr params body =
let return =
match body with
| Tfunction_body body ->
value_kind body.exp_env body.exp_type
| Tfunction_cases { cases = { c_rhs } :: _ } ->
value_kind c_rhs.exp_env c_rhs.exp_type
| Tfunction_cases { cases = [] } ->
(* With Camlp4/ppx, a pattern matching might be empty *)
Pgenval
in
transl_tupled_function ~scopes loc return repr params body
and transl_tupled_function ~scopes loc return repr params body =
(* Cases are eligible for flattening if they belong to the only param. *)
let eligible_cases =
match params, body with
| [], Tfunction_cases { cases; partial } ->
Some (cases, partial)
| [ { fp_kind = Tparam_pat pat; fp_partial } ], Tfunction_body body ->
let case =
{ c_lhs = pat; c_cont = None; c_guard = None; c_rhs = body }
in
Some ([ case ], fp_partial)
| _ -> None
in
match eligible_cases with
| Some (({ c_lhs = { pat_desc = Tpat_tuple pl } } :: _) as cases, partial)
when !Clflags.native_code
&& List.length pl <= (Lambda.max_arity ()) ->
begin try
let size = List.length pl in
let pats_expr_list =
List.map
(fun {c_lhs; c_guard; c_rhs} ->
(Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
cases in
let kinds =
(* All the patterns might not share the same types. We must take the
union of the patterns types *)
match pats_expr_list with
| [] -> assert false
| (pats, _, _) :: cases ->
let first_case_kinds =
List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats
in
List.fold_left
(fun kinds (pats, _, _) ->
List.map2 (fun kind pat ->
value_kind_union kind
(value_kind pat.pat_env pat.pat_type))
kinds pats)
first_case_kinds cases
in
let tparams =
List.map (fun kind -> Ident.create_local "param", kind) kinds
in
let params = List.map fst tparams in
((Tupled, tparams, return),
Matching.for_tupled_function ~scopes loc params
(transl_tupled_cases ~scopes pats_expr_list) partial)
with Matching.Cannot_flatten ->
transl_curried_function ~scopes loc return repr params body
end
| _ -> transl_curried_function ~scopes loc return repr params body
and transl_curried_function ~scopes loc return repr params body =
let cases_param, body =
match body with
| Tfunction_body body ->
None, event_before ~scopes body (transl_exp ~scopes body)
| Tfunction_cases { cases; partial; param; loc = cases_loc } ->
let kind =
match cases with
| [] ->
(* With Camlp4/ppx, a pattern matching might be empty *)
Pgenval
| {c_lhs=pat} :: other_cases ->
(* All the patterns might not share the same types. We must take the
union of the patterns types *)
List.fold_left (fun k {c_lhs=pat} ->
Typeopt.value_kind_union k
(value_kind pat.pat_env pat.pat_type))
(value_kind pat.pat_env pat.pat_type) other_cases
in
let body =
Matching.for_function ~scopes cases_loc repr (Lvar param)
(transl_cases ~scopes cases) partial
in
Some (param, kind), body
in
let body, params =
List.fold_right (fun fp (body, params) ->
let param = fp.fp_param in
let param_loc = fp.fp_loc in
match fp.fp_kind with
| Tparam_pat pat ->
let kind = value_kind pat.pat_env pat.pat_type in
let body =
Matching.for_function ~scopes param_loc None (Lvar param)
[ pat, body ]
fp.fp_partial
in
body, (param, kind) :: params
| Tparam_optional_default (pat, default_arg) ->
let default_arg =
event_before ~scopes default_arg (transl_exp ~scopes default_arg)
in
let body =
Matching.for_optional_arg_default
~scopes param_loc pat body ~default_arg ~param
in
(* The optional param is Pgenval as it's an option. *)
body, (param, Pgenval) :: params)
params
(body, Option.to_list cases_param)
in
(* chunk params according to Lambda.max_arity. If Lambda.max_arity = n and
N>n, then the translation of an N-ary typedtree function is an n-ary lambda
function returning the translation of an (N-n)-ary typedtree function.
*)
let params, return, body =
match Misc.Stdlib.List.chunks_of (Lambda.max_arity ()) params with
| [] ->
Misc.fatal_error "attempted to translate a function with zero arguments"
| first_chunk :: rest_of_chunks ->
let body, return =
List.fold_right
(fun chunk (body, return) ->
let attr = function_attribute_disallowing_arity_fusion in
let loc = of_location ~scopes loc in
let body =
lfunction ~kind:Curried ~params:chunk ~return ~body ~attr ~loc
in
(* we return Pgenval (for a function) after the rightmost chunk. *)
body, Pgenval)
rest_of_chunks
(body, return)
in
first_chunk, return, body
in
((Curried, params, return), body)
and transl_function ~scopes e params body =
let ((kind, params, return), body) =
event_function ~scopes e
(function repr ->
let params, body = fuse_method_arity params body in
transl_function_without_attributes ~scopes e.exp_loc repr params body)
in
let attr = function_attribute_disallowing_arity_fusion in
let loc = of_location ~scopes e.exp_loc in
let lam = lfunction ~kind ~params ~return ~body ~attr ~loc in
let attrs =
(* Collect attributes from the Pexp_newtype node for locally abstract types.
Otherwise we'd ignore the attribute in, e.g.:
fun [@inline] (type a) x -> ...
*)
List.fold_left
(fun attrs (extra_exp, _, extra_attrs) ->
match extra_exp with
| Texp_newtype _ -> extra_attrs @ attrs
| (Texp_constraint _ | Texp_coerce _ | Texp_poly _) -> attrs)
e.exp_attributes e.exp_extra
in
Translattribute.add_function_attributes lam e.exp_loc attrs
(* Like transl_exp, but used when a new scope was just introduced. *)
and transl_scoped_exp ~scopes expr =
transl_exp1 ~scopes ~in_new_scope:true expr
(* Decides whether a pattern binding should introduce a new scope. *)
and transl_bound_exp ~scopes ~in_structure pat expr =
let should_introduce_scope =
match expr.exp_desc with
| Texp_function _ -> true
| _ when in_structure -> true
| _ -> false in
match pat_bound_idents pat with
| (id :: _) when should_introduce_scope ->
transl_scoped_exp ~scopes:(enter_value_definition ~scopes id) expr
| _ -> transl_exp ~scopes expr
(*
Notice: transl_let consumes (ie compiles) its pat_expr_list argument,
and returns a function that will take the body of the lambda-let construct.
This complication allows choosing any compilation order for the
bindings and body of let constructs.
*)
and transl_let ~scopes ?(in_structure=false) rec_flag pat_expr_list =
match rec_flag with
Nonrecursive ->
let rec transl = function
[] ->
fun body -> body
| {vb_pat=pat; vb_expr=expr; vb_rec_kind=_; vb_attributes=attr; vb_loc}
:: rem ->
let lam = transl_bound_exp ~scopes ~in_structure pat expr in
let lam = Translattribute.add_function_attributes lam vb_loc attr in
let mk_body = transl rem in
fun body ->
Matching.for_let ~scopes pat.pat_loc lam pat (mk_body body)
in transl pat_expr_list
| Recursive ->
let idlist =
List.map
(fun {vb_pat=pat} -> match pat.pat_desc with
Tpat_var (id,_,_) -> id
| _ -> assert false)
pat_expr_list in
let transl_case {vb_expr=expr; vb_attributes; vb_rec_kind = rkind;
vb_loc; vb_pat} id =
let def = transl_bound_exp ~scopes ~in_structure vb_pat expr in
let def =
Translattribute.add_function_attributes def vb_loc vb_attributes
in
( id, rkind, def ) in
let lam_bds = List.map2 transl_case pat_expr_list idlist in
fun body -> Value_rec_compiler.compile_letrec lam_bds body
and transl_setinstvar ~scopes loc self var expr =
Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
[self; var; transl_exp ~scopes expr], loc)
and transl_record ~scopes loc env fields repres opt_init_expr =
let size = Array.length fields in
(* Determine if there are "enough" fields (only relevant if this is a
functional-style record update *)
let no_init = match opt_init_expr with None -> true | _ -> false in
if no_init || size < Config.max_young_wosize
then begin
(* Allocate new record with given fields (and remaining fields
taken from init_expr if any *)
let init_id = Ident.create_local "init" in
let lv =
Array.mapi
(fun i (_, definition) ->
match definition with
| Kept (typ, mut) ->
let field_kind = value_kind env typ in
let access =
match repres with
Record_regular | Record_inlined _ ->
Pfield (i, maybe_pointer_type env typ, mut)
| Record_unboxed _ -> assert false
| Record_extension _ ->
Pfield (i + 1, maybe_pointer_type env typ, mut)
| Record_float -> Pfloatfield i in
Lprim(access, [Lvar init_id],
of_location ~scopes loc),
field_kind
| Overridden (_lid, expr) ->
let field_kind = value_kind expr.exp_env expr.exp_type in
transl_exp ~scopes expr, field_kind)
fields
in
let ll, shape = List.split (Array.to_list lv) in
let mut =
if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
then Mutable
else Immutable in
let lam =
try