Skip to content

Unboxed numbers #1165

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 7 commits into from
Mar 10, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 6 additions & 0 deletions backend/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -2658,6 +2658,10 @@ let machtype_of_layout (layout : Lambda.layout) =
match layout with
| Ptop -> Misc.fatal_error "No machtype for layout [Ptop]"
| Pbottom -> Misc.fatal_error "No unique machtype for layout [Pbottom]"
| Punboxed_float -> typ_float
| Punboxed_int _ ->
(* Only 64-bit architectures, so this is always [typ_int] *)
typ_int
| Pvalue _ -> typ_val

let final_curry_function nlocal arity result =
Expand Down Expand Up @@ -3998,4 +4002,6 @@ let kind_of_layout (layout : Lambda.layout) =
| Ptop | Pbottom ->
(* This is incorrect but only used for unboxing *)
Vval Pgenval
| Punboxed_float -> Vfloat
| Punboxed_int _ -> Vint
| Pvalue kind -> Vval kind
27 changes: 25 additions & 2 deletions backend/cmmgen.ml
Original file line number Diff line number Diff line change
Expand Up @@ -664,6 +664,7 @@ let rec transl env e =
| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
| Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
| Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
| Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
| Pbbswap _), _)
->
fatal_error "Cmmgen.transl:prim"
Expand Down Expand Up @@ -806,6 +807,8 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
Misc.fatal_errorf
"Variable %a with layout [Pbottom] can't be compiled"
VP.print id
| Punboxed_float | Punboxed_int _ ->
u := No_unboxing
| Pvalue kind ->
let strict = is_strict kind in
u := join_unboxed_number_kind ~strict !u
Expand All @@ -817,12 +820,12 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
let body = transl env_body body in
let new_env, rewrite, ids =
List.fold_right
(fun (id, _kind, u) (env, rewrite, ids) ->
(fun (id, layout, u) (env, rewrite, ids) ->
match !u with
| No_unboxing | Boxed (_, true) | No_result ->
env,
(fun x -> x) :: rewrite,
(id, Cmm.typ_val) :: ids
(id, machtype_of_layout layout) :: ids
| Boxed (bn, false) ->
let unboxed_id = V.create_local (VP.name id) in
add_unboxed_id (VP.var id) unboxed_id bn env,
Expand Down Expand Up @@ -937,7 +940,15 @@ and transl_prim_1 env p arg dbg =
offsetint n (transl env arg) dbg
| Poffsetref n ->
offsetref n (transl env arg) dbg
| Punbox_int bi ->
transl_unbox_int dbg env bi arg
| Pbox_int (bi, m) ->
box_int dbg bi m (transl env arg)
(* Floating-point operations *)
| Punbox_float ->
transl_unbox_float dbg env arg
| Pbox_float m ->
box_float dbg m (transl env arg)
| Pfloatofint m ->
box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
| Pintoffloat ->
Expand Down Expand Up @@ -1172,6 +1183,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
| Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
| Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _
| Pprobe_is_enabled _
| Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
->
fatal_errorf "Cmmgen.transl_prim_2: %a"
Printclambda_primitives.primitive p
Expand Down Expand Up @@ -1232,6 +1244,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
| Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
| Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
| Pprobe_is_enabled _
| Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
->
fatal_errorf "Cmmgen.transl_prim_3: %a"
Printclambda_primitives.primitive p
Expand Down Expand Up @@ -1305,6 +1318,16 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body =
there may be constant closures inside that need lifting out. *)
let _cbody : expression = transl_body env in
cexp
| Punboxed_float | Punboxed_int _ -> begin
let cexp = transl env exp in
let cbody = transl_body env in
match str with
| (Immutable | Immutable_unique) ->
Clet(id, cexp, cbody)
| Mutable ->
let typ = machtype_of_layout layout in
Clet_mut(id, typ, cexp, cbody)
end
| Pvalue kind ->
transl_let_value env str kind id exp transl_body

Expand Down
12 changes: 11 additions & 1 deletion middle_end/clambda_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -122,6 +122,10 @@ type primitive =
| Popaque
(* Probes *)
| Pprobe_is_enabled of { name : string }
| Punbox_float
| Pbox_float of alloc_mode
| Punbox_int of boxed_integer
| Pbox_int of boxed_integer * alloc_mode

and integer_comparison = Lambda.integer_comparison =
Ceq | Cne | Clt | Cgt | Cle | Cge
Expand All @@ -144,6 +148,8 @@ and value_kind = Lambda.value_kind =
and layout = Lambda.layout =
| Ptop
| Pvalue of value_kind
| Punboxed_float
| Punboxed_int of boxed_integer
| Pbottom

and block_shape = Lambda.block_shape
Expand Down Expand Up @@ -171,4 +177,8 @@ and raise_kind = Lambda.raise_kind =

let equal (x: primitive) (y: primitive) = x = y

let result_layout _p = Lambda.layout_any_value
let result_layout (p : primitive) =
match p with
| Punbox_float -> Lambda.Punboxed_float
| Punbox_int bi -> Lambda.Punboxed_int bi
| _ -> Lambda.layout_any_value
6 changes: 6 additions & 0 deletions middle_end/clambda_primitives.mli
Original file line number Diff line number Diff line change
Expand Up @@ -125,6 +125,10 @@ type primitive =
| Popaque
(* Probes *)
| Pprobe_is_enabled of { name : string }
| Punbox_float
| Pbox_float of alloc_mode
| Punbox_int of boxed_integer
| Pbox_int of boxed_integer * alloc_mode

and integer_comparison = Lambda.integer_comparison =
Ceq | Cne | Clt | Cgt | Cle | Cge
Expand All @@ -147,6 +151,8 @@ and value_kind = Lambda.value_kind =
and layout = Lambda.layout =
| Ptop
| Pvalue of value_kind
| Punboxed_float
| Punboxed_int of boxed_integer
| Pbottom

and block_shape = Lambda.block_shape
Expand Down
2 changes: 2 additions & 0 deletions middle_end/closure/closure.ml
Original file line number Diff line number Diff line change
Expand Up @@ -61,6 +61,8 @@ let is_gc_ignorable kind =
match kind with
| Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
| Pbottom -> Misc.fatal_error "[Pbottom] should not be stored in a closure."
| Punboxed_float -> true
| Punboxed_int _ -> true
| Pvalue Pintval -> true
| Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false

Expand Down
4 changes: 4 additions & 0 deletions middle_end/convert_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -154,6 +154,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
~native_name:"caml_obj_dup"
~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr]
~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr))
| Punbox_float -> Punbox_float
| Pbox_float m -> Pbox_float m
| Punbox_int bi -> Punbox_int bi
| Pbox_int (bi, m) -> Pbox_int (bi, m)
| Pobj_magic _
| Pbytes_to_string
| Pbytes_of_string
Expand Down
2 changes: 2 additions & 0 deletions middle_end/flambda/closure_offsets.ml
Original file line number Diff line number Diff line change
Expand Up @@ -77,6 +77,8 @@ let add_closure_offsets
Misc.fatal_error
"[Pbottom] should have been eliminated as dead code \
and not stored in a closure."
| Punboxed_float -> true
| Punboxed_int _ -> true
| Pvalue Pintval -> true
| Pvalue _ -> false)
free_vars
Expand Down
8 changes: 7 additions & 1 deletion middle_end/flambda/flambda_to_clambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -703,6 +703,8 @@ and to_clambda_set_of_closures t env
Misc.fatal_error
"[Pbottom] should have been eliminated as dead code \
and not stored in a closure."
| Punboxed_float -> true
| Punboxed_int _ -> true
| Pvalue Pintval -> true
| Pvalue _ -> false)
free_vars
Expand Down Expand Up @@ -752,7 +754,11 @@ and to_clambda_closed_set_of_closures t env symbol
in
let body =
let body, body_layout = to_clambda t env_body function_decl.body in
assert(Lambda.compatible_layout body_layout function_decl.return_layout);
if not (Lambda.compatible_layout body_layout function_decl.return_layout) then
Misc.fatal_errorf "Incompatible layouts:@.body: %[email protected]: %a@.%a@."
Printlambda.layout body_layout
Printlambda.layout function_decl.return_layout
Printclambda.clambda body;
Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol body
in
assert (
Expand Down
3 changes: 2 additions & 1 deletion middle_end/flambda2/from_lambda/closure_conversion.ml
Original file line number Diff line number Diff line change
Expand Up @@ -693,7 +693,8 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args
| Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _
| Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pctconst _ | Pbswap16
| Pbbswap _ | Pint_as_pointer | Popaque _ | Pprobe_is_enabled _ | Pobj_dup
| Pobj_magic _ ->
| Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
->
(* Inconsistent with outer match *)
assert false
in
Expand Down
13 changes: 11 additions & 2 deletions middle_end/flambda2/from_lambda/lambda_to_flambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -953,7 +953,8 @@ let primitive_can_raise (prim : Lambda.primitive) =
| Pbigstring_set_32 true
| Pbigstring_set_64 true
| Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | Popaque _
| Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ ->
| Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float
| Punbox_int _ | Pbox_int _ ->
false

let primitive_result_kind (prim : Lambda.primitive) :
Expand Down Expand Up @@ -1014,7 +1015,8 @@ let primitive_result_kind (prim : Lambda.primitive) :
| Pmulbint (bi, _)
| Pbintofint (bi, _)
| Pcvtbint (_, bi, _)
| Pbbswap (bi, _) -> (
| Pbbswap (bi, _)
| Pbox_int (bi, _) -> (
match bi with
| Pint32 -> Flambda_kind.With_subkind.boxed_int32
| Pint64 -> Flambda_kind.With_subkind.boxed_int64
Expand All @@ -1035,6 +1037,13 @@ let primitive_result_kind (prim : Lambda.primitive) :
(_, _, (Pbigarray_complex32 | Pbigarray_complex64 | Pbigarray_unknown), _)
| Pint_as_pointer | Pobj_dup ->
Flambda_kind.With_subkind.any_value
| Pbox_float _ -> Flambda_kind.With_subkind.boxed_float
| Punbox_float -> Flambda_kind.With_subkind.naked_float
| Punbox_int bi -> (
match bi with
| Pint32 -> Flambda_kind.With_subkind.naked_int32
| Pint64 -> Flambda_kind.With_subkind.naked_int64
| Pnativeint -> Flambda_kind.With_subkind.naked_nativeint)

type cps_continuation =
| Tail of Continuation.t
Expand Down
19 changes: 18 additions & 1 deletion middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -722,6 +722,22 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
( Float_comp (Yielding_bool (convert_float_comparison comp)),
unbox_float arg1,
unbox_float arg2 ))
| Punbox_float, [arg] -> Unary (Unbox_number Naked_float, arg)
| Pbox_float mode, [arg] ->
Unary
( Box_number
( Naked_float,
Alloc_mode.For_allocations.from_lambda mode ~current_region ),
arg )
| Punbox_int bi, [arg] ->
let kind = boxable_number_of_boxed_integer bi in
Unary (Unbox_number kind, arg)
| Pbox_int (bi, mode), [arg] ->
let kind = boxable_number_of_boxed_integer bi in
Unary
( Box_number
(kind, Alloc_mode.For_allocations.from_lambda mode ~current_region),
arg )
| Pfield_computed sem, [obj; field] ->
let block_access : P.Block_access_kind.t =
Values { tag = Unknown; size = Unknown; field_kind = Any_value }
Expand Down Expand Up @@ -1168,7 +1184,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list)
| Pintofbint _ | Pnegbint _ | Popaque _ | Pduprecord _ | Parraylength _
| Pduparray _ | Pfloatfield _ | Pcvtbint _ | Poffsetref _ | Pbswap16
| Pbbswap _ | Pisint _ | Pint_as_pointer | Pbigarraydim _ | Pobj_dup
| Pobj_magic _ ),
| Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
),
([] | _ :: _ :: _) ) ->
Misc.fatal_errorf
"Closure_conversion.convert_primitive: Wrong arity for unary primitive \
Expand Down
4 changes: 4 additions & 0 deletions middle_end/flambda2/kinds/flambda_kind.ml
Original file line number Diff line number Diff line change
Expand Up @@ -522,6 +522,10 @@ module With_subkind = struct
| Ptop -> Misc.fatal_error "Can't convert layout [Ptop] to flambda kind"
| Pbottom ->
Misc.fatal_error "Can't convert layout [Pbottom] to flambda kind"
| Punboxed_float -> naked_float
| Punboxed_int Pint32 -> naked_int32
| Punboxed_int Pint64 -> naked_int64
| Punboxed_int Pnativeint -> naked_nativeint

