Skip to content

Commit 86526aa

Browse files
stedolanstedolan
authored
flambda-backend: Middle-end support for local allocs (#491)
1 parent 969b937 commit 86526aa

26 files changed

+1256
-822
lines changed

‎asmcomp/cmm_helpers.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -1356,7 +1356,7 @@ let default_prim name =
13561356

13571357

13581358
let int64_native_prim name arity ~alloc =
1359-
let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
1359+
let u64 = Primitive.(Prim_global, Unboxed_integer Pint64) in
13601360
let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
13611361
let effects = Primitive.Arbitrary_effects in
13621362
let coeffects = Primitive.Has_coeffects in

‎asmcomp/cmmgen.ml

+9-9
Original file line numberDiff line numberDiff line change
@@ -747,18 +747,18 @@ and transl_make_array dbg env kind args =
747747
and transl_ccall env prim args dbg =
748748
let transl_arg native_repr arg =
749749
match native_repr with
750-
| Same_as_ocaml_repr ->
750+
| _, Same_as_ocaml_repr ->
751751
(XInt, transl env arg)
752-
| Unboxed_float ->
752+
| _, Unboxed_float ->
753753
(XFloat, transl_unbox_float dbg env arg)
754-
| Unboxed_integer bi ->
754+
| _, Unboxed_integer bi ->
755755
let xty =
756756
match bi with
757757
| Pnativeint -> XInt
758758
| Pint32 -> XInt32
759759
| Pint64 -> XInt64 in
760760
(xty, transl_unbox_int dbg env bi arg)
761-
| Untagged_int ->
761+
| _, Untagged_int ->
762762
(XInt, untag_int (transl env arg) dbg)
763763
in
764764
let rec transl_args native_repr_args args =
@@ -776,12 +776,12 @@ and transl_ccall env prim args dbg =
776776
in
777777
let typ_res, wrap_result =
778778
match prim.prim_native_repr_res with
779-
| Same_as_ocaml_repr -> (typ_val, fun x -> x)
780-
| Unboxed_float -> (typ_float, box_float dbg)
781-
| Unboxed_integer Pint64 when size_int = 4 ->
779+
| _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
780+
| _, Unboxed_float -> (typ_float, box_float dbg)
781+
| _, Unboxed_integer Pint64 when size_int = 4 ->
782782
([|Int; Int|], box_int dbg Pint64)
783-
| Unboxed_integer bi -> (typ_int, box_int dbg bi)
784-
| Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
783+
| _, Unboxed_integer bi -> (typ_int, box_int dbg bi)
784+
| _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
785785
in
786786
let typ_args, args = transl_args prim.prim_native_repr_args args in
787787
wrap_result

‎boot/ocamlc

52.9 KB
Binary file not shown.

‎boot/ocamllex

0 Bytes
Binary file not shown.

‎bytecomp/bytegen.ml

+48-42
Original file line numberDiff line numberDiff line change
@@ -109,7 +109,7 @@ let rec is_tailcall = function
109109
from the tail call optimization? *)
110110

