Skip to content

Commit

Permalink
Add initialization flag
Browse files Browse the repository at this point in the history
  • Loading branch information
mshinwell committed Dec 11, 2024
1 parent 59e5341 commit 1cff540
Show file tree
Hide file tree
Showing 6 changed files with 55 additions and 29 deletions.
15 changes: 12 additions & 3 deletions bytecomp/bytegen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -683,7 +683,10 @@ let comp_primitive stack_info p sz args =
"Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \
targets";
Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1)
| Pmakearray_dynamic(kind, locality) ->
| Pmakearray_dynamic(kind, locality, With_initializer) ->
if List.compare_length_with args 2 <> 0 then
fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \
arguments for [With_initializer]";
(* CR layouts v4.0: This is "wrong" for unboxed types. It should construct
blocks that can't be marshalled. We've decided to ignore that problem in
the short term, as it's unlikely to cause issues - see the internal arrays
Expand All @@ -708,6 +711,9 @@ let comp_primitive stack_info p sz args =
| Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> ()
end;
Kccall("caml_array_blit", 5)
| Pmakearray_dynamic(_, _, Uninitialized) ->
Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \
translated to Pmakearray_dynamic Initialized earlier on"
(* The cases below are handled in [comp_expr] before the [comp_primitive] call
(in the order in which they appear below),
so they should never be reached in this function. *)
Expand Down Expand Up @@ -984,7 +990,7 @@ let rec comp_expr stack_info env exp sz cont =
(Kreperformterm(sz + nargs) :: discard_dead_code cont)
else
fatal_error "Reperform used in non-tail position"
| Lprim (Pmakearray_dynamic (kind, locality), [len], loc) ->
| Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) ->
(* Use a dummy initializer to implement the "uninitialized" primitive *)
let init =
match kind with
Expand Down Expand Up @@ -1028,7 +1034,10 @@ let rec comp_expr stack_info env exp sz cont =
convert_ignorable (Pproduct_ignorable ignorables)
in
comp_expr stack_info env
(Lprim (Pmakearray_dynamic (kind, locality), [len; init], loc)) sz cont
(Lprim (Pmakearray_dynamic (kind, locality, With_initializer),
[len; init], loc)) sz cont
| Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) ->
Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]"
| Lprim (Pduparray (kind, mutability),
[Lprim (Pmakearray (kind',_,m),args,_)], loc) ->
assert (kind = kind');
Expand Down
8 changes: 6 additions & 2 deletions lambda/lambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,10 @@ type field_read_semantics =
| Reads_agree
| Reads_vary

type has_initializer =
| With_initializer
| Uninitialized

include (struct

type locality_mode =
Expand Down Expand Up @@ -189,7 +193,7 @@ type primitive =
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
(* Array operations *)
| Pmakearray of array_kind * mutable_flag * locality_mode
| Pmakearray_dynamic of array_kind * locality_mode
| Pmakearray_dynamic of array_kind * locality_mode * has_initializer
| Pduparray of array_kind * mutable_flag
| Parrayblit of {
src_mutability : mutable_flag;
Expand Down Expand Up @@ -1829,7 +1833,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function
| Pstringlength | Pstringrefu | Pstringrefs
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None
| Pmakearray (_, _, m) -> Some m
| Pmakearray_dynamic (_, m) -> Some m
| Pmakearray_dynamic (_, m, _) -> Some m
| Pduparray _ -> Some alloc_heap
| Parraylength _ -> None
| Parrayblit _
Expand Down
6 changes: 5 additions & 1 deletion lambda/lambda.mli
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,10 @@ type field_read_semantics =
| Reads_agree
| Reads_vary

type has_initializer =
| With_initializer
| Uninitialized

(* Tail calls can close their enclosing region early *)
type region_close =
| Rc_normal (* do not close region, may TCO if in tail position *)
Expand Down Expand Up @@ -178,7 +182,7 @@ type primitive =
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
(* Array operations *)
| Pmakearray of array_kind * mutable_flag * locality_mode
| Pmakearray_dynamic of array_kind * locality_mode
| Pmakearray_dynamic of array_kind * locality_mode * has_initializer
(** For [Pmakearray_dynamic], if the array kind specifies an unboxed
product, the float array optimization will never apply. *)
| Pduparray of array_kind * mutable_flag
Expand Down
7 changes: 5 additions & 2 deletions lambda/printlambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -663,9 +663,12 @@ let primitive ppf = function
| Pmakearray (k, Immutable_unique, mode) ->
fprintf ppf "make%sarray_unique[%s]" (locality_mode_if_local mode)
(array_kind k)
| Pmakearray_dynamic (k, mode) ->
fprintf ppf "make%sarray_any[%s]" (locality_mode_if_local mode)
| Pmakearray_dynamic (k, mode, has_init) ->
fprintf ppf "make%sarray_any[%s]%s" (locality_mode_if_local mode)
(array_kind k)
(match has_init with
| With_initializer -> ""
| Uninitialized -> "[uninit]")
| Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
| Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
| Pduparray (k, Immutable_unique) ->
Expand Down
25 changes: 14 additions & 11 deletions lambda/translprim.ml
Original file line number Diff line number Diff line change
Expand Up @@ -545,10 +545,10 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
3)
| "%makearray_dynamic" ->
Language_extension.assert_enabled ~loc Layouts Language_extension.Beta;
Primitive (Pmakearray_dynamic (gen_array_kind, mode), 2)
Primitive (Pmakearray_dynamic (gen_array_kind, mode, With_initializer), 2)
| "%makearray_dynamic_uninit" ->
Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha;
Primitive (Pmakearray_dynamic (gen_array_kind, mode), 1)
Primitive (Pmakearray_dynamic (gen_array_kind, mode, Uninitialized), 1)
| "%arrayblit" ->
Language_extension.assert_enabled ~loc Layouts Language_extension.Beta;
Primitive (Parrayblit {
Expand Down Expand Up @@ -1253,8 +1253,8 @@ let specialize_primitive env loc ty ~has_constant_constructor prim =
if st = array_set_type then None
else Some (Primitive (Parraysets (array_set_type, index_kind), arity))
end
| Primitive (Pmakearray_dynamic (array_kind, mode), 2), _ :: p2 :: [] -> begin
(* This is the version of the primitive that takes an initializer *)
| Primitive (Pmakearray_dynamic (array_kind, mode, With_initializer), 2),
_ :: p2 :: [] -> begin
let loc = to_location loc in
let new_array_kind =
array_kind_of_elt ~elt_sort:None env loc p2
Expand All @@ -1263,11 +1263,12 @@ let specialize_primitive env loc ty ~has_constant_constructor prim =
let array_mut = array_type_mut env rest_ty in
unboxed_product_iarray_check loc new_array_kind array_mut;
if array_kind = new_array_kind then None
else Some (Primitive (Pmakearray_dynamic (new_array_kind, mode), 2))
else
Some (Primitive (Pmakearray_dynamic (
new_array_kind, mode, With_initializer), 2))
end
| Primitive (Pmakearray_dynamic (array_kind, mode), 1), _ :: [] -> begin
(* This is the version of the primitive that returns an uninitialized
array *)
| Primitive (Pmakearray_dynamic (array_kind, mode, Uninitialized), 1),
_ :: [] -> begin
let loc = to_location loc in
match is_function_type env ty with
| None -> None
Expand All @@ -1280,7 +1281,9 @@ let specialize_primitive env loc ty ~has_constant_constructor prim =
unboxed_product_iarray_check loc new_array_kind array_mut;
unboxed_product_uninitialized_array_check loc new_array_kind;
if array_kind = new_array_kind then None
else Some (Primitive (Pmakearray_dynamic (new_array_kind, mode), 1))
else
Some (Primitive (Pmakearray_dynamic (
new_array_kind, mode, Uninitialized), 1))
end
| Primitive (Pmakearray_dynamic _, arity), args ->
Misc.fatal_errorf
Expand Down Expand Up @@ -1786,7 +1789,7 @@ let lambda_primitive_needs_event_after = function
| Pmulfloat (_, _) | Pdivfloat (_, _)
| Pstringrefs | Pbytesrefs
| Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _
| Pmakearray_dynamic (Pgenarray, _)
| Pmakearray_dynamic (Pgenarray, _, _)
| Parrayrefu ((Pgenarray_ref _ | Pfloatarray_ref _), _, _)
| Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _
| Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _
Expand Down Expand Up @@ -1836,7 +1839,7 @@ let lambda_primitive_needs_event_after = function
| Pmakearray_dynamic
((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray _
| Punboxedintarray _ | Punboxedvectorarray _
| Pgcscannableproductarray _ | Pgcignorableproductarray _), _)
| Pgcscannableproductarray _ | Pgcignorableproductarray _), _, _)
| Parrayblit _
| Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisnull | Pisout
| Pprobe_is_enabled _
Expand Down
23 changes: 13 additions & 10 deletions middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml
Original file line number Diff line number Diff line change
Expand Up @@ -339,7 +339,8 @@ let makearray_dynamic_scannable_unboxed_product env
~length ~init:(Some init) loc

let makearray_dynamic env (lambda_array_kind : L.array_kind)
(mode : L.locality_mode) args loc : Env.t * primitive_transform_result =
(mode : L.locality_mode) (has_init : L.has_initializer) args loc :
Env.t * primitive_transform_result =
(* %makearray_dynamic is analogous to (from stdlib/array.ml):
* external create: int -> 'a -> 'a array = "caml_make_vect"
* except that it works on any layout, including unboxed products, at both
Expand All @@ -351,13 +352,15 @@ let makearray_dynamic env (lambda_array_kind : L.array_kind)
*)
let dbg = Debuginfo.from_location loc in
let length, init =
match args with
| [length] -> length, None
| [length; init] -> length, Some init
| [] | _ :: _ :: _ ->
Misc.fatal_error
"%makearray_dynamic takes the (non-unarized) length and optionally an \
initializer (the latter perhaps of unboxed product layout)"
match args, has_init with
| [length], Uninitialized -> length, None
| [length; init], With_initializer -> length, Some init
| _, (Uninitialized | With_initializer) ->
Misc.fatal_errorf
"Pmakearray_dynamic takes the (non-unarized) length and optionally an \
initializer (the latter perhaps of unboxed product layout) according \
to the setting of [Uninitialized] or [With_initializer]:@ %a"
Debuginfo.print_compact dbg
in
let[@inline] must_have_initializer () =
match init with
Expand Down Expand Up @@ -666,8 +669,8 @@ let transform_primitive0 env (prim : L.primitive) args loc =

let transform_primitive env (prim : L.primitive) args loc =
match prim with
| Pmakearray_dynamic (lambda_array_kind, mode) ->
makearray_dynamic env lambda_array_kind mode args loc
| Pmakearray_dynamic (lambda_array_kind, mode, has_init) ->
makearray_dynamic env lambda_array_kind mode has_init args loc
| Parrayblit { src_mutability; dst_array_set_kind } ->
arrayblit env ~src_mutability ~dst_array_set_kind args loc
| _ -> env, transform_primitive0 env prim args loc
Expand Down

0 comments on commit 1cff540

Please sign in to comment.