include Container_types.Make (struct
type nonrec t = t
Expand Down
16 changes: 16 additions & 0 deletions middle_end/internal_variable_names.ml
Original file line number Diff line number Diff line change
Expand Up @@ -302,6 +302,14 @@ let unbox_free_vars_of_closures = "unbox_free_vars_of_closures"
let unit = "unit"
let zero = "zero"
let probe_handler = "probe_handler"
let punbox_float = "Punbox_float"
let pbox_float = "Pbox_float"
let punbox_float_arg = "Punbox_float_arg"
let pbox_float_arg = "Pbox_float_arg"
let punbox_int = "Punbox_int"
let pbox_int = "Pbox_int"
let punbox_int_arg = "Punbox_int_arg"
let pbox_int_arg = "Pbox_int_arg"

let anon_fn_with_loc (sloc: Lambda.scoped_location) =
let loc = Debuginfo.Scoped_location.to_location sloc in
Expand Down Expand Up @@ -421,6 +429,10 @@ let of_primitive : Lambda.primitive -> string = function
| Pprobe_is_enabled _ -> pprobe_is_enabled
| Pobj_dup -> pobj_dup
| Pobj_magic _ -> pobj_magic
| Punbox_float -> punbox_float
| Pbox_float _ -> pbox_float
| Punbox_int _ -> punbox_int
| Pbox_int _ -> pbox_int

let of_primitive_arg : Lambda.primitive -> string = function
| Pbytes_of_string -> pbytes_of_string_arg
Expand Down Expand Up @@ -529,3 +541,7 @@ let of_primitive_arg : Lambda.primitive -> string = function
| Pprobe_is_enabled _ -> pprobe_is_enabled_arg
| Pobj_dup -> pobj_dup_arg
| Pobj_magic _ -> pobj_magic_arg
| Punbox_float -> punbox_float_arg
| Pbox_float _ -> pbox_float_arg
| Punbox_int _ -> punbox_int_arg
| Pbox_int _ -> pbox_int_arg
4 changes: 4 additions & 0 deletions middle_end/printclambda.ml
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,10 @@ let layout (layout : Lambda.layout) =
| Pvalue kind -> value_kind kind
| Ptop -> ":top"
| Pbottom -> ":bottom"
| Punboxed_float -> ":unboxed_float"
| Punboxed_int Pint32 -> ":unboxed_int32"
| Punboxed_int Pint64 -> ":unboxed_int64"
| Punboxed_int Pnativeint -> ":unboxed_nativeint"

let rec structured_constant ppf = function
| Uconst_float x -> fprintf ppf "%F" x
Expand Down
5 changes: 5 additions & 0 deletions middle_end/printclambda_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -230,3 +230,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
| Pint_as_pointer -> fprintf ppf "int_as_pointer"
| Popaque -> fprintf ppf "opaque"
| Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name
| Pbox_float m -> fprintf ppf "box_float.%s" (alloc_kind m)
| Punbox_float -> fprintf ppf "unbox_float"
| Pbox_int (bi, m) ->
fprintf ppf "box_%s.%s" (boxed_integer_name bi) (alloc_kind m)
| Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi)
4 changes: 4 additions & 0 deletions middle_end/semantics_of_primitives.ml
Original file line number Diff line number Diff line change
Expand Up @@ -82,8 +82,10 @@ let for_primitive (prim : Clambda_primitives.primitive) =
Arbitrary_effects, No_coeffects
| Poffsetint _ -> No_effects, No_coeffects
| Poffsetref _ -> Arbitrary_effects, Has_coeffects
| Punbox_float | Punbox_int _
| Pintoffloat
| Pfloatcomp _ -> No_effects, No_coeffects
| Pbox_float m | Pbox_int (_, m)
| Pfloatofint m
| Pnegfloat m
| Pabsfloat m
Expand Down Expand Up @@ -210,8 +212,10 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool =
-> false
| Poffsetint _ -> false
| Poffsetref _ -> false
| Punbox_float | Punbox_int _
| Pintoffloat
| Pfloatcomp _ -> false
| Pbox_float m | Pbox_int (_, m)
| Pfloatofint m
| Pnegfloat m
| Pabsfloat m
Expand Down
6 changes: 6 additions & 0 deletions ocaml/asmcomp/cmm_helpers.ml
Original file line number Diff line number Diff line change
Expand Up @@ -2243,6 +2243,10 @@ let machtype_of_layout (layout : Lambda.layout) =
match layout with
| Ptop -> Misc.fatal_error "No machtype for layout [Ptop]"
| Pbottom -> Misc.fatal_error "No unique machtype for layout [Pbottom]"
| Punboxed_float -> typ_float
| Punboxed_int _ ->
(* Only 64-bit architectures, so this is always [typ_int] *)
typ_int
| Pvalue _ -> typ_val

let final_curry_function nlocal arity result =
Expand Down Expand Up @@ -3149,4 +3153,6 @@ let kind_of_layout (layout : Lambda.layout) =
| Ptop | Pbottom ->
(* This is incorrect but only used for unboxing *)
Vval Pgenval
| Punboxed_float -> Vfloat
| Punboxed_int _ -> Vint
| Pvalue kind -> Vval kind
Loading