Skip to content

Commit

Permalink
Squashed 'ocaml/' changes from 23a7f73..86526aa
Browse files Browse the repository at this point in the history
86526aa flambda-backend: Middle-end support for local allocs (#491)
969b937 flambda-backend: Backend support for local allocations (#478)
2d1e6ef flambda-backend: Remove leading space from LINE. (#484)

git-subtree-dir: ocaml
git-subtree-split: 86526aa
  • Loading branch information
stedolan committed Feb 1, 2022
1 parent d39cf1b commit c1a2712
Show file tree
Hide file tree
Showing 33 changed files with 1,318 additions and 826 deletions.
3 changes: 2 additions & 1 deletion asmcomp/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1356,7 +1356,7 @@ let default_prim name =


let int64_native_prim name arity ~alloc =
let u64 = Primitive.Unboxed_integer Primitive.Pint64 in
let u64 = Primitive.(Prim_global, Unboxed_integer Pint64) in
let rec make_args = function 0 -> [] | n -> u64 :: make_args (n - 1) in
let effects = Primitive.Arbitrary_effects in
let coeffects = Primitive.Has_coeffects in
Expand Down Expand Up @@ -2180,6 +2180,7 @@ let assignment_kind
(ptr: Lambda.immediate_or_pointer)
(init: Lambda.initialization_or_assignment) =
match init, ptr with
| Local_assignment, _ -> assert false (* temporary *)
| Assignment, Pointer -> Caml_modify
| Heap_initialization, Pointer -> Caml_initialize
| Assignment, Immediate
Expand Down
18 changes: 9 additions & 9 deletions asmcomp/cmmgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -747,18 +747,18 @@ and transl_make_array dbg env kind args =
and transl_ccall env prim args dbg =
let transl_arg native_repr arg =
match native_repr with
| Same_as_ocaml_repr ->
| _, Same_as_ocaml_repr ->
(XInt, transl env arg)
| Unboxed_float ->
| _, Unboxed_float ->
(XFloat, transl_unbox_float dbg env arg)
| Unboxed_integer bi ->
| _, 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 ->
| _, Untagged_int ->
(XInt, untag_int (transl env arg) dbg)
in
let rec transl_args native_repr_args args =
Expand All @@ -776,12 +776,12 @@ and transl_ccall env prim args dbg =
in
let typ_res, wrap_result =
match prim.prim_native_repr_res with
| Same_as_ocaml_repr -> (typ_val, fun x -> x)
| Unboxed_float -> (typ_float, box_float dbg)
| Unboxed_integer Pint64 when size_int = 4 ->
| _, Same_as_ocaml_repr -> (typ_val, fun x -> x)
| _, Unboxed_float -> (typ_float, box_float dbg)
| _, Unboxed_integer Pint64 when size_int = 4 ->
([|Int; Int|], box_int dbg Pint64)
| Unboxed_integer bi -> (typ_int, box_int dbg bi)
| Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
| _, Unboxed_integer bi -> (typ_int, box_int dbg bi)
| _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
in
let typ_args, args = transl_args prim.prim_native_repr_args args in
wrap_result
Expand Down
1 change: 1 addition & 0 deletions asmcomp/printcmm.ml
Original file line number Diff line number Diff line change
Expand Up @@ -126,6 +126,7 @@ let operation d = function
| Lambda.Heap_initialization -> "(heap-init)"
| Lambda.Root_initialization -> "(root-init)"
| Lambda.Assignment -> ""
| Lambda.Local_assignment -> "(local)"
in
Printf.sprintf "store %s%s" (chunk c) init
| Caddi -> "+"
Expand Down
2 changes: 1 addition & 1 deletion asmcomp/selectgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -456,7 +456,7 @@ method select_operation op args _dbg =
match init with
| Lambda.Root_initialization -> false
| Lambda.Heap_initialization -> false
| Lambda.Assignment -> true
| Lambda.Assignment | Lambda.Local_assignment -> true
in
if chunk = Word_int || chunk = Word_val then begin
let (op, newarg2) = self#select_store is_assign addr arg2 in
Expand Down
Binary file modified boot/ocamlc
Binary file not shown.
Binary file modified boot/ocamllex
Binary file not shown.
90 changes: 48 additions & 42 deletions bytecomp/bytegen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -109,7 +109,7 @@ let rec is_tailcall = function
from the tail call optimization? *)

let preserve_tailcall_for_prim = function
Pidentity | Popaque | Pdirapply | Prevapply | Psequor | Psequand ->
Pidentity | Popaque | Pdirapply _ | Prevapply _ | Psequor | Psequand ->
true
| Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
| Pmakeblock _ | Pmakefloatblock _
Expand All @@ -118,8 +118,8 @@ let preserve_tailcall_for_prim = function
| Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
| Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
| Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
| Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat
| Pdivfloat | Pfloatcomp _ | Pstringlength | Pstringrefu | Pstringrefs
| Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
| Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu | Pstringrefs
| Pcompare_ints | Pcompare_floats | Pcompare_bints _
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
| Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
Expand Down Expand Up @@ -209,12 +209,12 @@ let rec size_of_lambda env = function
in
size_of_lambda env body
| Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
| Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
| Lprim (Pmakearray ((Paddrarray|Pintarray), _, _), args, _) ->
RHS_block (List.length args)
| Lprim (Pmakearray (Pfloatarray, _), args, _)
| Lprim (Pmakearray (Pfloatarray, _, _), args, _)
| Lprim (Pmakefloatblock _, args, _) ->
RHS_floatblock (List.length args)
| Lprim (Pmakearray (Pgenarray, _), _, _) ->
| Lprim (Pmakearray (Pgenarray, _, _), _, _) ->
(* Pgenarray is excluded from recursive bindings by the
check in Translcore.check_recursive_lambda *)
RHS_nonrec
Expand All @@ -227,6 +227,7 @@ let rec size_of_lambda env = function
| Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
| Levent (lam, _) -> size_of_lambda env lam
| Lsequence (_lam, lam') -> size_of_lambda env lam'
| Lregion lam -> size_of_lambda env lam
| _ -> RHS_nonrec

(**** Merging consecutive events ****)
Expand Down Expand Up @@ -398,7 +399,7 @@ let comp_primitive p args =
| Pfield_computed _sem -> Kgetvectitem
| Psetfield(n, _ptr, _init) -> Ksetfield n
| Psetfield_computed(_ptr, _init) -> Ksetvectitem
| Pfloatfield (n, _sem) -> Kgetfloatfield n
| Pfloatfield (n, _sem, _mode) -> Kgetfloatfield n
| Psetfloatfield (n, _init) -> Ksetfloatfield n
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
| Pccall p -> Kccall(p.prim_name, p.prim_arity)
Expand All @@ -417,13 +418,13 @@ let comp_primitive p args =
| Poffsetint n -> Koffsetint n
| Poffsetref n -> Koffsetref n
| Pintoffloat -> Kccall("caml_int_of_float", 1)
| Pfloatofint -> Kccall("caml_float_of_int", 1)
| Pnegfloat -> Kccall("caml_neg_float", 1)
| Pabsfloat -> Kccall("caml_abs_float", 1)
| Paddfloat -> Kccall("caml_add_float", 2)
| Psubfloat -> Kccall("caml_sub_float", 2)
| Pmulfloat -> Kccall("caml_mul_float", 2)
| Pdivfloat -> Kccall("caml_div_float", 2)
| Pfloatofint _ -> Kccall("caml_float_of_int", 1)
| Pnegfloat _ -> Kccall("caml_neg_float", 1)
| Pabsfloat _ -> Kccall("caml_abs_float", 1)
| Paddfloat _ -> Kccall("caml_add_float", 2)
| Psubfloat _ -> Kccall("caml_sub_float", 2)
| Pmulfloat _ -> Kccall("caml_mul_float", 2)
| Pdivfloat _ -> Kccall("caml_div_float", 2)
| Pstringlength -> Kccall("caml_ml_string_length", 1)
| Pbyteslength -> Kccall("caml_ml_bytes_length", 1)
| Pstringrefs -> Kccall("caml_string_get", 2)
Expand Down Expand Up @@ -467,26 +468,26 @@ let comp_primitive p args =
Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
| Pisint -> Kisint
| Pisout -> Kisout
| Pbintofint bi -> comp_bint_primitive bi "of_int" args
| Pbintofint (bi,_) -> comp_bint_primitive bi "of_int" args
| Pintofbint bi -> comp_bint_primitive bi "to_int" args
| Pcvtbint(Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1)
| Pcvtbint(Pnativeint, Pint32) -> Kccall("caml_nativeint_to_int32", 1)
| Pcvtbint(Pint32, Pint64) -> Kccall("caml_int64_of_int32", 1)
| Pcvtbint(Pint64, Pint32) -> Kccall("caml_int64_to_int32", 1)
| Pcvtbint(Pnativeint, Pint64) -> Kccall("caml_int64_of_nativeint", 1)
| Pcvtbint(Pint64, Pnativeint) -> Kccall("caml_int64_to_nativeint", 1)
| Pnegbint bi -> comp_bint_primitive bi "neg" args
| Paddbint bi -> comp_bint_primitive bi "add" args
| Psubbint bi -> comp_bint_primitive bi "sub" args
| Pmulbint bi -> comp_bint_primitive bi "mul" args
| Pcvtbint(Pint32, Pnativeint, _) -> Kccall("caml_nativeint_of_int32", 1)
| Pcvtbint(Pnativeint, Pint32, _) -> Kccall("caml_nativeint_to_int32", 1)
| Pcvtbint(Pint32, Pint64, _) -> Kccall("caml_int64_of_int32", 1)
| Pcvtbint(Pint64, Pint32, _) -> Kccall("caml_int64_to_int32", 1)
| Pcvtbint(Pnativeint, Pint64, _) -> Kccall("caml_int64_of_nativeint", 1)
| Pcvtbint(Pint64, Pnativeint, _) -> Kccall("caml_int64_to_nativeint", 1)
| Pnegbint(bi,_) -> comp_bint_primitive bi "neg" args
| Paddbint(bi,_) -> comp_bint_primitive bi "add" args
| Psubbint(bi,_) -> comp_bint_primitive bi "sub" args
| Pmulbint(bi,_) -> comp_bint_primitive bi "mul" args
| Pdivbint { size = bi } -> comp_bint_primitive bi "div" args
| Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args
| Pandbint bi -> comp_bint_primitive bi "and" args
| Porbint bi -> comp_bint_primitive bi "or" args
| Pxorbint bi -> comp_bint_primitive bi "xor" args
| Plslbint bi -> comp_bint_primitive bi "shift_left" args
| Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
| Pasrbint bi -> comp_bint_primitive bi "shift_right" args
| Pandbint(bi,_) -> comp_bint_primitive bi "and" args
| Porbint(bi,_) -> comp_bint_primitive bi "or" args
| Pxorbint(bi,_) -> comp_bint_primitive bi "xor" args
| Plslbint(bi,_) -> comp_bint_primitive bi "shift_left" args
| Plsrbint(bi,_) -> comp_bint_primitive bi "shift_right_unsigned" args
| Pasrbint(bi,_) -> comp_bint_primitive bi "shift_right" args
| Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
| Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2)
| Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
Expand All @@ -503,7 +504,7 @@ let comp_primitive p args =
| Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
| Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
| Pbswap16 -> Kccall("caml_bswap16", 1)
| Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
| Pbbswap(bi,_) -> comp_bint_primitive bi "bswap" args
| Pint_as_pointer -> Kccall("caml_int_as_pointer", 1)
| Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
| Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
Expand Down Expand Up @@ -563,7 +564,7 @@ let rec comp_expr env exp sz cont =
(Kapply nargs :: cont1))
end
end
| Lsend(kind, met, obj, args, _) ->
| Lsend(kind, met, obj, args, _, _, _) ->
let args = if kind = Cached then List.tl args else args in
let nargs = List.length args + 1 in
let getmethod, args' =
Expand Down Expand Up @@ -678,12 +679,14 @@ let rec comp_expr env exp sz cont =
comp_expr env arg sz cont
| Lprim(Pignore, [arg], _) ->
comp_expr env arg sz (add_const_unit cont)
| Lprim(Pdirapply, [func;arg], loc)
| Lprim(Prevapply, [arg;func], loc) ->
| Lprim(Pdirapply pos, [func;arg], loc)
| Lprim(Prevapply pos, [arg;func], loc) ->
let exp = Lapply{
ap_loc=loc;
ap_func=func;
ap_args=[arg];
ap_region_close=pos;
ap_mode=Alloc_heap;
ap_tailcall=Default_tailcall;
ap_inlined=Default_inlined;
ap_specialised=Default_specialise;
Expand Down Expand Up @@ -739,10 +742,10 @@ let rec comp_expr env exp sz cont =
(Kpush::
Kconst (Const_base (Const_int n))::
Kaddint::cont)
| Lprim (Pmakefloatblock _mut, args, loc) ->
| Lprim (Pmakefloatblock _, args, loc) ->
let cont = add_pseudo_event loc !compunit_name cont in
comp_args env args sz (Kmakefloatblock (List.length args) :: cont)
| Lprim(Pmakearray (kind, _), args, loc) ->
| Lprim(Pmakearray (kind, _, _), args, loc) ->
let cont = add_pseudo_event loc !compunit_name cont in
begin match kind with
Pintarray | Paddrarray ->
Expand All @@ -757,9 +760,9 @@ let rec comp_expr env exp sz cont =
Kccall("caml_make_array", 1) :: cont)
end
| Lprim (Pduparray (kind, mutability),
[Lprim (Pmakearray (kind',_),args,_)], loc) ->
[Lprim (Pmakearray (kind',_,m),args,_)], loc) ->
assert (kind = kind');
comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont
comp_expr env (Lprim (Pmakearray (kind, mutability, m), args, loc)) sz cont
| Lprim (Pduparray _, [arg], loc) ->
let prim_obj_dup =
Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
Expand Down Expand Up @@ -787,10 +790,10 @@ let rec comp_expr env exp sz cont =
| CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
in
comp_args env args sz cont
| Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
| Lprim(Pmakeblock(tag, _mut, _, _), args, loc) ->
let cont = add_pseudo_event loc !compunit_name cont in
comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
| Lprim(Pfloatfield (n, _sem), args, loc) ->
| Lprim(Pfloatfield (n, _, _), args, loc) ->
let cont = add_pseudo_event loc !compunit_name cont in
comp_args env args sz (Kgetfloatfield n :: cont)
| Lprim(p, args, _) ->
Expand Down Expand Up @@ -984,7 +987,8 @@ let rec comp_expr env exp sz cont =
let info =
match lam with
Lapply{ap_args = args} -> Event_return (List.length args)
| Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
| Lsend(_, _, _, args, _, _, _) ->
Event_return (List.length args + 1)
| Lprim(_,args,_) -> Event_return (List.length args)
| _ -> Event_other
in
Expand All @@ -997,6 +1001,8 @@ let rec comp_expr env exp sz cont =
end
| Lifused (_, exp) ->
comp_expr env exp sz cont
| Lregion exp ->
comp_expr env exp sz cont

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

0 comments on commit c1a2712

Please sign in to comment.