111111
let preserve_tailcall_for_prim = function
112-
Pidentity | Popaque | Pdirapply | Prevapply | Psequor | Psequand ->
112+
Pidentity | Popaque | Pdirapply _ | Prevapply _ | Psequor | Psequand ->
113113
true
114114
| Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
115115
| Pmakeblock _ | Pmakefloatblock _
@@ -118,8 +118,8 @@ let preserve_tailcall_for_prim = function
118118
| Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
119119
| Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
120120
| Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
121-
| Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat
122-
| Pdivfloat | Pfloatcomp _ | Pstringlength | Pstringrefu | Pstringrefs
121+
| Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
122+
| Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu | Pstringrefs
123123
| Pcompare_ints | Pcompare_floats | Pcompare_bints _
124124
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
125125
| Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
@@ -209,12 +209,12 @@ let rec size_of_lambda env = function
209209
in
210210
size_of_lambda env body
211211
| Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
212-
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
212+
| Lprim (Pmakearray ((Paddrarray|Pintarray), _, _), args, _) ->
213213
RHS_block (List.length args)
214-
| Lprim (Pmakearray (Pfloatarray, _), args, _)
214+
| Lprim (Pmakearray (Pfloatarray, _, _), args, _)
215215
| Lprim (Pmakefloatblock _, args, _) ->
216216
RHS_floatblock (List.length args)
217-
| Lprim (Pmakearray (Pgenarray, _), _, _) ->
217+
| Lprim (Pmakearray (Pgenarray, _, _), _, _) ->
218218
(* Pgenarray is excluded from recursive bindings by the
219219
check in Translcore.check_recursive_lambda *)
220220
RHS_nonrec
@@ -227,6 +227,7 @@ let rec size_of_lambda env = function
227227
| Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
228228
| Levent (lam, _) -> size_of_lambda env lam
229229
| Lsequence (_lam, lam') -> size_of_lambda env lam'
230+
| Lregion lam -> size_of_lambda env lam
230231
| _ -> RHS_nonrec
231232

232233
(**** Merging consecutive events ****)
@@ -398,7 +399,7 @@ let comp_primitive p args =
398399
| Pfield_computed _sem -> Kgetvectitem
399400
| Psetfield(n, _ptr, _init) -> Ksetfield n
400401
| Psetfield_computed(_ptr, _init) -> Ksetvectitem
401-
| Pfloatfield (n, _sem) -> Kgetfloatfield n
402+
| Pfloatfield (n, _sem, _mode) -> Kgetfloatfield n
402403
| Psetfloatfield (n, _init) -> Ksetfloatfield n
403404
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
404405
| Pccall p -> Kccall(p.prim_name, p.prim_arity)
@@ -417,13 +418,13 @@ let comp_primitive p args =
417418
| Poffsetint n -> Koffsetint n
418419
| Poffsetref n -> Koffsetref n
419420
| Pintoffloat -> Kccall("caml_int_of_float", 1)
420-
| Pfloatofint -> Kccall("caml_float_of_int", 1)
421-
| Pnegfloat -> Kccall("caml_neg_float", 1)
422-
| Pabsfloat -> Kccall("caml_abs_float", 1)
423-
| Paddfloat -> Kccall("caml_add_float", 2)
424-
| Psubfloat -> Kccall("caml_sub_float", 2)
425-
| Pmulfloat -> Kccall("caml_mul_float", 2)
426-
| Pdivfloat -> Kccall("caml_div_float", 2)
421+
| Pfloatofint _ -> Kccall("caml_float_of_int", 1)
422+
| Pnegfloat _ -> Kccall("caml_neg_float", 1)
423+
| Pabsfloat _ -> Kccall("caml_abs_float", 1)
424+
| Paddfloat _ -> Kccall("caml_add_float", 2)
425+
| Psubfloat _ -> Kccall("caml_sub_float", 2)
426+
| Pmulfloat _ -> Kccall("caml_mul_float", 2)
427+
| Pdivfloat _ -> Kccall("caml_div_float", 2)
427428
| Pstringlength -> Kccall("caml_ml_string_length", 1)
428429
| Pbyteslength -> Kccall("caml_ml_bytes_length", 1)
429430
| Pstringrefs -> Kccall("caml_string_get", 2)
@@ -467,26 +468,26 @@ let comp_primitive p args =
467468
Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
468469
| Pisint -> Kisint
469470
| Pisout -> Kisout
470-
| Pbintofint bi -> comp_bint_primitive bi "of_int" args
471+
| Pbintofint (bi,_) -> comp_bint_primitive bi "of_int" args
471472
| Pintofbint bi -> comp_bint_primitive bi "to_int" args
472-
| Pcvtbint(Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1)
473-
| Pcvtbint(Pnativeint, Pint32) -> Kccall("caml_nativeint_to_int32", 1)
474-
| Pcvtbint(Pint32, Pint64) -> Kccall("caml_int64_of_int32", 1)
475-
| Pcvtbint(Pint64, Pint32) -> Kccall("caml_int64_to_int32", 1)
476-
| Pcvtbint(Pnativeint, Pint64) -> Kccall("caml_int64_of_nativeint", 1)
477-
| Pcvtbint(Pint64, Pnativeint) -> Kccall("caml_int64_to_nativeint", 1)
478-
| Pnegbint bi -> comp_bint_primitive bi "neg" args
479-
| Paddbint bi -> comp_bint_primitive bi "add" args
480-
| Psubbint bi -> comp_bint_primitive bi "sub" args
481-
| Pmulbint bi -> comp_bint_primitive bi "mul" args
473+
| Pcvtbint(Pint32, Pnativeint, _) -> Kccall("caml_nativeint_of_int32", 1)
474+
| Pcvtbint(Pnativeint, Pint32, _) -> Kccall("caml_nativeint_to_int32", 1)
475+
| Pcvtbint(Pint32, Pint64, _) -> Kccall("caml_int64_of_int32", 1)
476+
| Pcvtbint(Pint64, Pint32, _) -> Kccall("caml_int64_to_int32", 1)
477+
| Pcvtbint(Pnativeint, Pint64, _) -> Kccall("caml_int64_of_nativeint", 1)
478+
| Pcvtbint(Pint64, Pnativeint, _) -> Kccall("caml_int64_to_nativeint", 1)
479+
| Pnegbint(bi,_) -> comp_bint_primitive bi "neg" args
480+
| Paddbint(bi,_) -> comp_bint_primitive bi "add" args
481+
| Psubbint(bi,_) -> comp_bint_primitive bi "sub" args
482+
| Pmulbint(bi,_) -> comp_bint_primitive bi "mul" args
482483
| Pdivbint { size = bi } -> comp_bint_primitive bi "div" args
483484
| Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args
484-
| Pandbint bi -> comp_bint_primitive bi "and" args
485-
| Porbint bi -> comp_bint_primitive bi "or" args
486-
| Pxorbint bi -> comp_bint_primitive bi "xor" args
487-
| Plslbint bi -> comp_bint_primitive bi "shift_left" args
488-
| Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
489-
| Pasrbint bi -> comp_bint_primitive bi "shift_right" args
485+
| Pandbint(bi,_) -> comp_bint_primitive bi "and" args
486+
| Porbint(bi,_) -> comp_bint_primitive bi "or" args
487+
| Pxorbint(bi,_) -> comp_bint_primitive bi "xor" args
488+
| Plslbint(bi,_) -> comp_bint_primitive bi "shift_left" args
489+
| Plsrbint(bi,_) -> comp_bint_primitive bi "shift_right_unsigned" args
490+
| Pasrbint(bi,_) -> comp_bint_primitive bi "shift_right" args
490491
| Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
491492
| Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2)
492493
| Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
@@ -503,7 +504,7 @@ let comp_primitive p args =
503504
| Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
504505
| Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
505506
| Pbswap16 -> Kccall("caml_bswap16", 1)
506-
| Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
507+
| Pbbswap(bi,_) -> comp_bint_primitive bi "bswap" args
507508
| Pint_as_pointer -> Kccall("caml_int_as_pointer", 1)
508509
| Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
509510
| Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
@@ -563,7 +564,7 @@ let rec comp_expr env exp sz cont =
563564
(Kapply nargs :: cont1))
564565
end
565566
end
566-
| Lsend(kind, met, obj, args, _) ->
567+
| Lsend(kind, met, obj, args, _, _, _) ->
567568
let args = if kind = Cached then List.tl args else args in
568569
let nargs = List.length args + 1 in
569570
let getmethod, args' =
@@ -678,12 +679,14 @@ let rec comp_expr env exp sz cont =
678679
comp_expr env arg sz cont
679680
| Lprim(Pignore, [arg], _) ->
680681
comp_expr env arg sz (add_const_unit cont)
681-
| Lprim(Pdirapply, [func;arg], loc)
682-
| Lprim(Prevapply, [arg;func], loc) ->
682+
| Lprim(Pdirapply pos, [func;arg], loc)
683+
| Lprim(Prevapply pos, [arg;func], loc) ->
683684
let exp = Lapply{
684685
ap_loc=loc;
685686
ap_func=func;
686687
ap_args=[arg];
688+
ap_region_close=pos;
689+
ap_mode=Alloc_heap;
687690
ap_tailcall=Default_tailcall;
688691
ap_inlined=Default_inlined;
689692
ap_specialised=Default_specialise;
@@ -739,10 +742,10 @@ let rec comp_expr env exp sz cont =
739742
(Kpush::
740743
Kconst (Const_base (Const_int n))::
741744
Kaddint::cont)
742-
| Lprim (Pmakefloatblock _mut, args, loc) ->
745+
| Lprim (Pmakefloatblock _, args, loc) ->
743746
let cont = add_pseudo_event loc !compunit_name cont in
744747
comp_args env args sz (Kmakefloatblock (List.length args) :: cont)
745-
| Lprim(Pmakearray (kind, _), args, loc) ->
748+
| Lprim(Pmakearray (kind, _, _), args, loc) ->
746749
let cont = add_pseudo_event loc !compunit_name cont in
747750
begin match kind with
748751
Pintarray | Paddrarray ->
@@ -757,9 +760,9 @@ let rec comp_expr env exp sz cont =
757760
Kccall("caml_make_array", 1) :: cont)
758761
end
759762
| Lprim (Pduparray (kind, mutability),
760-
[Lprim (Pmakearray (kind',_),args,_)], loc) ->
763+
[Lprim (Pmakearray (kind',_,m),args,_)], loc) ->
761764
assert (kind = kind');
762-
comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont
765+
comp_expr env (Lprim (Pmakearray (kind, mutability, m), args, loc)) sz cont
763766
| Lprim (Pduparray _, [arg], loc) ->
764767
let prim_obj_dup =
765768
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
@@ -787,10 +790,10 @@ let rec comp_expr env exp sz cont =
787790
| CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
788791
in
789792
comp_args env args sz cont
790-
| Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
793+
| Lprim(Pmakeblock(tag, _mut, _, _), args, loc) ->
791794
let cont = add_pseudo_event loc !compunit_name cont in
792795
comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
793-
| Lprim(Pfloatfield (n, _sem), args, loc) ->
796+
| Lprim(Pfloatfield (n, _, _), args, loc) ->
794797
let cont = add_pseudo_event loc !compunit_name cont in
795798
comp_args env args sz (Kgetfloatfield n :: cont)
796799
| Lprim(p, args, _) ->
@@ -984,7 +987,8 @@ let rec comp_expr env exp sz cont =
984987
let info =
985988
match lam with
986989
Lapply{ap_args = args} -> Event_return (List.length args)
987-
| Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
990+
| Lsend(_, _, _, args, _, _, _) ->
991+
Event_return (List.length args + 1)
988992
| Lprim(_,args,_) -> Event_return (List.length args)
989993
| _ -> Event_other
990994
in
@@ -997,6 +1001,8 @@ let rec comp_expr env exp sz cont =
9971001
end
9981002
| Lifused (_, exp) ->
9991003
comp_expr env exp sz cont
1004+
| Lregion exp ->
1005+
comp_expr env exp sz cont
10001006

10011007
(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
10021008
The values of eN ... e2 are pushed on the stack, e2 at top of stack,

0 commit comments

Comments
 (0)