diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 142579fdaf7..b8195d43400 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1252,7 +1252,7 @@ module Extended_machtype = struct | Ptop -> Misc.fatal_error "No Extended_machtype for layout [Ptop]" | Pbottom -> Misc.fatal_error "No unique Extended_machtype for layout [Pbottom]" - | Punboxed_float -> typ_float + | Punboxed_float Pfloat64 -> typ_float | Punboxed_vector (Pvec128 _) -> typ_vec128 | Punboxed_int _ -> (* Only 64-bit architectures, so this is always [typ_int] *) @@ -2828,7 +2828,7 @@ let arraylength kind arg dbg = Cop (Cor, [len; Cconst_int (1, dbg)], dbg) | Paddrarray | Pintarray -> Cop (Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) - | Pfloatarray | Punboxedfloatarray -> + | Pfloatarray | Punboxedfloatarray Pfloat64 -> (* Note: we only support 64 bit targets now, so this is ok for Punboxedfloatarray *) Cop (Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) @@ -3615,12 +3615,13 @@ let transl_attrib : Lambda.check_attribute -> Cmm.codegen_option list = function let kind_of_layout (layout : Lambda.layout) = match layout with - | Pvalue Pfloatval -> Boxed_float + | Pvalue (Pboxedfloatval Pfloat64) -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pboxedvectorval vi) -> Boxed_vector vi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_vector _ - | Punboxed_product _ -> + | Ptop | Pbottom + | Punboxed_float Pfloat64 + | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _ -> Any (* Atomics *) diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 479b1f5f39e..09e4a8c5745 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -503,7 +503,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let box_return_value = match prim_native_repr_res with | _, Same_as_ocaml_repr _ -> None - | _, Unboxed_float -> Some (P.Box_number (Naked_float, alloc_mode)) + | _, Unboxed_float Pfloat64 -> Some (P.Box_number (Naked_float, alloc_mode)) | _, Unboxed_integer Pnativeint -> Some (P.Box_number (Naked_nativeint, alloc_mode)) | _, Unboxed_integer Pint32 -> Some (P.Box_number (Naked_int32, alloc_mode)) @@ -531,7 +531,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds kind (from_lambda_values_and_unboxed_numbers_only (Typeopt.layout_of_const_sort sort))) - | Unboxed_float -> K.naked_float + | Unboxed_float Pfloat64 -> K.naked_float | Unboxed_integer Pnativeint -> K.naked_nativeint | Unboxed_integer Pint32 -> K.naked_int32 | Unboxed_integer Pint64 -> K.naked_int64 @@ -577,7 +577,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds then Misc.fatal_errorf "Expected arity one for %s" prim_native_name else match prim_native_repr_args, prim_native_repr_res with - | [(_, Unboxed_integer Pint64)], (_, Unboxed_float) -> ( + | [(_, Unboxed_integer Pint64)], (_, Unboxed_float Pfloat64) -> ( match args with | [arg] -> let result = Variable.create "reinterpreted_int64" in @@ -620,7 +620,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds let unbox_arg : P.unary_primitive option = match arg_repr with | _, Same_as_ocaml_repr _ -> None - | _, Unboxed_float -> Some (P.Unbox_number Naked_float) + | _, Unboxed_float Pfloat64 -> Some (P.Unbox_number Naked_float) | _, Unboxed_integer Pnativeint -> Some (P.Unbox_number Naked_nativeint) | _, Unboxed_integer Pint32 -> Some (P.Unbox_number Naked_int32) @@ -808,29 +808,40 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints - | Pcompare_floats | Pcompare_bints _ | Poffsetint _ | Poffsetref _ - | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ - | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ - | Punboxed_float_comp _ | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ - | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pbintofint _ - | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ - | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ - | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ - | Punboxed_int_comp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ - | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ - | Pstring_load_128 _ | Pbytes_load_16 _ | Pbytes_load_32 _ - | Pbytes_load_64 _ | Pbytes_load_128 _ | Pbytes_set_16 _ | Pbytes_set_32 _ - | Pbytes_set_64 _ | Pbytes_set_128 _ | Pbigstring_load_16 _ - | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_load_128 _ - | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ - | Pbigstring_set_128 _ | Pctconst _ | Pbswap16 | Pbbswap _ - | Pint_as_pointer _ | Popaque _ | Pprobe_is_enabled _ | Pobj_dup - | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Pmake_unboxed_product _ | Punboxed_product_field _ | Pget_header _ - | Prunstack | Pperform | Presume | Preperform | Patomic_exchange - | Patomic_cas | Patomic_fetch_add | Pdls_get | Patomic_load _ -> + | Pcompare_floats Pfloat64 + | Pcompare_bints _ | Poffsetint _ | Poffsetref _ + | Pintoffloat Pfloat64 + | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) + | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) + | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) + | Pdivfloat (Pfloat64, _) + | Pfloatcomp (Pfloat64, _) + | Punboxed_float_comp (Pfloat64, _) + | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu + | Pbytessetu | Pbytesrefs | Pbytessets | Pduparray _ | Parraylength _ + | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ + | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ + | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ + | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ + | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _ | Pbigarrayref _ + | Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _ + | Pstring_load_64 _ | Pstring_load_128 _ | Pbytes_load_16 _ + | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ + | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pctconst _ | Pbswap16 + | Pbbswap _ | Pint_as_pointer _ | Popaque _ | Pprobe_is_enabled _ + | Pobj_dup | Pobj_magic _ + | Punbox_float Pfloat64 + | Pbox_float (Pfloat64, _) + | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ + | Punboxed_product_field _ | Pget_header _ | Prunstack | Pperform + | Presume | Preperform | Patomic_exchange | Patomic_cas + | Patomic_fetch_add | Pdls_get | Patomic_load _ -> (* Inconsistent with outer match *) assert false in diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 664d3f972b0..443c14802e2 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -272,22 +272,26 @@ let transform_primitive env (prim : L.primitive) args loc = Misc.fatal_errorf "Pmakeblock with wrong or non-scannable block tag %d" tag | Pmakefloatblock (_mut, _mode), args when List.length args < 1 -> Misc.fatal_errorf "Pmakefloatblock must have at least one argument" - | Pfloatcomp CFnlt, args -> - Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFlt, args, loc)], loc) - | Pfloatcomp CFngt, args -> - Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFgt, args, loc)], loc) - | Pfloatcomp CFnle, args -> - Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFle, args, loc)], loc) - | Pfloatcomp CFnge, args -> - Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFge, args, loc)], loc) - | Punboxed_float_comp CFnlt, args -> - Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFlt, args, loc)], loc) - | Punboxed_float_comp CFngt, args -> - Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFgt, args, loc)], loc) - | Punboxed_float_comp CFnle, args -> - Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFle, args, loc)], loc) - | Punboxed_float_comp CFnge, args -> - Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFge, args, loc)], loc) + | Pfloatcomp (bf, CFnlt), args -> + Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFlt), args, loc)], loc) + | Pfloatcomp (bf, CFngt), args -> + Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFgt), args, loc)], loc) + | Pfloatcomp (bf, CFnle), args -> + Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFle), args, loc)], loc) + | Pfloatcomp (bf, CFnge), args -> + Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFge), args, loc)], loc) + | Punboxed_float_comp (bf, CFnlt), args -> + Primitive + (L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFlt), args, loc)], loc) + | Punboxed_float_comp (bf, CFngt), args -> + Primitive + (L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFgt), args, loc)], loc) + | Punboxed_float_comp (bf, CFnle), args -> + Primitive + (L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFle), args, loc)], loc) + | Punboxed_float_comp (bf, CFnge), args -> + Primitive + (L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFge), args, loc)], loc) | Pbigarrayref (_unsafe, num_dimensions, kind, layout), args -> ( match P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout @@ -605,14 +609,23 @@ let primitive_can_raise (prim : Lambda.primitive) = | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pmakeufloatblock _ | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats - | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ - | Pdivfloat _ | Pfloatcomp _ | Punboxed_float_comp _ | Pstringlength - | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu | Pmakearray _ - | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ - | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ - | Psubbint _ | Pmulbint _ + | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints + | Pcompare_floats Pfloat64 + | Pcompare_bints _ | Poffsetint _ | Poffsetref _ + | Pintoffloat Pfloat64 + | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) + | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) + | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) + | Pdivfloat (Pfloat64, _) + | Pfloatcomp (Pfloat64, _) + | Punboxed_float_comp (Pfloat64, _) + | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu + | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ + | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ + | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint { is_safe = Unsafe; _ } | Pmodbint { is_safe = Unsafe; _ } | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ @@ -654,7 +667,9 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbigstring_set_64 true | Pbigstring_set_128 { unsafe = true; _ } | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque _ - | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float + | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ + | Pbox_float (Pfloat64, _) + | Punbox_float Pfloat64 | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ | Punboxed_product_field _ | Pget_header _ -> false @@ -848,7 +863,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) match layout with | Ptop | Pbottom -> Misc.fatal_error "Cannot bind layout [Ptop] or [Pbottom]" - | Pvalue _ | Punboxed_int _ | Punboxed_float | Punboxed_vector _ -> + | Pvalue _ | Punboxed_int _ + | Punboxed_float Pfloat64 + | Punboxed_vector _ -> ( env, [ ( id, Flambda_kind.With_subkind @@ -971,8 +988,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let id = Ident.create_local name in let result_layout = L.primitive_result_layout prim in (match result_layout with - | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _ - | Punboxed_product _ -> + | Pvalue _ + | Punboxed_float Pfloat64 + | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _ -> () | Ptop | Pbottom -> Misc.fatal_errorf "Invalid result layout %a for primitive %a" diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index 430253a1b35..3e31b24d5a0 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -128,7 +128,7 @@ let convert_array_kind (kind : L.array_kind) : converted_array_kind = Float_array_opt_dynamic | Paddrarray -> Array_kind Values | Pintarray -> Array_kind Immediates - | Pfloatarray | Punboxedfloatarray -> Array_kind Naked_floats + | Pfloatarray | Punboxedfloatarray Pfloat64 -> Array_kind Naked_floats | Punboxedintarray Pint32 -> Array_kind Naked_int32s | Punboxedintarray Pint64 -> Array_kind Naked_int64s | Punboxedintarray Pnativeint -> Array_kind Naked_nativeints @@ -168,7 +168,7 @@ let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind | Paddrarray_ref -> Array_ref_kind Values | Pintarray_ref -> Array_ref_kind Immediates | Pfloatarray_ref mode -> Array_ref_kind (Naked_floats_to_be_boxed mode) - | Punboxedfloatarray_ref -> Array_ref_kind Naked_floats + | Punboxedfloatarray_ref Pfloat64 -> Array_ref_kind Naked_floats | Punboxedintarray_ref Pint32 -> Array_ref_kind Naked_int32s | Punboxedintarray_ref Pint64 -> Array_ref_kind Naked_int64s | Punboxedintarray_ref Pnativeint -> Array_ref_kind Naked_nativeints @@ -223,7 +223,7 @@ let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind (Values (Assignment (Alloc_mode.For_assignments.from_lambda mode))) | Pintarray_set -> Array_set_kind Immediates | Pfloatarray_set -> Array_set_kind Naked_floats_to_be_unboxed - | Punboxedfloatarray_set -> Array_set_kind Naked_floats + | Punboxedfloatarray_set Pfloat64 -> Array_set_kind Naked_floats | Punboxedintarray_set Pint32 -> Array_set_kind Naked_int32s | Punboxedintarray_set Pint64 -> Array_set_kind Naked_int64s | Punboxedintarray_set Pnativeint -> Array_set_kind Naked_nativeints @@ -252,7 +252,7 @@ let convert_array_kind_to_duplicate_array_kind (kind : L.array_kind) : Float_array_opt_dynamic | Paddrarray -> Duplicate_array_kind Values | Pintarray -> Duplicate_array_kind Immediates - | Pfloatarray | Punboxedfloatarray -> + | Pfloatarray | Punboxedfloatarray Pfloat64 -> Duplicate_array_kind (Naked_floats { length = None }) | Punboxedintarray Pint32 -> Duplicate_array_kind (Naked_int32s { length = None }) @@ -846,7 +846,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Array_kind array_kind -> let args = match lambda_array_kind with - | Pgenarray | Paddrarray | Pintarray | Punboxedfloatarray + | Pgenarray | Paddrarray | Pintarray + | Punboxedfloatarray Pfloat64 | Punboxedintarray (Pint32 | Pint64 | Pnativeint) -> args | Pfloatarray -> List.map unbox_float args @@ -932,48 +933,48 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [ tag_int (Binary (convert_boxed_integer_comparison_prim kind comp, arg1, arg2)) ] - | Pintoffloat, [[arg]] -> + | Pintoffloat Pfloat64, [[arg]] -> let src = K.Standard_int_or_float.Naked_float in let dst = K.Standard_int_or_float.Tagged_immediate in [Unary (Num_conv { src; dst }, unbox_float arg)] - | Pfloatofint mode, [[arg]] -> + | Pfloatofint (Pfloat64, mode), [[arg]] -> let src = K.Standard_int_or_float.Tagged_immediate in let dst = K.Standard_int_or_float.Naked_float in [box_float mode (Unary (Num_conv { src; dst }, arg)) ~current_region] - | Pnegfloat mode, [[arg]] -> + | Pnegfloat (Pfloat64, mode), [[arg]] -> [box_float mode (Unary (Float_arith Neg, unbox_float arg)) ~current_region] - | Pabsfloat mode, [[arg]] -> + | Pabsfloat (Pfloat64, mode), [[arg]] -> [box_float mode (Unary (Float_arith Abs, unbox_float arg)) ~current_region] - | Paddfloat mode, [[arg1]; [arg2]] -> + | Paddfloat (Pfloat64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith Add, unbox_float arg1, unbox_float arg2)) ~current_region ] - | Psubfloat mode, [[arg1]; [arg2]] -> + | Psubfloat (Pfloat64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith Sub, unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pmulfloat mode, [[arg1]; [arg2]] -> + | Pmulfloat (Pfloat64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith Mul, unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pdivfloat mode, [[arg1]; [arg2]] -> + | Pdivfloat (Pfloat64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith Div, unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pfloatcomp comp, [[arg1]; [arg2]] -> + | Pfloatcomp (Pfloat64, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Yielding_bool (convert_float_comparison comp)), unbox_float arg1, unbox_float arg2 )) ] - | Punboxed_float_comp comp, [[arg1]; [arg2]] -> + | Punboxed_float_comp (Pfloat64, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Yielding_bool (convert_float_comparison comp)), arg1, arg2 )) ] - | Punbox_float, [[arg]] -> [Unary (Unbox_number Naked_float, arg)] - | Pbox_float mode, [[arg]] -> + | Punbox_float Pfloat64, [[arg]] -> [Unary (Unbox_number Naked_float, arg)] + | Pbox_float (Pfloat64, mode), [[arg]] -> [ Unary ( Box_number ( Naked_float, @@ -1485,7 +1486,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) (Tagged_immediate, Yielding_int_like_compare_functions Signed), i1, i2 )) ] - | Pcompare_floats, [[f1]; [f2]] -> + | Pcompare_floats Pfloat64, [[f1]; [f2]] -> [ tag_int (Binary ( Float_comp (Yielding_int_like_compare_functions ()), @@ -1530,14 +1531,19 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) %a (%a)" Printlambda.primitive prim H.print_list_of_simple_or_prim (List.flatten args) - | ( ( Pfield _ | Pnegint | Pnot | Poffsetint _ | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ | Pstringlength | Pbyteslength | Pbintofint _ - | Pintofbint _ | Pnegbint _ | Popaque _ | Pduprecord _ | Parraylength _ - | Pduparray _ | Pfloatfield _ | Pcvtbint _ | Poffsetref _ | Pbswap16 - | Pbbswap _ | Pisint _ | Pint_as_pointer _ | Pbigarraydim _ | Pobj_dup - | Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ - | Punboxed_product_field _ | Pget_header _ | Pufloatfield _ - | Patomic_load _ ), + | ( ( Pfield _ | Pnegint | Pnot | Poffsetint _ + | Pintoffloat Pfloat64 + | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) + | Pabsfloat (Pfloat64, _) + | Pstringlength | Pbyteslength | Pbintofint _ | Pintofbint _ | Pnegbint _ + | Popaque _ | Pduprecord _ | Parraylength _ | Pduparray _ | Pfloatfield _ + | Pcvtbint _ | Poffsetref _ | Pbswap16 | Pbbswap _ | Pisint _ + | Pint_as_pointer _ | Pbigarraydim _ | Pobj_dup | Pobj_magic _ + | Punbox_float Pfloat64 + | Pbox_float (Pfloat64, _) + | Punbox_int _ | Pbox_int _ | Punboxed_product_field _ | Pget_header _ + | Pufloatfield _ | Patomic_load _ ), ([] | _ :: _ :: _ | [([] | _ :: _ :: _)]) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for unary primitive \ @@ -1545,24 +1551,32 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) Printlambda.primitive prim H.print_list_of_lists_of_simple_or_prim args | ( ( Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pdivint _ | Pmodint _ | Psetfield _ | Pintcomp _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ - | Punboxed_float_comp _ | Pstringrefu | Pbytesrefu | Pstringrefs - | Pbytesrefs | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ - | Pstring_load_128 _ | Pbytes_load_16 _ | Pbytes_load_32 _ - | Pbytes_load_64 _ | Pbytes_load_128 _ | Pisout | Paddbint _ | Psubbint _ - | Pmulbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ - | Plsrbint _ | Pasrbint _ | Pfield_computed _ | Pdivbint _ | Pmodbint _ + | Paddfloat (Pfloat64, _) + | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) + | Pdivfloat (Pfloat64, _) + | Pfloatcomp (Pfloat64, _) + | Punboxed_float_comp (Pfloat64, _) + | Pstringrefu | Pbytesrefu | Pstringrefs | Pbytesrefs | Pstring_load_16 _ + | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ + | Pbytes_load_128 _ | Pisout | Paddbint _ | Psubbint _ | Pmulbint _ + | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ + | Pasrbint _ | Pfield_computed _ | Pdivbint _ | Pmodbint _ | Psetfloatfield _ | Psetufloatfield _ | Pbintcomp _ | Punboxed_int_comp _ | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_load_128 _ | Parrayrefu ( Pgenarray_ref _ | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref | Punboxedintarray_ref _ ) + | Punboxedfloatarray_ref Pfloat64 + | Punboxedintarray_ref _ ) | Parrayrefs ( Pgenarray_ref _ | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref | Punboxedintarray_ref _ ) - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ | Patomic_exchange - | Patomic_fetch_add ), + | Punboxedfloatarray_ref Pfloat64 + | Punboxedintarray_ref _ ) + | Pcompare_ints + | Pcompare_floats Pfloat64 + | Pcompare_bints _ | Patomic_exchange | Patomic_fetch_add ), ( [] | [_] | _ :: _ :: _ :: _ @@ -1575,10 +1589,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | ( ( Psetfield_computed _ | Pbytessetu | Pbytessets | Parraysetu ( Pgenarray_set _ | Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set | Punboxedintarray_set _ ) + | Punboxedfloatarray_set Pfloat64 + | Punboxedintarray_set _ ) | Parraysets ( Pgenarray_set _ | Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set | Punboxedintarray_set _ ) + | Punboxedfloatarray_set Pfloat64 + | Punboxedintarray_set _ ) | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Patomic_cas ), diff --git a/middle_end/flambda2/kinds/flambda_arity.ml b/middle_end/flambda2/kinds/flambda_arity.ml index a9ce63c95d9..0aa2ea6ce7f 100644 --- a/middle_end/flambda2/kinds/flambda_arity.ml +++ b/middle_end/flambda2/kinds/flambda_arity.ml @@ -73,7 +73,7 @@ module Component_for_creation = struct let rec from_lambda (layout : Lambda.layout) = match layout with | Pvalue vk -> Singleton (KS.from_lambda_value_kind vk) - | Punboxed_float -> Singleton KS.naked_float + | Punboxed_float Pfloat64 -> Singleton KS.naked_float | Punboxed_int Pint32 -> Singleton KS.naked_int32 | Punboxed_int Pint64 -> Singleton KS.naked_int64 | Punboxed_int Pnativeint -> Singleton KS.naked_nativeint diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index 244a922498b..d53ccab2ba5 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -68,7 +68,7 @@ let to_lambda (t : t) : Lambda.layout = | Value -> Pvalue Pgenval | Naked_number Naked_immediate -> Misc.fatal_error "Can't convert kind [Naked_immediate] to lambda layout" - | Naked_number Naked_float -> Punboxed_float + | Naked_number Naked_float -> Punboxed_float Pfloat64 | Naked_number Naked_int32 -> Punboxed_int Pint32 | Naked_number Naked_int64 -> Punboxed_int Pint64 | Naked_number Naked_nativeint -> Punboxed_int Pnativeint @@ -551,7 +551,7 @@ module With_subkind = struct let rec from_lambda_value_kind (vk : Lambda.value_kind) = match vk with | Pgenval -> any_value - | Pfloatval -> boxed_float + | Pboxedfloatval Pfloat64 -> boxed_float | Pboxedintval Pint32 -> boxed_int32 | Pboxedintval Pint64 -> boxed_int64 | Pboxedintval Pnativeint -> boxed_nativeint @@ -586,7 +586,7 @@ module With_subkind = struct | Parrayval Pintarray -> immediate_array | Parrayval Paddrarray -> value_array | Parrayval Pgenarray -> generic_array - | Parrayval Punboxedfloatarray -> float_array + | Parrayval (Punboxedfloatarray Pfloat64) -> float_array | Parrayval (Punboxedintarray Pint32) -> unboxed_int32_array | Parrayval (Punboxedintarray Pint64) -> unboxed_int64_array | Parrayval (Punboxedintarray Pnativeint) -> unboxed_nativeint_array @@ -594,7 +594,7 @@ module With_subkind = struct let from_lambda_values_and_unboxed_numbers_only (layout : Lambda.layout) = match layout with | Pvalue vk -> from_lambda_value_kind vk - | Punboxed_float -> naked_float + | Punboxed_float Pfloat64 -> naked_float | Punboxed_int Pint32 -> naked_int32 | Punboxed_int Pint64 -> naked_int64 | Punboxed_int Pnativeint -> naked_nativeint diff --git a/middle_end/flambda2/term_basics/empty_array_kind.ml b/middle_end/flambda2/term_basics/empty_array_kind.ml index 26606c162d6..a95a05875ee 100644 --- a/middle_end/flambda2/term_basics/empty_array_kind.ml +++ b/middle_end/flambda2/term_basics/empty_array_kind.ml @@ -46,7 +46,8 @@ let of_element_kind t = let of_lambda array_kind = match (array_kind : Lambda.array_kind) with - | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray -> + | Pgenarray | Paddrarray | Pintarray | Pfloatarray + | Punboxedfloatarray Pfloat64 -> Values_or_immediates_or_naked_floats | Punboxedintarray Pint32 -> Naked_int32s | Punboxedintarray Pint64 -> Naked_int64s diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 97183c33c56..b80ba800985 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -928,13 +928,14 @@ module Extended_machtype = struct | Ptop -> Misc.fatal_error "No Extended_machtype for layout [Ptop]" | Pbottom -> Misc.fatal_error "No unique Extended_machtype for layout [Pbottom]" - | Punboxed_float -> typ_float + | Punboxed_float Pfloat64 -> typ_float | Punboxed_int _ -> (* Only 64-bit architectures, so this is always [typ_int] *) typ_any_int | Pvalue Pintval -> typ_tagged_int | Punboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." | Pvalue _ -> typ_val | Punboxed_product _ -> failwith "TODO" end @@ -2509,7 +2510,7 @@ let arraylength kind arg dbg = Cop(Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) | Pfloatarray -> Cop(Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) - | Punboxedfloatarray | Punboxedintarray _ -> + | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> Misc.fatal_errorf "Unboxed arrays not supported" let bbswap bi arg dbg = @@ -2701,7 +2702,7 @@ let arrayref_unsafe rkind arg1 arg2 dbg = int_array_ref arg1 arg2 dbg | Pfloatarray_ref mode -> float_array_ref mode arg1 arg2 dbg - | Punboxedfloatarray_ref | Punboxedintarray_ref _ -> + | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _ -> Misc.fatal_errorf "Unboxed arrays not supported" let arrayref_safe rkind arg1 arg2 dbg = @@ -2756,7 +2757,7 @@ let arrayref_safe rkind arg1 arg2 dbg = (get_header_masked arr dbg) dbg; idx], unboxed_float_array_ref arr idx dbg)))) - | Punboxedfloatarray_ref | Punboxedintarray_ref _ -> + | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _ -> Misc.fatal_errorf "Unboxed arrays not supported" type ternary_primitive = @@ -2808,7 +2809,7 @@ let arrayset_unsafe skind arg1 arg2 arg3 dbg = int_array_set arg1 arg2 arg3 dbg | Pfloatarray_set -> float_array_set arg1 arg2 arg3 dbg - | Punboxedfloatarray_set | Punboxedintarray_set _ -> + | Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _ -> Misc.fatal_errorf "Unboxed arrays not supported" ) @@ -2873,7 +2874,7 @@ let arrayset_safe skind arg1 arg2 arg3 dbg = (get_header_masked arr dbg) dbg; idx], float_array_set arr idx newval dbg)))) - | Punboxedfloatarray_set | Punboxedintarray_set _ -> + | Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _ -> Misc.fatal_errorf "Unboxed arrays not supported" ) @@ -3205,12 +3206,14 @@ let emit_preallocated_blocks preallocated_blocks cont = let kind_of_layout (layout : Lambda.layout) = match layout with - | Pvalue Pfloatval -> Boxed_float + | Pvalue (Pboxedfloatval Pfloat64) -> Boxed_float | Pvalue (Pboxedintval bi) -> Boxed_integer bi | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _) - | Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_product _ -> Any + | Ptop | Pbottom | Punboxed_float Pfloat64 + | Punboxed_int _ | Punboxed_product _ -> Any | Pvalue (Pboxedvectorval _) | Punboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." let make_tuple l = match l with [e] -> e | _ -> Ctuple l diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index 7a24fcce15e..08ceefd3956 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/asmcomp/cmmgen.ml @@ -136,9 +136,10 @@ let get_field env mut layout ptr n dbg = match layout with | Pvalue Pintval | Punboxed_int _ -> Word_int | Pvalue _ -> Word_val - | Punboxed_float -> Double + | Punboxed_float Pfloat64 -> Double | Punboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." | Punboxed_product _ -> Misc.fatal_error "TODO" | Ptop -> Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg @@ -656,9 +657,11 @@ let rec transl env e = | Patomic_cas | Patomic_fetch_add | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint - | Plsrint | Pasrint | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pstringlength | Pstringrefu + | Plsrint | Pasrint | Pintoffloat Pfloat64 | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) + | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets | Pisint | Pisout | Pbswap16 | Pint_as_pointer _ | Popaque | Pfield _ @@ -666,15 +669,15 @@ let rec transl env e = | Pfloatfield _ | Psetfloatfield (_, _) | Pduprecord (_, _) | Pufloatfield _ | Psetufloatfield (_, _) | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ | Poffsetint _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _ | Parraylength _ - | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ + | Poffsetref _ | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) + | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) | Punboxed_int_comp (_, _) | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ - | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Punbox_float Pfloat64 | Pbox_float (Pfloat64, _) | Punbox_int _ | Pbox_int _ | Pbbswap _ | Pget_header _), _) -> fatal_error "Cmmgen.transl:prim" @@ -873,14 +876,14 @@ and transl_make_array dbg env kind mode args = | Pfloatarray -> make_float_alloc ~mode dbg Obj.double_array_tag (List.map (transl_unbox_float dbg env) args) - | Punboxedfloatarray | Punboxedintarray _ -> + | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> Misc.fatal_errorf "Unboxed arrays not supported" and transl_ccall env prim args dbg = let transl_arg native_repr arg = match native_repr with | Same_as_ocaml_repr sort -> (exttype_of_sort sort, transl env arg) - | Unboxed_float -> + | Unboxed_float Pfloat64 -> (XFloat, transl_unbox_float dbg env arg) | Unboxed_integer bi -> let xty = @@ -890,7 +893,8 @@ and transl_ccall env prim args dbg = | Pint64 -> XInt64 in (xty, transl_unbox_int dbg env bi arg) | Unboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." | Untagged_int -> (XInt, untag_int (transl env arg) dbg) in @@ -911,11 +915,12 @@ and transl_ccall env prim args dbg = match prim.prim_native_repr_res with | _, Same_as_ocaml_repr sort -> (machtype_of_sort sort, fun x -> x) (* TODO: Allow Alloc_local on suitably typed C stubs *) - | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap) + | _, Unboxed_float Pfloat64 -> (typ_float, box_float dbg alloc_heap) | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap) | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg)) | _, Unboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." in let typ_args, args = transl_args prim.prim_native_repr_args args in wrap_result @@ -934,7 +939,7 @@ and transl_prim_1 env p arg dbg = let ptr = transl env arg in box_float dbg mode (floatfield n ptr dbg) | Pufloatfield n -> - get_field env Mutable Punboxed_float (transl env arg) n dbg + get_field env Mutable (Punboxed_float Pfloat64) (transl env arg) n dbg | Pint_as_pointer _ -> int_as_pointer (transl env arg) dbg (* Exceptions *) @@ -952,17 +957,17 @@ and transl_prim_1 env p arg dbg = | Pbox_int (bi, m) -> box_int dbg bi m (transl env arg) (* Floating-point operations *) - | Punbox_float -> + | Punbox_float Pfloat64 -> transl_unbox_float dbg env arg - | Pbox_float m -> + | Pbox_float (Pfloat64, m) -> box_float dbg m (transl env arg) - | Pfloatofint m -> + | Pfloatofint (Pfloat64, m) -> box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg)) - | Pintoffloat -> + | Pintoffloat Pfloat64 -> tag_int(Cop(Cintoffloat, [transl_unbox_float dbg env arg], dbg)) dbg - | Pnegfloat m -> + | Pnegfloat (Pfloat64, m) -> box_float dbg m (Cop(Cnegf, [transl_unbox_float dbg env arg], dbg)) - | Pabsfloat m -> + | Pabsfloat (Pfloat64, m) -> box_float dbg m (Cop(Cabsf, [transl_unbox_float dbg env arg], dbg)) (* String operations *) | Pstringlength | Pbyteslength -> @@ -1020,15 +1025,16 @@ and transl_prim_1 env p arg dbg = | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) | Pstringrefu | Pstringrefs | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets | Pisout | Pread_symbol _ | Pmakeblock (_, _, _, _) | Psetfield (_, _, _) | Psetfield_computed (_, _) | Pmakeufloatblock (_, _) | Psetfloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Pdivint _ | Psetufloatfield (_, _) - | Pmodint _ | Pintcomp _ | Pfloatcomp _ | Punboxed_float_comp _ | Pmakearray (_, _, _) - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pmodint _ | Pintcomp _ | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) + | Pmakearray (_, _, _) | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ | Pduparray (_, _) | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ @@ -1105,39 +1111,39 @@ and transl_prim_2 env p arg1 arg2 dbg = let a1 = transl_unbox_int dbg env bi arg1 in let a2 = transl_unbox_int dbg env bi arg2 in mk_compare_ints dbg a1 a2 - | Pcompare_floats -> + | Pcompare_floats Pfloat64 -> let a1 = transl_unbox_float dbg env arg1 in let a2 = transl_unbox_float dbg env arg2 in mk_compare_floats dbg a1 a2 | Pisout -> transl_isout (transl env arg1) (transl env arg2) dbg (* Float operations *) - | Paddfloat m -> + | Paddfloat (Pfloat64, m) -> box_float dbg m (Cop(Caddf, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) - | Psubfloat m -> + | Psubfloat (Pfloat64, m) -> box_float dbg m (Cop(Csubf, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) - | Pmulfloat m -> + | Pmulfloat (Pfloat64, m) -> box_float dbg m (Cop(Cmulf, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) - | Pdivfloat m -> + | Pdivfloat (Pfloat64, m) -> box_float dbg m (Cop(Cdivf, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) - | Pfloatcomp cmp -> + | Pfloatcomp (Pfloat64, cmp) -> tag_int(Cop(Ccmpf cmp, [transl_unbox_float dbg env arg1; transl_unbox_float dbg env arg2], dbg)) dbg - | Punboxed_float_comp cmp -> + | Punboxed_float_comp (Pfloat64, cmp) -> tag_int(Cop(Ccmpf cmp, [transl env arg1; transl env arg2], @@ -1223,8 +1229,9 @@ and transl_prim_2 env p arg1 arg2 dbg = [transl env arg1; transl env arg2], dbg) | Prunstack | Pperform | Presume | Preperform | Pdls_get | Patomic_cas | Patomic_load _ - | Pnot | Pnegint | Pintoffloat | Pfloatofint _ | Pnegfloat _ - | Pabsfloat _ | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets + | Pnot | Pnegint | Pintoffloat Pfloat64 | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Pstringlength | Pbyteslength | Pbytessetu | Pbytessets | Pisint | Pbswap16 | Pint_as_pointer _ | Popaque | Pread_symbol _ | Pmakeblock (_, _, _, _) | Pfield _ | Psetfield_computed (_, _) | Pmakeufloatblock (_, _) | Pfloatfield _ | Pufloatfield _ @@ -1234,7 +1241,8 @@ 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 _ | Pget_header _ + | Punbox_float Pfloat64 | Pbox_float (Pfloat64, _) + | Punbox_int _ | Pbox_int _ | Pget_header _ -> fatal_errorf "Cmmgen.transl_prim_2: %a" Printclambda_primitives.primitive p @@ -1317,16 +1325,18 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = | Patomic_exchange | Patomic_fetch_add | Patomic_load _ | Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ - | Pmulfloat _ | Pdivfloat _ | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytesrefs | Pisint | Pisout - | Pbswap16 | Pint_as_pointer _ | Popaque | Pread_symbol _ + | Pintoffloat Pfloat64 | Pfloatofint (Pfloat64, _) | Pnegfloat (Pfloat64, _) + | Pabsfloat (Pfloat64, _) | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) | Pstringlength + | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytesrefs | Pisint + | Pisout | Pbswap16 | Pint_as_pointer _ | Popaque | Pread_symbol _ | Pmakeblock (_, _, _, _) | Pfield _ | Psetfield (_, _, _) | Pfloatfield _ | Psetfloatfield (_, _) | Pmakeufloatblock (_, _) | Pufloatfield _ | Psetufloatfield (_, _) | Pduprecord (_, _) | Pccall _ | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Punboxed_float_comp _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ + | Poffsetint _ | Poffsetref _ + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pmakearray (_, _, _) | Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _ | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ @@ -1336,7 +1346,8 @@ 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 _ | Pget_header _ + | Punbox_float Pfloat64 | Pbox_float (Pfloat64, _) + | Punbox_int _ | Pbox_int _ | Pget_header _ -> fatal_errorf "Cmmgen.transl_prim_3: %a" Printclambda_primitives.primitive p @@ -1372,13 +1383,14 @@ and transl_let_value env str (kind : Lambda.value_kind) id exp transl_body = We conservatively mark these as Alloc_heap, although with more tracking of allocation mode it may be possible to mark some Alloc_local *) match str, kind with - | Mutable, Pfloatval -> + | Mutable, Pboxedfloatval Pfloat64 -> Boxed (Boxed_float (alloc_heap, dbg), false) | Mutable, Pboxedintval bi -> Boxed (Boxed_integer (bi, alloc_heap, dbg), false) | _, Pboxedvectorval _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." - | _, (Pfloatval | Pboxedintval _) -> + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." + | _, (Pboxedfloatval Pfloat64 | Pboxedintval _) -> (* It would be safe to always unbox in this case, but we do it only if this indeed allows us to get rid of some allocations in the bound expression. *) @@ -1425,8 +1437,9 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body = let _cbody : expression = transl_body env in cexp | Punboxed_vector _ -> - Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build." - | Punboxed_float | Punboxed_int _ -> begin + Misc.fatal_error + "SIMD vectors are not supported in the upstream compiler build." + | Punboxed_float Pfloat64 | Punboxed_int _ -> begin let cexp = transl env exp in let cbody = transl_body env in match str with diff --git a/ocaml/boot/ocamlc b/ocaml/boot/ocamlc index 049e1b831a1..4397db24e19 100755 Binary files a/ocaml/boot/ocamlc and b/ocaml/boot/ocamlc differ diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index 1ef78563a99..4dc9d44451a 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -112,7 +112,7 @@ let preserve_tailcall_for_prim = function Popaque _ | Psequor | Psequand | Pobj_magic _ | Prunstack | Pperform | Presume | Preperform - | Pbox_float _ | Punbox_float + | Pbox_float (Pfloat64, _) | Punbox_float Pfloat64 | Pbox_int _ | Punbox_int _ -> true | Pbytes_to_string | Pbytes_of_string @@ -127,11 +127,12 @@ let preserve_tailcall_for_prim = function | Pmake_unboxed_product _ | Punboxed_product_field _ | 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 _| Punboxed_float_comp _ + | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat Pfloat64 + | Pfloatofint (Pfloat64, _) | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) | Pmulfloat (Pfloat64, _) + | Pdivfloat (Pfloat64, _) | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pstringlength | Pstringrefu | Pstringrefs - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ @@ -428,7 +429,7 @@ let comp_primitive stack_info p sz args = | Pgetpredef id -> Kgetglobal id | Pintcomp cmp -> Kintcomp cmp | Pcompare_ints -> Kccall("caml_int_compare", 2) - | Pcompare_floats -> Kccall("caml_float_compare", 2) + | Pcompare_floats Pfloat64 -> Kccall("caml_float_compare", 2) | Pcompare_bints bi -> comp_bint_primitive bi "compare" args | Pfield (n, _ptr, _sem) -> Kgetfield n | Pfield_computed _sem -> Kgetvectitem @@ -459,14 +460,14 @@ let comp_primitive stack_info p sz args = | Pasrint -> Kasrint | 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) + | Pintoffloat Pfloat64 -> Kccall("caml_int_of_float", 1) + | Pfloatofint (Pfloat64, _) -> Kccall("caml_float_of_int", 1) + | Pnegfloat (Pfloat64, _) -> Kccall("caml_neg_float", 1) + | Pabsfloat (Pfloat64, _) -> Kccall("caml_abs_float", 1) + | Paddfloat (Pfloat64, _) -> Kccall("caml_add_float", 2) + | Psubfloat (Pfloat64, _) -> Kccall("caml_sub_float", 2) + | Pmulfloat (Pfloat64, _) -> Kccall("caml_mul_float", 2) + | Pdivfloat (Pfloat64, _) -> 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) @@ -492,26 +493,26 @@ let comp_primitive stack_info p sz args = | Parrayrefs (Pfloatarray_ref _) -> Kccall("caml_floatarray_get", 2) | Parrayrefs (Paddrarray_ref | Pintarray_ref) -> Kccall("caml_array_get_addr", 2) - | Parrayrefs (Punboxedfloatarray_ref | Punboxedintarray_ref _) -> + | Parrayrefs (Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p | Parraysets (Pgenarray_set _) -> Kccall("caml_array_set", 3) | Parraysets Pfloatarray_set -> Kccall("caml_floatarray_set", 3) | Parraysets (Paddrarray_set _ | Pintarray_set) -> Kccall("caml_array_set_addr", 3) - | Parraysets (Punboxedfloatarray_set | Punboxedintarray_set _) -> + | Parraysets (Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p | Parrayrefu (Pgenarray_ref _) -> Kccall("caml_array_unsafe_get", 2) | Parrayrefu (Pfloatarray_ref _) -> Kccall("caml_floatarray_unsafe_get", 2) | Parrayrefu (Paddrarray_ref | Pintarray_ref) -> Kgetvectitem - | Parrayrefu (Punboxedfloatarray_ref | Punboxedintarray_ref _) -> + | Parrayrefu (Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p | Parraysetu (Pgenarray_set _) -> Kccall("caml_array_unsafe_set", 3) | Parraysetu Pfloatarray_set -> Kccall("caml_floatarray_unsafe_set", 3) | Parraysetu (Paddrarray_set _ | Pintarray_set) -> Ksetvectitem - | Parraysetu (Punboxedfloatarray_set | Punboxedintarray_set _) -> + | Parraysetu (Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _) -> Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" Printlambda.primitive p | Pctconst c -> @@ -593,12 +594,12 @@ let comp_primitive stack_info p sz args = | Pnot | Psequand | Psequor | Praise _ | Pmakearray _ | Pduparray _ - | Pfloatcomp _ | Punboxed_float_comp _ + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pprobe_is_enabled _ - | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ + | Punbox_float Pfloat64 | Pbox_float (Pfloat64, _) | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ | Punboxed_product_field _ -> fatal_error "Bytegen.comp_primitive" @@ -777,7 +778,7 @@ let rec comp_expr stack_info env exp sz cont = end | Lprim((Popaque _ | Pobj_magic _), [arg], _) -> comp_expr stack_info env arg sz cont - | Lprim((Pbox_float _ | Punbox_float), [arg], _) -> + | Lprim((Pbox_float (Pfloat64, _) | Punbox_float Pfloat64), [arg], _) -> comp_expr stack_info env arg sz cont | Lprim((Pbox_int _ | Punbox_int _), [arg], _) -> comp_expr stack_info env arg sz cont @@ -853,7 +854,7 @@ let rec comp_expr stack_info env exp sz cont = else comp_args stack_info env args sz (Kmakeblock(List.length args, 0) :: Kccall("caml_make_array", 1) :: cont) - | Punboxedfloatarray | Punboxedintarray _ -> + | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> Misc.fatal_errorf "Cannot use Pmakeblock for unboxed arrays in bytecode" Printlambda.primitive p @@ -896,7 +897,7 @@ let rec comp_expr stack_info env exp sz cont = let nargs = List.length args - 1 in comp_args stack_info env args sz (comp_primitive stack_info p (sz + nargs - 1) args :: cont) - | Lprim (Pfloatcomp cmp, args, _) | Lprim (Punboxed_float_comp cmp, args, _) -> + | Lprim (Pfloatcomp (Pfloat64, cmp), args, _) | Lprim (Punboxed_float_comp (Pfloat64, cmp), args, _) -> let cont = match cmp with | CFeq -> Kccall("caml_eq_float", 2) :: cont diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 13db7d21382..7e13b65b39a 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -174,16 +174,22 @@ type primitive = | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of integer_comparison - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer + | Pcompare_ints + | Pcompare_floats of boxed_float + | Pcompare_bints of boxed_integer | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison + | Pintoffloat of boxed_float + | Pfloatofint of boxed_float * alloc_mode + | Pnegfloat of boxed_float * alloc_mode + | Pabsfloat of boxed_float * alloc_mode + | Paddfloat of boxed_float * alloc_mode + | Psubfloat of boxed_float * alloc_mode + | Pmulfloat of boxed_float * alloc_mode + | Pdivfloat of boxed_float * alloc_mode + | Pfloatcomp of boxed_float * float_comparison + | Punboxed_float_comp of boxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -265,8 +271,8 @@ type primitive = (* Primitives for [Obj] *) | Pobj_dup | Pobj_magic of layout - | Punbox_float - | Pbox_float of alloc_mode + | Punbox_float of boxed_float + | Pbox_float of boxed_float * alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode (* Jane Street extensions *) @@ -283,7 +289,10 @@ and float_comparison = CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + | Pgenval + | Pintval + | Pboxedfloatval of boxed_float + | Pboxedintval of boxed_integer | Pvariant of { consts : int list; non_consts : (int * value_kind list) list; @@ -294,7 +303,7 @@ and value_kind = and layout = | Ptop | Pvalue of value_kind - | Punboxed_float + | Punboxed_float of boxed_float | Punboxed_int of boxed_integer | Punboxed_vector of boxed_vector | Punboxed_product of layout list @@ -305,7 +314,7 @@ and block_shape = and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Punboxedfloatarray + | Punboxedfloatarray of unboxed_float | Punboxedintarray of unboxed_integer and array_ref_kind = @@ -313,7 +322,7 @@ and array_ref_kind = | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref of alloc_mode - | Punboxedfloatarray_ref + | Punboxedfloatarray_ref of unboxed_float | Punboxedintarray_ref of unboxed_integer and array_set_kind = @@ -321,12 +330,17 @@ and array_set_kind = | Paddrarray_set of modify_mode | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set + | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer +and boxed_float = Primitive.boxed_float = + | Pfloat64 + and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_float = boxed_float + and unboxed_integer = boxed_integer and vec128_type = @@ -371,6 +385,8 @@ let vec128_name = function let equal_boxed_integer = Primitive.equal_boxed_integer +let equal_boxed_float = Primitive.equal_boxed_float + let equal_boxed_vector_size v1 v2 = match v1, v2 with | Pvec128 _, Pvec128 _ -> true @@ -394,7 +410,7 @@ let join_boxed_vector_layout v1 v2 = let rec equal_value_kind x y = match x, y with | Pgenval, Pgenval -> true - | Pfloatval, Pfloatval -> true + | Pboxedfloatval f1, Pboxedfloatval f2 -> equal_boxed_float f1 f2 | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 | Pboxedvectorval bi1, Pboxedvectorval bi2 -> equal_boxed_vector_size bi1 bi2 @@ -413,7 +429,7 @@ let rec equal_value_kind x y = && List.length fields1 = List.length fields2 && List.for_all2 equal_value_kind fields1 fields2) non_consts1 non_consts2 - | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _ + | (Pgenval | Pboxedfloatval Pfloat64 | Pboxedintval _ | Pintval | Pvariant _ | Parrayval _ | Pboxedvectorval _), _ -> false let equal_layout x y = @@ -428,7 +444,7 @@ let rec compatible_layout x y = | Pbottom, _ | _, Pbottom -> true | Pvalue _, Pvalue _ -> true - | Punboxed_float, Punboxed_float -> true + | Punboxed_float f1, Punboxed_float f2 -> equal_boxed_float f1 f2 | Punboxed_int bi1, Punboxed_int bi2 -> equal_boxed_integer bi1 bi2 | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector_size bi1 bi2 @@ -437,7 +453,8 @@ let rec compatible_layout x y = && List.for_all2 compatible_layout layouts1 layouts2 | Ptop, Ptop -> true | Ptop, _ | _, Ptop -> false - | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _), _ -> + | (Pvalue _ | Punboxed_float Pfloat64 | Punboxed_int _ | Punboxed_vector _ | + Punboxed_product _), _ -> false let must_be_value layout = @@ -739,8 +756,8 @@ let layout_class = Pvalue Pgenval let layout_module = Pvalue Pgenval let layout_module_field = Pvalue Pgenval let layout_functor = Pvalue Pgenval -let layout_boxed_float = Pvalue Pfloatval -let layout_unboxed_float = Punboxed_float +let layout_boxed_float f = Pvalue (Pboxedfloatval f) +let layout_unboxed_float f = Punboxed_float f let layout_unboxed_nativeint = Punboxed_int Pnativeint let layout_unboxed_int32 = Punboxed_int Pint32 let layout_unboxed_int64 = Punboxed_int Pint64 @@ -1508,15 +1525,15 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ | Poffsetint _ | Poffsetref _ -> None - | Pintoffloat -> None - | Pfloatofint m -> Some m - | Pnegfloat m | Pabsfloat m - | Paddfloat m | Psubfloat m - | Pmulfloat m | Pdivfloat m -> Some m - | Pfloatcomp _ | Punboxed_float_comp _ -> None + | Pintoffloat Pfloat64 -> None + | Pfloatofint (Pfloat64, m) -> Some m + | Pnegfloat (Pfloat64, m) | Pabsfloat (Pfloat64, m) + | Paddfloat (Pfloat64, m) | Psubfloat (Pfloat64, m) + | Pmulfloat (Pfloat64, m) | Pdivfloat (Pfloat64, m) -> Some m + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) -> None | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None | Pmakearray (_, _, m) -> Some m @@ -1524,9 +1541,9 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Parraylength _ -> None | Parraysetu _ | Parraysets _ | Parrayrefu (Paddrarray_ref | Pintarray_ref - | Punboxedfloatarray_ref | Punboxedintarray_ref _) + | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _) | Parrayrefs (Paddrarray_ref | Pintarray_ref - | Punboxedfloatarray_ref | Punboxedintarray_ref _) -> None + | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _) -> None | Parrayrefu (Pgenarray_ref m | Pfloatarray_ref m) | Parrayrefs (Pgenarray_ref m | Pfloatarray_ref m) -> Some m | Pisint _ | Pisout -> None @@ -1569,8 +1586,8 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pprobe_is_enabled _ -> None | Pobj_dup -> Some alloc_heap | Pobj_magic _ -> None - | Punbox_float | Punbox_int _ -> None - | Pbox_float m | Pbox_int (_, m) -> Some m + | Punbox_float Pfloat64 | Punbox_int _ -> None + | Pbox_float (Pfloat64, m) | Pbox_int (_, m) -> Some m | Prunstack | Presume | Pperform | Preperform -> Misc.fatal_error "Effects-related primitives are not yet supported" | Patomic_load _ @@ -1588,8 +1605,8 @@ let constant_layout: constant -> layout = function | Const_unboxed_int32 _ -> Punboxed_int Pint32 | Const_unboxed_int64 _ -> Punboxed_int Pint64 | Const_unboxed_nativeint _ -> Punboxed_int Pnativeint - | Const_float _ -> Pvalue Pfloatval - | Const_unboxed_float _ -> Punboxed_float + | Const_float _ -> Pvalue (Pboxedfloatval Pfloat64) + | Const_unboxed_float _ -> Punboxed_float Pfloat64 let structured_constant_layout = function | Const_base const -> constant_layout const @@ -1599,12 +1616,12 @@ let structured_constant_layout = function let layout_of_native_repr : Primitive.native_repr -> _ = function | Untagged_int -> layout_int | Unboxed_vector v -> layout_boxed_vector v - | Unboxed_float -> layout_boxed_float + | Unboxed_float Pfloat64 -> layout_boxed_float Pfloat64 | Unboxed_integer bi -> layout_boxedint bi | Same_as_ocaml_repr s -> begin match s with | Value -> layout_any_value - | Float64 -> layout_unboxed_float + | Float64 -> layout_unboxed_float Pfloat64 | Word -> layout_unboxed_nativeint | Bits32 -> layout_unboxed_int32 | Bits64 -> layout_unboxed_int64 @@ -1613,8 +1630,8 @@ let layout_of_native_repr : Primitive.native_repr -> _ = function let array_ref_kind_result_layout = function | Pintarray_ref -> layout_int - | Pfloatarray_ref _ -> layout_boxed_float - | Punboxedfloatarray_ref -> layout_unboxed_float + | Pfloatarray_ref _ -> layout_boxed_float Pfloat64 + | Punboxedfloatarray_ref Pfloat64 -> layout_unboxed_float Pfloat64 | Pgenarray_ref _ | Paddrarray_ref -> layout_field | Punboxedintarray_ref Pint32 -> layout_unboxed_int32 | Punboxedintarray_ref Pint64 -> layout_unboxed_int64 @@ -1638,10 +1655,12 @@ let primitive_result_layout (p : primitive) = | Pfield _ | Pfield_computed _ -> layout_field | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) | Pmake_unboxed_product layouts -> layout_unboxed_product layouts - | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pbox_float _ -> layout_boxed_float - | Pufloatfield _ | Punbox_float -> Punboxed_float + | Pfloatfield _ -> layout_boxed_float Pfloat64 + | Pfloatofint (f, _) | Pnegfloat (f, _) | Pabsfloat (f, _) + | Paddfloat (f, _) | Psubfloat (f, _) | Pmulfloat (f, _) | Pdivfloat (f, _) + | Pbox_float (f, _) -> layout_boxed_float f + | Pufloatfield _ -> Punboxed_float Pfloat64 + | Punbox_float Pfloat64 -> Punboxed_float Pfloat64 | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_native_repr repr_res | Praise _ -> layout_bottom | Psequor | Psequand | Pnot @@ -1650,8 +1669,9 @@ let primitive_result_layout (p : primitive) = | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetint _ | Pintoffloat | Pfloatcomp _ | Punboxed_float_comp _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ + | Poffsetint _ | Pintoffloat Pfloat64 + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytesrefs | Parraylength _ | Pisint _ | Pisout | Pintofbint _ @@ -1678,7 +1698,7 @@ let primitive_result_layout (p : primitive) = | Pbigarrayref (_, _, kind, _) -> begin match kind with | Pbigarray_unknown -> layout_any_value - | Pbigarray_float32 | Pbigarray_float64 -> layout_boxed_float + | Pbigarray_float32 | Pbigarray_float64 -> layout_boxed_float Pfloat64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_caml_int -> layout_int @@ -1754,7 +1774,7 @@ let array_ref_kind mode = function | Pintarray -> Pintarray_ref | Pfloatarray -> Pfloatarray_ref mode | Punboxedintarray int_kind -> Punboxedintarray_ref int_kind - | Punboxedfloatarray -> Punboxedfloatarray_ref + | Punboxedfloatarray Pfloat64 -> Punboxedfloatarray_ref Pfloat64 let array_set_kind mode = function | Pgenarray -> Pgenarray_set mode @@ -1762,7 +1782,7 @@ let array_set_kind mode = function | Pintarray -> Pintarray_set | Pfloatarray -> Pfloatarray_set | Punboxedintarray int_kind -> Punboxedintarray_set int_kind - | Punboxedfloatarray -> Punboxedfloatarray_set + | Punboxedfloatarray Pfloat64 -> Punboxedfloatarray_set Pfloat64 let is_check_enabled ~opt property = match property with diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 16e63492c8f..a58ebaf82a7 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -133,16 +133,22 @@ type primitive = | Plslint | Plsrint | Pasrint | Pintcomp of integer_comparison (* Comparisons that return int (not bool like above) for ordering *) - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer + | Pcompare_ints + | Pcompare_floats of boxed_float + | Pcompare_bints of boxed_integer | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison + | Pintoffloat of boxed_float + | Pfloatofint of boxed_float * alloc_mode + | Pnegfloat of boxed_float * alloc_mode + | Pabsfloat of boxed_float * alloc_mode + | Paddfloat of boxed_float * alloc_mode + | Psubfloat of boxed_float * alloc_mode + | Pmulfloat of boxed_float * alloc_mode + | Pdivfloat of boxed_float * alloc_mode + | Pfloatcomp of boxed_float * float_comparison + | Punboxed_float_comp of boxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -227,8 +233,8 @@ type primitive = (* Primitives for [Obj] *) | Pobj_dup | Pobj_magic of layout - | Punbox_float - | Pbox_float of alloc_mode + | Punbox_float of boxed_float + | Pbox_float of boxed_float * alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode (* Jane Street extensions *) @@ -252,7 +258,7 @@ and float_comparison = and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Punboxedfloatarray + | Punboxedfloatarray of unboxed_float | Punboxedintarray of unboxed_integer (** When accessing a flat float array, we need to know the mode which we should @@ -262,7 +268,7 @@ and array_ref_kind = | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref of alloc_mode - | Punboxedfloatarray_ref + | Punboxedfloatarray_ref of unboxed_float | Punboxedintarray_ref of unboxed_integer (** When updating an array that might contain pointers, we need to know what @@ -272,11 +278,14 @@ and array_set_kind = | Paddrarray_set of modify_mode | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set + | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + | Pgenval + | Pintval + | Pboxedfloatval of boxed_float + | Pboxedintval of boxed_integer | Pvariant of { consts : int list; non_consts : (int * value_kind list) list; @@ -292,7 +301,7 @@ and value_kind = and layout = | Ptop | Pvalue of value_kind - | Punboxed_float + | Punboxed_float of boxed_float | Punboxed_int of boxed_integer | Punboxed_vector of boxed_vector | Punboxed_product of layout list @@ -301,9 +310,14 @@ and layout = and block_shape = value_kind list option +and boxed_float = Primitive.boxed_float = + | Pfloat64 + and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_float = boxed_float + and unboxed_integer = boxed_integer and vec128_type = @@ -347,6 +361,8 @@ val equal_layout : layout -> layout -> bool val compatible_layout : layout -> layout -> bool +val equal_boxed_float : boxed_float -> boxed_float -> bool + val equal_boxed_integer : boxed_integer -> boxed_integer -> bool val equal_boxed_vector_size : boxed_vector -> boxed_vector -> bool @@ -625,8 +641,8 @@ val layout_module : layout val layout_functor : layout val layout_module_field : layout val layout_string : layout -val layout_boxed_float : layout -val layout_unboxed_float : layout +val layout_boxed_float : boxed_float -> layout +val layout_unboxed_float : boxed_float -> layout val layout_boxedint : boxed_integer -> layout val layout_boxed_vector : Primitive.boxed_vector -> layout (* A layout that is Pgenval because it is the field of a block *) diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 300957cea34..a8632708fa8 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -2870,13 +2870,13 @@ let combine_constant value_kind loc arg cst partial ctx def let hs, sw, fail = share_actions_tree value_kind sw fail in hs (Lstringswitch (arg, sw, fail, loc, value_kind)) | Const_float _ -> - make_test_sequence value_kind loc fail (Pfloatcomp CFneq) - (Pfloatcomp CFlt) arg + make_test_sequence value_kind loc fail (Pfloatcomp (Pfloat64, CFneq)) + (Pfloatcomp (Pfloat64, CFlt)) arg const_lambda_list | Const_unboxed_float _ -> make_test_sequence value_kind loc fail - (Punboxed_float_comp CFneq) - (Punboxed_float_comp CFlt) + (Punboxed_float_comp (Pfloat64, CFneq)) + (Punboxed_float_comp (Pfloat64, CFlt)) arg const_lambda_list | Const_int32 _ -> make_test_sequence value_kind loc fail diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index a820284a176..89891c82724 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -60,7 +60,7 @@ let array_kind = function | Paddrarray -> "addr" | Pintarray -> "int" | Pfloatarray -> "float" - | Punboxedfloatarray -> "unboxed_float" + | Punboxedfloatarray Pfloat64 -> "unboxed_float" | Punboxedintarray Pint32 -> "unboxed_int32" | Punboxedintarray Pint64 -> "unboxed_int64" | Punboxedintarray Pnativeint -> "unboxed_nativeint" @@ -75,7 +75,7 @@ let array_ref_kind ppf k = | Paddrarray_ref -> fprintf ppf "addr" | Pintarray_ref -> fprintf ppf "int" | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode - | Punboxedfloatarray_ref -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_ref Pfloat64 -> fprintf ppf "unboxed_float" | Punboxedintarray_ref Pint32 -> fprintf ppf "unboxed_int32" | Punboxedintarray_ref Pint64 -> fprintf ppf "unboxed_int64" | Punboxedintarray_ref Pnativeint -> fprintf ppf "unboxed_nativeint" @@ -90,7 +90,7 @@ let array_set_kind ppf k = | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode | Pintarray_set -> fprintf ppf "int" | Pfloatarray_set -> fprintf ppf "float" - | Punboxedfloatarray_set -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_set Pfloat64 -> fprintf ppf "unboxed_float" | Punboxedintarray_set Pint32 -> fprintf ppf "unboxed_int32" | Punboxedintarray_set Pint64 -> fprintf ppf "unboxed_int64" | Punboxedintarray_set Pnativeint -> fprintf ppf "unboxed_nativeint" @@ -109,6 +109,9 @@ let boxed_integer_name = function | Pint32 -> "int32" | Pint64 -> "int64" +let boxed_float_name = function + | Pfloat64 -> "float" + let variant_kind print_contents ppf ~consts ~non_consts = fprintf ppf "@[[(consts (%a))@ (non_consts (%a))]@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int) @@ -126,7 +129,7 @@ let variant_kind print_contents ppf ~consts ~non_consts = let rec value_kind ppf = function | Pgenval -> () | Pintval -> fprintf ppf "[int]" - | Pfloatval -> fprintf ppf "[float]" + | Pboxedfloatval bf -> fprintf ppf "[%s]" (boxed_float_name bf) | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind) | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v) @@ -136,7 +139,7 @@ let rec value_kind ppf = function and value_kind' ppf = function | Pgenval -> fprintf ppf "*" | Pintval -> fprintf ppf "[int]" - | Pfloatval -> fprintf ppf "[float]" + | Pboxedfloatval bf -> fprintf ppf "[%s]" (boxed_float_name bf) | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind) | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v) @@ -148,7 +151,7 @@ let rec layout is_top ppf layout_ = | Pvalue k -> (if is_top then value_kind else value_kind') ppf k | Ptop -> fprintf ppf "[top]" | Pbottom -> fprintf ppf "[bottom]" - | Punboxed_float -> fprintf ppf "[unboxed_float]" + | Punboxed_float bf -> fprintf ppf "[unboxed_%s]" (boxed_float_name bf) | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi) | Punboxed_vector (Pvec128 v) -> fprintf ppf "[unboxed_%s]" (vec128_name v) | Punboxed_product layouts -> @@ -164,7 +167,8 @@ let return_kind ppf (mode, kind) = | Pvalue Pgenval when is_heap_mode mode -> () | Pvalue Pgenval -> fprintf ppf ": %s@ " smode | Pvalue Pintval -> fprintf ppf ": int@ " - | Pvalue Pfloatval -> fprintf ppf ": %sfloat@ " smode + | Pvalue (Pboxedfloatval bf) -> + fprintf ppf ": %s%s@ " smode (boxed_float_name bf) | Pvalue (Parrayval elt_kind) -> fprintf ppf ": %s%sarray@ " smode (array_kind elt_kind) | Pvalue (Pboxedintval bi) -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi) @@ -172,7 +176,7 @@ let return_kind ppf (mode, kind) = fprintf ppf ": %s%s@ " smode (vec128_name v) | Pvalue (Pvariant { consts; non_consts; }) -> variant_kind value_kind' ppf ~consts ~non_consts - | Punboxed_float -> fprintf ppf ": unboxed_float@ " + | Punboxed_float bf -> fprintf ppf ": unboxed_%s@ " (boxed_float_name bf) | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi) | Punboxed_vector (Pvec128 v) -> fprintf ppf ": unboxed_%s@ " (vec128_name v) | Punboxed_product _ -> fprintf ppf ": %a" layout kind @@ -182,7 +186,7 @@ let return_kind ppf (mode, kind) = let field_kind ppf = function | Pgenval -> pp_print_string ppf "*" | Pintval -> pp_print_string ppf "int" - | Pfloatval -> pp_print_string ppf "float" + | Pboxedfloatval bf -> pp_print_string ppf (boxed_float_name bf) | Parrayval elt_kind -> fprintf ppf "%s-array" (array_kind elt_kind) | Pboxedintval bi -> pp_print_string ppf (boxed_integer_name bi) | Pboxedvectorval (Pvec128 v) -> pp_print_string ppf (vec128_name v) @@ -225,6 +229,20 @@ let unboxed_integer_mark name bi m = let print_unboxed_integer name ppf bi m = fprintf ppf "%s" (unboxed_integer_mark name bi m);; +let boxed_float_mark name bf m = + match bf with + | Pfloat64 -> Printf.sprintf "Float.%s%s" name (alloc_kind m) + +let print_boxed_float name ppf bf m = + fprintf ppf "%s" (boxed_float_mark name bf m);; + +let unboxed_float_mark name bf m = + match bf with + | Pfloat64 -> Printf.sprintf "Float_u.%s%s" name (alloc_kind m) + +let print_unboxed_float name ppf bf m = + fprintf ppf "%s" (unboxed_float_mark name bf m);; + let print_bigarray name unsafe kind ppf layout = fprintf ppf "Bigarray.%s[%s,%s]" (if unsafe then "unsafe_"^ name else name) @@ -274,17 +292,17 @@ let integer_comparison ppf = function | Cgt -> fprintf ppf ">" | Cge -> fprintf ppf ">=" -let float_comparison ppf = function - | CFeq -> fprintf ppf "==." - | CFneq -> fprintf ppf "!=." - | CFlt -> fprintf ppf "<." - | CFnlt -> fprintf ppf "!<." - | CFle -> fprintf ppf "<=." - | CFnle -> fprintf ppf "!<=." - | CFgt -> fprintf ppf ">." - | CFngt -> fprintf ppf "!>." - | CFge -> fprintf ppf ">=." - | CFnge -> fprintf ppf "!>=." +let float_comparison = function + | CFeq -> "==" + | CFneq -> "!=" + | CFlt -> "<" + | CFnlt -> "!<" + | CFle -> "<=" + | CFnle -> "!<=" + | CFgt -> ">" + | CFngt -> "!>" + | CFge -> ">=" + | CFnge -> "!>=" let field_read_semantics ppf sem = match sem with @@ -419,20 +437,23 @@ let primitive ppf = function | Pasrint -> fprintf ppf "asr" | Pintcomp(cmp) -> integer_comparison ppf cmp | Pcompare_ints -> fprintf ppf "compare_ints" - | Pcompare_floats -> fprintf ppf "compare_floats" + | Pcompare_floats bf -> fprintf ppf "compare_floats %s" (boxed_float_name bf) | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer_name bi) | Poffsetint n -> fprintf ppf "%i+" n | Poffsetref n -> fprintf ppf "+:=%i"n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint m -> fprintf ppf "float_of_int%s" (alloc_kind m) - | Pnegfloat m -> fprintf ppf "~.%s" (alloc_kind m) - | Pabsfloat m -> fprintf ppf "abs.%s" (alloc_kind m) - | Paddfloat m -> fprintf ppf "+.%s" (alloc_kind m) - | Psubfloat m -> fprintf ppf "-.%s" (alloc_kind m) - | Pmulfloat m -> fprintf ppf "*.%s" (alloc_kind m) - | Pdivfloat m -> fprintf ppf "/.%s" (alloc_kind m) - | Pfloatcomp(cmp) -> float_comparison ppf cmp - | Punboxed_float_comp(cmp) -> fprintf ppf "%a (unboxed)" float_comparison cmp + | Pintoffloat bf -> fprintf ppf "int_of_%s" (boxed_float_name bf) + | Pfloatofint (bf,m) -> + fprintf ppf "%s_of_int%s" (boxed_float_name bf) (alloc_kind m) + | Pabsfloat (bf,m) -> print_boxed_float "abs" ppf bf m + | Pnegfloat (bf,m) -> print_boxed_float "neg" ppf bf m + | Paddfloat (bf,m) -> print_boxed_float "add" ppf bf m + | Psubfloat (bf,m) -> print_boxed_float "sub" ppf bf m + | Pmulfloat (bf,m) -> print_boxed_float "mul" ppf bf m + | Pdivfloat (bf,m) -> print_boxed_float "div" ppf bf m + | Pfloatcomp (bf,cmp) -> + print_boxed_float (float_comparison cmp) ppf bf alloc_heap + | Punboxed_float_comp (bf,cmp) -> + print_unboxed_float (float_comparison cmp) ppf bf alloc_heap | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" @@ -599,8 +620,9 @@ let primitive ppf = function | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name | Pobj_dup -> fprintf ppf "obj_dup" | Pobj_magic _ -> fprintf ppf "obj_magic" - | Punbox_float -> fprintf ppf "unbox_float" - | Pbox_float m -> fprintf ppf "box_float%s" (alloc_kind m) + | Punbox_float bf -> fprintf ppf "unbox_%s" (boxed_float_name bf) + | Pbox_float (bf,m) -> + fprintf ppf "box_%s%s" (boxed_float_name bf) (alloc_kind m) | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi) | Pbox_int (bi, m) -> fprintf ppf "box_%s%s" (boxed_integer_name bi) (alloc_kind m) @@ -649,20 +671,20 @@ let name_of_primitive = function | Pasrint -> "Pasrint" | Pintcomp _ -> "Pintcomp" | Pcompare_ints -> "Pcompare_ints" - | Pcompare_floats -> "Pcompare_floats" + | Pcompare_floats Pfloat64 -> "Pcompare_floats" | Pcompare_bints _ -> "Pcompare" | Poffsetint _ -> "Poffsetint" | Poffsetref _ -> "Poffsetref" - | Pintoffloat -> "Pintoffloat" - | Pfloatofint _ -> "Pfloatofint" - | Pnegfloat _ -> "Pnegfloat" - | Pabsfloat _ -> "Pabsfloat" - | Paddfloat _ -> "Paddfloat" - | Psubfloat _ -> "Psubfloat" - | Pmulfloat _ -> "Pmulfloat" - | Pdivfloat _ -> "Pdivfloat" - | Pfloatcomp _ -> "Pfloatcomp" - | Punboxed_float_comp _ -> "Punboxed_float_comp" + | Pintoffloat Pfloat64 -> "Pintoffloat" + | Pfloatofint (Pfloat64, _) -> "Pfloatofint" + | Pnegfloat (Pfloat64, _) -> "Pnegfloat" + | Pabsfloat (Pfloat64, _) -> "Pabsfloat" + | Paddfloat (Pfloat64, _) -> "Paddfloat" + | Psubfloat (Pfloat64, _) -> "Psubfloat" + | Pmulfloat (Pfloat64, _) -> "Pmulfloat" + | Pdivfloat (Pfloat64, _) -> "Pdivfloat" + | Pfloatcomp (Pfloat64, _) -> "Pfloatcomp" + | Punboxed_float_comp (Pfloat64, _) -> "Punboxed_float_comp" | Pstringlength -> "Pstringlength" | Pstringrefu -> "Pstringrefu" | Pstringrefs -> "Pstringrefs" @@ -740,8 +762,8 @@ let name_of_primitive = function | Pprobe_is_enabled _ -> "Pprobe_is_enabled" | Pobj_dup -> "Pobj_dup" | Pobj_magic _ -> "Pobj_magic" - | Punbox_float -> "Punbox_float" - | Pbox_float _ -> "Pbox_float" + | Punbox_float Pfloat64 -> "Punbox_float" + | Pbox_float (Pfloat64, _) -> "Pbox_float" | Punbox_int _ -> "Punbox_int" | Pbox_int _ -> "Pbox_int" | Parray_of_iarray -> "Parray_of_iarray" diff --git a/ocaml/lambda/printlambda.mli b/ocaml/lambda/printlambda.mli index 8af3563d6b6..1cd9f6edbe2 100644 --- a/ocaml/lambda/printlambda.mli +++ b/ocaml/lambda/printlambda.mli @@ -18,7 +18,7 @@ open Lambda open Format val integer_comparison: formatter -> integer_comparison -> unit -val float_comparison: formatter -> float_comparison -> unit +val float_comparison: float_comparison -> string val structured_constant: formatter -> structured_constant -> unit val lambda: formatter -> lambda -> unit val program: formatter -> program -> unit diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index e862c07e1c9..83813d6c643 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -887,23 +887,24 @@ let rec choice ctx t = | Plslint | Plsrint | Pasrint | Pintcomp _ | Punboxed_int_comp _ | Poffsetint _ | Poffsetref _ - | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pfloatcomp _ | Punboxed_float_comp _ + | Pintoffloat Pfloat64 | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets | Parraylength _ | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pignore - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ (* we don't handle effect or DLS primitives *) | Prunstack | Pperform | Presume | Preperform | Pdls_get (* we don't handle atomic primitives *) | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ - | Punbox_float | Pbox_float _ + | Punbox_float Pfloat64 | Pbox_float (Pfloat64, _) | Punbox_int _ | Pbox_int _ (* we don't handle array indices as destinations yet *) diff --git a/ocaml/lambda/transl_array_comprehension.ml b/ocaml/lambda/transl_array_comprehension.ml index 6916e24fdde..f4fb5e4a4c6 100644 --- a/ocaml/lambda/transl_array_comprehension.ml +++ b/ocaml/lambda/transl_array_comprehension.ml @@ -697,7 +697,7 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = | Fixed_size, (Pintarray | Paddrarray) -> Immutable StrictOpt, make_vect ~loc ~length:array_size.var ~init:(int 0) - | Fixed_size, (Pfloatarray | Punboxedfloatarray) -> + | Fixed_size, (Pfloatarray | Punboxedfloatarray Pfloat64) -> (* The representations of these two are the same, it's only accesses that differ. *) Immutable StrictOpt, make_float_vect ~loc array_size.var @@ -712,7 +712,7 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = Mutable, Resizable_array.make ~loc array_kind (int 0) | Dynamic_size, Pfloatarray -> Mutable, Resizable_array.make ~loc array_kind (float 0.) - | Dynamic_size, Punboxedfloatarray -> + | Dynamic_size, Punboxedfloatarray Pfloat64 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_float 0.) | Dynamic_size, Punboxedintarray Pint32 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_int32 0l) @@ -808,7 +808,7 @@ let body Lassign(array.id, make_array), set_element_in_bounds elt.var, (Pvalue Pintval) (* [unit] is immediate *))) - | Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray + | Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> set_element_in_bounds body in @@ -821,7 +821,7 @@ let comprehension { comp_body; comp_clauses } = (match array_kind with | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> () - | Punboxedfloatarray | Punboxedintarray _ -> + | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> if not !Clflags.native_code then Misc.fatal_errorf "Array comprehensions for kind %s are not allowed in bytecode" diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 84dd69b5469..a9d423847c3 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -59,7 +59,7 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type *) let record_field_kind l = match l with - | Punboxed_float -> Pfloatval + | Punboxed_float Pfloat64 -> Pboxedfloatval Pfloat64 | _ -> must_be_value l (* CR layouts v5: This function is only used for sanity checking the @@ -643,7 +643,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = Lconst(Const_float_array(List.map extract_float cl)) | Pgenarray -> raise Not_constant (* can this really happen? *) - | Punboxedfloatarray | Punboxedintarray _ -> + | Punboxedfloatarray Pfloat64 | Punboxedintarray _ -> Misc.fatal_error "Use flambda2 for unboxed arrays" in match amut with diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 81863a604db..78639830162 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -210,20 +210,20 @@ let lookup_primitive loc poly pos p = | "%geint" -> Primitive ((Pintcomp Cge), 2) | "%incr" -> Primitive ((Poffsetref(1)), 1) | "%decr" -> Primitive ((Poffsetref(-1)), 1) - | "%intoffloat" -> Primitive (Pintoffloat, 1) - | "%floatofint" -> Primitive (Pfloatofint mode, 1) - | "%negfloat" -> Primitive (Pnegfloat mode, 1) - | "%absfloat" -> Primitive (Pabsfloat mode, 1) - | "%addfloat" -> Primitive (Paddfloat mode, 2) - | "%subfloat" -> Primitive (Psubfloat mode, 2) - | "%mulfloat" -> Primitive (Pmulfloat mode, 2) - | "%divfloat" -> Primitive (Pdivfloat mode, 2) - | "%eqfloat" -> Primitive ((Pfloatcomp CFeq), 2) - | "%noteqfloat" -> Primitive ((Pfloatcomp CFneq), 2) - | "%ltfloat" -> Primitive ((Pfloatcomp CFlt), 2) - | "%lefloat" -> Primitive ((Pfloatcomp CFle), 2) - | "%gtfloat" -> Primitive ((Pfloatcomp CFgt), 2) - | "%gefloat" -> Primitive ((Pfloatcomp CFge), 2) + | "%intoffloat" -> Primitive (Pintoffloat Pfloat64, 1) + | "%floatofint" -> Primitive (Pfloatofint (Pfloat64, mode), 1) + | "%negfloat" -> Primitive (Pnegfloat (Pfloat64, mode), 1) + | "%absfloat" -> Primitive (Pabsfloat (Pfloat64, mode), 1) + | "%addfloat" -> Primitive (Paddfloat (Pfloat64, mode), 2) + | "%subfloat" -> Primitive (Psubfloat (Pfloat64, mode), 2) + | "%mulfloat" -> Primitive (Pmulfloat (Pfloat64, mode), 2) + | "%divfloat" -> Primitive (Pdivfloat (Pfloat64, mode), 2) + | "%eqfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFeq)), 2) + | "%noteqfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFneq)), 2) + | "%ltfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFlt)), 2) + | "%lefloat" -> Primitive ((Pfloatcomp (Pfloat64, CFle)), 2) + | "%gtfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFgt)), 2) + | "%gefloat" -> Primitive ((Pfloatcomp (Pfloat64, CFge)), 2) | "%string_length" -> Primitive (Pstringlength, 1) | "%string_safe_get" -> Primitive (Pstringrefs, 2) | "%string_safe_set" -> Primitive (Pbytessets, 3) @@ -448,8 +448,8 @@ let lookup_primitive loc poly pos p = | "%obj_magic" -> Primitive(Pobj_magic Lambda.layout_any_value, 1) | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1) | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1) - | "%unbox_float" -> Primitive(Punbox_float, 1) - | "%box_float" -> Primitive(Pbox_float mode, 1) + | "%unbox_float" -> Primitive(Punbox_float Pfloat64, 1) + | "%box_float" -> Primitive(Pbox_float (Pfloat64, mode), 1) | "%get_header" -> Primitive (Pget_header mode, 1) | "%atomic_load" -> Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1) @@ -506,9 +506,9 @@ let glb_array_type loc t1 t2 = match t1, t2 with (* Handle unboxed array kinds which can only match with themselves *) - | Punboxedfloatarray, Punboxedfloatarray -> Punboxedfloatarray - | Punboxedfloatarray, _ | _, Punboxedfloatarray -> - raise(Error(loc, Invalid_array_kind_in_glb Punboxedfloatarray)) + | Punboxedfloatarray Pfloat64, Punboxedfloatarray Pfloat64 -> Punboxedfloatarray Pfloat64 + | Punboxedfloatarray Pfloat64, _ | _, Punboxedfloatarray Pfloat64 -> + raise(Error(loc, Invalid_array_kind_in_glb (Punboxedfloatarray Pfloat64))) | Punboxedintarray Pint32, Punboxedintarray Pint32 -> Punboxedintarray Pint32 | Punboxedintarray Pint64, Punboxedintarray Pint64 -> Punboxedintarray Pint64 | Punboxedintarray Pnativeint, Punboxedintarray Pnativeint -> @@ -529,9 +529,9 @@ let glb_array_type loc t1 t2 = let glb_array_ref_type loc t1 t2 = match t1, t2 with (* Handle unboxed array kinds which can only match with themselves *) - | Punboxedfloatarray_ref, Punboxedfloatarray -> t1 - | Punboxedfloatarray_ref, _ | _, Punboxedfloatarray -> - raise(Error(loc, Invalid_array_kind_in_glb Punboxedfloatarray)) + | Punboxedfloatarray_ref Pfloat64, Punboxedfloatarray Pfloat64 -> t1 + | Punboxedfloatarray_ref Pfloat64, _ | _, Punboxedfloatarray Pfloat64 -> + raise(Error(loc, Invalid_array_kind_in_glb (Punboxedfloatarray Pfloat64))) | Punboxedintarray_ref Pint32, Punboxedintarray Pint32 -> t1 | Punboxedintarray_ref Pint64, Punboxedintarray Pint64 -> t1 | Punboxedintarray_ref Pnativeint, Punboxedintarray Pnativeint -> t1 @@ -565,9 +565,9 @@ let glb_array_ref_type loc t1 t2 = let glb_array_set_type loc t1 t2 = match t1, t2 with (* Handle unboxed array kinds which can only match with themselves *) - | Punboxedfloatarray_set, Punboxedfloatarray -> t1 - | Punboxedfloatarray_set, _ | _, Punboxedfloatarray -> - raise(Error(loc, Invalid_array_kind_in_glb Punboxedfloatarray)) + | Punboxedfloatarray_set Pfloat64, Punboxedfloatarray Pfloat64 -> t1 + | Punboxedfloatarray_set Pfloat64, _ | _, Punboxedfloatarray Pfloat64 -> + raise(Error(loc, Invalid_array_kind_in_glb (Punboxedfloatarray Pfloat64))) | Punboxedintarray_set Pint32, Punboxedintarray Pint32 -> t1 | Punboxedintarray_set Pint64, Punboxedintarray Pint64 -> t1 | Punboxedintarray_set Pnativeint, Punboxedintarray Pnativeint -> t1 @@ -757,7 +757,7 @@ let comparison_primitive comparison comparison_kind = match comparison, comparison_kind with | Equal, Compare_generic -> Pccall caml_equal | Equal, Compare_ints -> Pintcomp Ceq - | Equal, Compare_floats -> Pfloatcomp CFeq + | Equal, Compare_floats -> Pfloatcomp (Pfloat64, CFeq) | Equal, Compare_strings -> Pccall caml_string_equal | Equal, Compare_bytes -> Pccall caml_bytes_equal | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) @@ -765,7 +765,7 @@ let comparison_primitive comparison comparison_kind = | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) | Not_equal, Compare_generic -> Pccall caml_notequal | Not_equal, Compare_ints -> Pintcomp Cne - | Not_equal, Compare_floats -> Pfloatcomp CFneq + | Not_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFneq) | Not_equal, Compare_strings -> Pccall caml_string_notequal | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) @@ -773,7 +773,7 @@ let comparison_primitive comparison comparison_kind = | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) | Less_equal, Compare_generic -> Pccall caml_lessequal | Less_equal, Compare_ints -> Pintcomp Cle - | Less_equal, Compare_floats -> Pfloatcomp CFle + | Less_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFle) | Less_equal, Compare_strings -> Pccall caml_string_lessequal | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) @@ -781,7 +781,7 @@ let comparison_primitive comparison comparison_kind = | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) | Less_than, Compare_generic -> Pccall caml_lessthan | Less_than, Compare_ints -> Pintcomp Clt - | Less_than, Compare_floats -> Pfloatcomp CFlt + | Less_than, Compare_floats -> Pfloatcomp (Pfloat64, CFlt) | Less_than, Compare_strings -> Pccall caml_string_lessthan | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) @@ -789,7 +789,7 @@ let comparison_primitive comparison comparison_kind = | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) | Greater_equal, Compare_generic -> Pccall caml_greaterequal | Greater_equal, Compare_ints -> Pintcomp Cge - | Greater_equal, Compare_floats -> Pfloatcomp CFge + | Greater_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFge) | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) @@ -797,7 +797,7 @@ let comparison_primitive comparison comparison_kind = | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) | Greater_than, Compare_generic -> Pccall caml_greaterthan | Greater_than, Compare_ints -> Pintcomp Cgt - | Greater_than, Compare_floats -> Pfloatcomp CFgt + | Greater_than, Compare_floats -> Pfloatcomp (Pfloat64, CFgt) | Greater_than, Compare_strings -> Pccall caml_string_greaterthan | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) @@ -805,7 +805,7 @@ let comparison_primitive comparison comparison_kind = | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) | Compare, Compare_generic -> Pccall caml_compare | Compare, Compare_ints -> Pcompare_ints - | Compare, Compare_floats -> Pcompare_floats + | Compare, Compare_floats -> Pcompare_floats Pfloat64 | Compare, Compare_strings -> Pccall caml_string_compare | Compare, Compare_bytes -> Pccall caml_bytes_compare | Compare, Compare_nativeints -> Pcompare_bints Pnativeint @@ -1088,8 +1088,12 @@ let lambda_primitive_needs_event_after = function (* We add an event after any primitive resulting in a C call that may raise an exception or allocate. These are places where we may collect the call stack. *) - | Pduprecord _ | Pccall _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pstringrefs | Pbytesrefs + | Pduprecord _ | Pccall _ + | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) + | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ | Parrayrefu (Pgenarray_ref _ | Pfloatarray_ref _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ @@ -1116,21 +1120,21 @@ let lambda_primitive_needs_event_after = function | Pufloatfield _ | Psetufloatfield _ | Psequor | Psequand | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint - | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat - | Pcompare_ints | Pcompare_floats - | Pfloatcomp _ | Punboxed_float_comp _ + | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat Pfloat64 + | Pcompare_ints | Pcompare_floats Pfloat64 + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu - | Pmakearray ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray + | Pmakearray ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray Pfloat64 | Punboxedintarray _), _, _) | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout | Pprobe_is_enabled _ | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer _ | Popaque _ | Pdls_get - | Pobj_magic _ | Punbox_float | Punbox_int _ + | Pobj_magic _ | Punbox_float Pfloat64 | Punbox_int _ (* These don't allocate in bytecode; they're just identity functions: *) - | Pbox_float _ | Pbox_int _ + | Pbox_float (Pfloat64, _) | Pbox_int _ -> false (* Determine if a primitive should be surrounded by an "after" debug event *) diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index 6337b44a01e..f322bb8295b 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/middle_end/clambda_primitives.ml @@ -65,16 +65,22 @@ type primitive = | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of integer_comparison - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer + | Pcompare_ints + | Pcompare_floats of boxed_float + | Pcompare_bints of boxed_integer | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison + | Pintoffloat of boxed_float + | Pfloatofint of boxed_float * alloc_mode + | Pnegfloat of boxed_float * alloc_mode + | Pabsfloat of boxed_float * alloc_mode + | Paddfloat of boxed_float * alloc_mode + | Psubfloat of boxed_float * alloc_mode + | Pmulfloat of boxed_float * alloc_mode + | Pdivfloat of boxed_float * alloc_mode + | Pfloatcomp of boxed_float * float_comparison + | Punboxed_float_comp of boxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -139,8 +145,8 @@ type primitive = | Popaque (* Probes *) | Pprobe_is_enabled of { name : string } - | Punbox_float - | Pbox_float of alloc_mode + | Punbox_float of boxed_float + | Pbox_float of boxed_float * alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode | Pget_header of alloc_mode @@ -155,7 +161,7 @@ and float_comparison = Lambda.float_comparison = and array_kind = Lambda.array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Punboxedfloatarray + | Punboxedfloatarray of unboxed_float | Punboxedintarray of unboxed_integer and array_ref_kind = Lambda.array_ref_kind = @@ -163,7 +169,7 @@ and array_ref_kind = Lambda.array_ref_kind = | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref of alloc_mode - | Punboxedfloatarray_ref + | Punboxedfloatarray_ref of unboxed_float | Punboxedintarray_ref of unboxed_integer and array_set_kind = Lambda.array_set_kind = @@ -171,12 +177,14 @@ and array_set_kind = Lambda.array_set_kind = | Paddrarray_set of modify_mode | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set + | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer and value_kind = Lambda.value_kind = - (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + | Pgenval + | Pintval + | Pboxedfloatval of boxed_float + | Pboxedintval of boxed_integer | Pvariant of { consts : int list; non_consts : (int * value_kind list) list; @@ -187,7 +195,7 @@ and value_kind = Lambda.value_kind = and layout = Lambda.layout = | Ptop | Pvalue of value_kind - | Punboxed_float + | Punboxed_float of boxed_float | Punboxed_int of boxed_integer | Punboxed_vector of boxed_vector | Punboxed_product of layout list @@ -195,9 +203,14 @@ and layout = Lambda.layout = and block_shape = Lambda.block_shape +and boxed_float = Lambda.boxed_float = + | Pfloat64 + and boxed_integer = Lambda.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_float = boxed_float + and unboxed_integer = boxed_integer and vec128_type = Lambda.vec128_type = @@ -243,10 +256,13 @@ let result_layout (p : primitive) = | Pmakeufloatblock _ | Pduparray _ | Pbigarraydim _ -> Lambda.layout_block | Pfield _ | Pfield_computed -> Lambda.layout_field - | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ - | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pbox_float _ -> Lambda.layout_boxed_float - | Pufloatfield _ | Punbox_float -> Punboxed_float + | Pfloatfield _ | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) | Pdivfloat (Pfloat64, _) + | Pbox_float (Pfloat64, _) -> Lambda.layout_boxed_float Pfloat64 + | Pufloatfield _ -> Punboxed_float Pfloat64 + | Punbox_float Pfloat64 -> Punboxed_float Pfloat64 | Pccall { prim_native_repr_res = _, repr_res } -> Lambda.layout_of_native_repr repr_res | Praise _ -> Lambda.layout_bottom | Psequor | Psequand | Pnot @@ -255,8 +271,9 @@ let result_layout (p : primitive) = | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ - | Poffsetint _ | Pintoffloat | Pfloatcomp _ | Punboxed_float_comp _ + | Pcompare_ints | Pcompare_floats Pfloat64| Pcompare_bints _ + | Poffsetint _ | Pintoffloat Pfloat64 + | Pfloatcomp (Pfloat64, _) | Punboxed_float_comp (Pfloat64, _) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytesrefs | Parraylength _ | Pisint | Pisout | Pintofbint _ @@ -276,7 +293,7 @@ let result_layout (p : primitive) = | Pbigarrayref (_, _, kind, _) -> begin match kind with | Pbigarray_unknown -> Lambda.layout_any_value - | Pbigarray_float32 | Pbigarray_float64 -> Lambda.layout_boxed_float + | Pbigarray_float32 | Pbigarray_float64 -> Lambda.layout_boxed_float Pfloat64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_caml_int -> Lambda.layout_int diff --git a/ocaml/middle_end/clambda_primitives.mli b/ocaml/middle_end/clambda_primitives.mli index 2e2f462db6e..bfe57201a0f 100644 --- a/ocaml/middle_end/clambda_primitives.mli +++ b/ocaml/middle_end/clambda_primitives.mli @@ -65,16 +65,22 @@ type primitive = | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp of integer_comparison - | Pcompare_ints | Pcompare_floats | Pcompare_bints of boxed_integer + | Pcompare_ints + | Pcompare_floats of boxed_float + | Pcompare_bints of boxed_integer | Poffsetint of int | Poffsetref of int (* Float operations *) - | Pintoffloat | Pfloatofint of alloc_mode - | Pnegfloat of alloc_mode | Pabsfloat of alloc_mode - | Paddfloat of alloc_mode | Psubfloat of alloc_mode - | Pmulfloat of alloc_mode | Pdivfloat of alloc_mode - | Pfloatcomp of float_comparison - | Punboxed_float_comp of float_comparison + | Pintoffloat of boxed_float + | Pfloatofint of boxed_float * alloc_mode + | Pnegfloat of boxed_float * alloc_mode + | Pabsfloat of boxed_float * alloc_mode + | Paddfloat of boxed_float * alloc_mode + | Psubfloat of boxed_float * alloc_mode + | Pmulfloat of boxed_float * alloc_mode + | Pdivfloat of boxed_float * alloc_mode + | Pfloatcomp of boxed_float * float_comparison + | Punboxed_float_comp of boxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -142,8 +148,8 @@ type primitive = | Popaque (* Probes *) | Pprobe_is_enabled of { name : string } - | Punbox_float - | Pbox_float of alloc_mode + | Punbox_float of boxed_float + | Pbox_float of boxed_float * alloc_mode | Punbox_int of boxed_integer | Pbox_int of boxed_integer * alloc_mode | Pget_header of alloc_mode @@ -159,7 +165,7 @@ and float_comparison = Lambda.float_comparison = and array_kind = Lambda.array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Punboxedfloatarray + | Punboxedfloatarray of unboxed_float | Punboxedintarray of unboxed_integer and array_ref_kind = Lambda.array_ref_kind = @@ -167,7 +173,7 @@ and array_ref_kind = Lambda.array_ref_kind = | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref of alloc_mode - | Punboxedfloatarray_ref + | Punboxedfloatarray_ref of unboxed_float | Punboxedintarray_ref of unboxed_integer and array_set_kind = Lambda.array_set_kind = @@ -175,12 +181,14 @@ and array_set_kind = Lambda.array_set_kind = | Paddrarray_set of modify_mode | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set + | Punboxedfloatarray_set of unboxed_float | Punboxedintarray_set of unboxed_integer and value_kind = Lambda.value_kind = - (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + | Pgenval + | Pintval + | Pboxedfloatval of boxed_float + | Pboxedintval of boxed_integer | Pvariant of { consts : int list; non_consts : (int * value_kind list) list; @@ -191,7 +199,7 @@ and value_kind = Lambda.value_kind = and layout = Lambda.layout = | Ptop | Pvalue of value_kind - | Punboxed_float + | Punboxed_float of boxed_float | Punboxed_int of boxed_integer | Punboxed_vector of boxed_vector | Punboxed_product of layout list @@ -199,9 +207,14 @@ and layout = Lambda.layout = and block_shape = Lambda.block_shape +and boxed_float = Lambda.boxed_float = + | Pfloat64 + and boxed_integer = Lambda.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_float = boxed_float + and unboxed_integer = boxed_integer and vec128_type = Lambda.vec128_type = diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index 8fe0ef5d276..91bf7094129 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/middle_end/closure/closure.ml @@ -61,12 +61,12 @@ 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_float Pfloat64 -> true | Punboxed_int _ -> true | Punboxed_vector _ -> true | Pvalue Pintval -> true - | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _ | - Pboxedvectorval _) -> false + | Pvalue (Pgenval | Pboxedfloatval Pfloat64 | Pboxedintval _ | Pvariant _ | + Parrayval _ | Pboxedvectorval _) -> false | Punboxed_product _ -> Misc.fatal_error "TODO" let split_closure_fv kinds fv = @@ -345,7 +345,7 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = | Pnot -> make_const_bool (n1 = 0) | Pnegint -> make_const_int (- n1) | Poffsetint n -> make_const_int (n + n1) - | Pfloatofint _ when fpc -> make_const_float (float_of_int n1) + | Pfloatofint (Pfloat64, _) when fpc -> make_const_float (float_of_int n1) | Pbintofint (Pnativeint,_) -> make_const_natint (Nativeint.of_int n1) | Pbintofint (Pint32,_) -> make_const_int32 (Int32.of_int n1) | Pbintofint (Pint64,_) -> make_const_int64 (Int64.of_int n1) @@ -379,20 +379,20 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = (* float *) | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> begin match p with - | Pintoffloat -> make_const_int (int_of_float n1) - | Pnegfloat _ -> make_const_float (-. n1) - | Pabsfloat _ -> make_const_float (abs_float n1) + | Pintoffloat Pfloat64 -> make_const_int (int_of_float n1) + | Pnegfloat (Pfloat64, _) -> make_const_float (-. n1) + | Pabsfloat (Pfloat64, _) -> make_const_float (abs_float n1) | _ -> default end (* float, float *) | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> begin match p with - | Paddfloat _ -> make_const_float (n1 +. n2) - | Psubfloat _ -> make_const_float (n1 -. n2) - | Pmulfloat _ -> make_const_float (n1 *. n2) - | Pdivfloat _ -> make_const_float (n1 /. n2) - | Pfloatcomp c -> make_float_comparison c n1 n2 + | Paddfloat (Pfloat64, _) -> make_const_float (n1 +. n2) + | Psubfloat (Pfloat64, _) -> make_const_float (n1 -. n2) + | Pmulfloat (Pfloat64, _) -> make_const_float (n1 *. n2) + | Pdivfloat (Pfloat64, _) -> make_const_float (n1 /. n2) + | Pfloatcomp (Pfloat64, c) -> make_float_comparison c n1 n2 | _ -> default end (* nativeint *) diff --git a/ocaml/middle_end/convert_primitives.ml b/ocaml/middle_end/convert_primitives.ml index d186ebb8a0f..066370e0957 100644 --- a/ocaml/middle_end/convert_primitives.ml +++ b/ocaml/middle_end/convert_primitives.ml @@ -74,20 +74,20 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pasrint -> Pasrint | Pintcomp comp -> Pintcomp comp | Pcompare_ints -> Pcompare_ints - | Pcompare_floats -> Pcompare_floats + | Pcompare_floats bf -> Pcompare_floats bf | Pcompare_bints bi -> Pcompare_bints bi | Poffsetint offset -> Poffsetint offset | Poffsetref offset -> Poffsetref offset - | Pintoffloat -> Pintoffloat - | Pfloatofint m -> Pfloatofint m - | Pnegfloat m -> Pnegfloat m - | Pabsfloat m -> Pabsfloat m - | Paddfloat m -> Paddfloat m - | Psubfloat m -> Psubfloat m - | Pmulfloat m -> Pmulfloat m - | Pdivfloat m -> Pdivfloat m - | Pfloatcomp comp -> Pfloatcomp comp - | Punboxed_float_comp comp -> Punboxed_float_comp comp + | Pintoffloat bf -> Pintoffloat bf + | Pfloatofint (bf,m) -> Pfloatofint (bf,m) + | Pnegfloat (bf,m) -> Pnegfloat (bf,m) + | Pabsfloat (bf,m) -> Pabsfloat (bf,m) + | Paddfloat (bf,m) -> Paddfloat (bf,m) + | Psubfloat (bf,m) -> Psubfloat (bf,m) + | Pmulfloat (bf,m) -> Pmulfloat (bf,m) + | Pdivfloat (bf,m) -> Pdivfloat (bf,m) + | Pfloatcomp (bf,comp) -> Pfloatcomp (bf,comp) + | Punboxed_float_comp (bf,comp) -> Punboxed_float_comp (bf,comp) | Pstringlength -> Pstringlength | Pstringrefu -> Pstringrefu | Pstringrefs -> Pstringrefs @@ -178,8 +178,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = ~native_name:"caml_obj_dup" ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value] ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Jkind.Sort.Value)) - | Punbox_float -> Punbox_float - | Pbox_float m -> Pbox_float m + | Punbox_float bf -> Punbox_float bf + | Pbox_float (bf,m) -> Pbox_float (bf,m) | Punbox_int bi -> Punbox_int bi | Pbox_int (bi, m) -> Pbox_int (bi, m) | Pget_header m -> Pget_header m diff --git a/ocaml/middle_end/flambda/closure_offsets.ml b/ocaml/middle_end/flambda/closure_offsets.ml index f2f67611789..a481149e8aa 100644 --- a/ocaml/middle_end/flambda/closure_offsets.ml +++ b/ocaml/middle_end/flambda/closure_offsets.ml @@ -77,7 +77,7 @@ 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_float Pfloat64 -> true | Punboxed_int _ -> true | Punboxed_vector _ -> true | Pvalue Pintval -> true diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index 39e02a4bcb1..48fae4c6c46 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/middle_end/flambda/flambda_to_clambda.ml @@ -710,7 +710,7 @@ 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_float Pfloat64 -> true | Punboxed_int _ -> true | Punboxed_vector _ -> true | Pvalue Pintval -> true diff --git a/ocaml/middle_end/flambda/inline_and_simplify.ml b/ocaml/middle_end/flambda/inline_and_simplify.ml index d9fc0bc9ef0..dc3fd71bd6b 100644 --- a/ocaml/middle_end/flambda/inline_and_simplify.ml +++ b/ocaml/middle_end/flambda/inline_and_simplify.ml @@ -1118,7 +1118,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = Misc.fatal_errorf "Assignment of a float to a specialised \ non-float array: %a" Flambda.print_named tree - | Punboxedfloatarray_set | Punboxedintarray_set _ -> + | Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _ -> Misc.fatal_errorf "Unboxed arrays not supported" in match A.descr block_approx, A.descr value_approx with diff --git a/ocaml/middle_end/flambda/simple_value_approx.ml b/ocaml/middle_end/flambda/simple_value_approx.ml index 45b6e039917..70c2efa13db 100644 --- a/ocaml/middle_end/flambda/simple_value_approx.ml +++ b/ocaml/middle_end/flambda/simple_value_approx.ml @@ -253,7 +253,7 @@ let replace_description t descr = { t with descr } let augment_with_kind t (kind:Lambda.value_kind) = match kind with | Pgenval -> t - | Pfloatval -> + | Pboxedfloatval Pfloat64 -> begin match t.descr with | Value_float _ -> t @@ -278,7 +278,7 @@ let augment_with_kind t (kind:Lambda.value_kind) = let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = match t.descr with - | Value_float _ -> Pfloatval + | Value_float _ -> Pboxedfloatval Pfloat64 | Value_int _ -> Pintval | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 @@ -375,7 +375,7 @@ let value_mutable_float_array ~size = let value_immutable_float_array (contents:t array) = let size = Array.length contents in let contents = - Array.map (fun t -> augment_with_kind t Pfloatval) contents + Array.map (fun t -> augment_with_kind t (Pboxedfloatval Pfloat64)) contents in approx (Value_float_array { contents = Contents contents; size; } ) diff --git a/ocaml/middle_end/flambda/simplify_primitives.ml b/ocaml/middle_end/flambda/simplify_primitives.ml index 31e711d08a1..d6d3e973e24 100644 --- a/ocaml/middle_end/flambda/simplify_primitives.ml +++ b/ocaml/middle_end/flambda/simplify_primitives.ml @@ -174,7 +174,8 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | Pbswap16 -> S.const_int_expr expr (S.swap16 x) | Pisint -> S.const_bool_expr expr true | Poffsetint y -> S.const_int_expr expr (x + y) - | Pfloatofint _ when fpc -> S.const_float_expr expr (float_of_int x) + | Pfloatofint (Pfloat64, _) when fpc -> + S.const_float_expr expr (float_of_int x) | Pbintofint (Pnativeint,_) -> S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) | Pbintofint (Pint32,_) -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) @@ -208,19 +209,19 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) end | [Value_float (Some x)] when fpc -> begin match p with - | Pintoffloat -> S.const_int_expr expr (int_of_float x) - | Pnegfloat _ -> S.const_float_expr expr (-. x) - | Pabsfloat _ -> S.const_float_expr expr (abs_float x) + | Pintoffloat Pfloat64 -> S.const_int_expr expr (int_of_float x) + | Pnegfloat (Pfloat64, _) -> S.const_float_expr expr (-. x) + | Pabsfloat (Pfloat64, _) -> S.const_float_expr expr (abs_float x) | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_float (Some n1); Value_float (Some n2)] when fpc -> begin match p with - | Paddfloat _ -> S.const_float_expr expr (n1 +. n2) - | Psubfloat _ -> S.const_float_expr expr (n1 -. n2) - | Pmulfloat _ -> S.const_float_expr expr (n1 *. n2) - | Pdivfloat _ -> S.const_float_expr expr (n1 /. n2) - | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 - | Pcompare_floats -> S.const_int_expr expr (Float.compare n1 n2) + | Paddfloat (Pfloat64, _) -> S.const_float_expr expr (n1 +. n2) + | Psubfloat (Pfloat64, _) -> S.const_float_expr expr (n1 -. n2) + | Pmulfloat (Pfloat64, _) -> S.const_float_expr expr (n1 *. n2) + | Pdivfloat (Pfloat64, _) -> S.const_float_expr expr (n1 /. n2) + | Pfloatcomp (Pfloat64, c) -> S.const_float_comparison_expr expr c n1 n2 + | Pcompare_floats Pfloat64 -> S.const_int_expr expr (Float.compare n1 n2) | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [A.Value_boxed_int(A.Nativeint, n)] -> diff --git a/ocaml/middle_end/internal_variable_names.ml b/ocaml/middle_end/internal_variable_names.ml index fee8351c97c..87447e4de4b 100644 --- a/ocaml/middle_end/internal_variable_names.ml +++ b/ocaml/middle_end/internal_variable_names.ml @@ -410,20 +410,20 @@ let of_primitive : Lambda.primitive -> string = function | Pasrint -> pasrint | Pintcomp _ -> pintcomp | Pcompare_ints -> pcompare_ints - | Pcompare_floats -> pcompare_floats + | Pcompare_floats Pfloat64 -> pcompare_floats | Pcompare_bints _ -> pcompare_bints | Poffsetint _ -> poffsetint | Poffsetref _ -> poffsetref - | Pintoffloat -> pintoffloat - | Pfloatofint _ -> pfloatofint - | Pnegfloat _ -> pnegfloat - | Pabsfloat _ -> pabsfloat - | Paddfloat _ -> paddfloat - | Psubfloat _ -> psubfloat - | Pmulfloat _ -> pmulfloat - | Pdivfloat _ -> pdivfloat - | Pfloatcomp _ -> pfloatcomp - | Punboxed_float_comp _ -> punboxed_float_comp + | Pintoffloat Pfloat64 -> pintoffloat + | Pfloatofint (Pfloat64, _) -> pfloatofint + | Pnegfloat (Pfloat64, _) -> pnegfloat + | Pabsfloat (Pfloat64, _) -> pabsfloat + | Paddfloat (Pfloat64, _) -> paddfloat + | Psubfloat (Pfloat64, _) -> psubfloat + | Pmulfloat (Pfloat64, _) -> pmulfloat + | Pdivfloat (Pfloat64, _) -> pdivfloat + | Pfloatcomp (Pfloat64, _) -> pfloatcomp + | Punboxed_float_comp (Pfloat64, _) -> punboxed_float_comp | Pstringlength -> pstringlength | Pstringrefu -> pstringrefu | Pstringrefs -> pstringrefs @@ -489,8 +489,8 @@ 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_float Pfloat64 -> punbox_float + | Pbox_float (Pfloat64, _) -> pbox_float | Punbox_int _ -> punbox_int | Pbox_int _ -> pbox_int | Parray_of_iarray -> parray_of_iarray @@ -546,20 +546,20 @@ let of_primitive_arg : Lambda.primitive -> string = function | Pasrint -> pasrint_arg | Pintcomp _ -> pintcomp_arg | Pcompare_ints -> pcompare_ints_arg - | Pcompare_floats -> pcompare_floats_arg + | Pcompare_floats Pfloat64 -> pcompare_floats_arg | Pcompare_bints _ -> pcompare_bints_arg | Poffsetint _ -> poffsetint_arg | Poffsetref _ -> poffsetref_arg - | Pintoffloat -> pintoffloat_arg - | Pfloatofint _ -> pfloatofint_arg - | Pnegfloat _ -> pnegfloat_arg - | Pabsfloat _ -> pabsfloat_arg - | Paddfloat _ -> paddfloat_arg - | Psubfloat _ -> psubfloat_arg - | Pmulfloat _ -> pmulfloat_arg - | Pdivfloat _ -> pdivfloat_arg - | Pfloatcomp _ -> pfloatcomp_arg - | Punboxed_float_comp _ -> punboxed_float_comp_arg + | Pintoffloat Pfloat64 -> pintoffloat_arg + | Pfloatofint (Pfloat64, _) -> pfloatofint_arg + | Pnegfloat (Pfloat64, _) -> pnegfloat_arg + | Pabsfloat (Pfloat64, _) -> pabsfloat_arg + | Paddfloat (Pfloat64, _) -> paddfloat_arg + | Psubfloat (Pfloat64, _) -> psubfloat_arg + | Pmulfloat (Pfloat64, _) -> pmulfloat_arg + | Pdivfloat (Pfloat64, _) -> pdivfloat_arg + | Pfloatcomp (Pfloat64, _) -> pfloatcomp_arg + | Punboxed_float_comp (Pfloat64, _) -> punboxed_float_comp_arg | Pstringlength -> pstringlength_arg | Pstringrefu -> pstringrefu_arg | Pstringrefs -> pstringrefs_arg @@ -625,8 +625,8 @@ 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_float Pfloat64 -> punbox_float_arg + | Pbox_float (Pfloat64, _) -> pbox_float_arg | Punbox_int _ -> punbox_int_arg | Pbox_int _ -> pbox_int_arg | Parray_of_iarray -> parray_of_iarray_arg diff --git a/ocaml/middle_end/printclambda.ml b/ocaml/middle_end/printclambda.ml index 410e7c66974..1444500931d 100644 --- a/ocaml/middle_end/printclambda.ml +++ b/ocaml/middle_end/printclambda.ml @@ -29,12 +29,12 @@ let rec value_kind0 ppf kind = match kind with | Pgenval -> Format.pp_print_string ppf "" | Pintval -> Format.pp_print_string ppf ":int" - | Pfloatval -> Format.pp_print_string ppf ":float" + | Pboxedfloatval Pfloat64 -> Format.pp_print_string ppf ":float" | Parrayval Pgenarray -> Format.pp_print_string ppf ":genarray" | Parrayval Pintarray -> Format.pp_print_string ppf ":intarray" | Parrayval Pfloatarray -> Format.pp_print_string ppf ":floatarray" | Parrayval Paddrarray -> Format.pp_print_string ppf ":addrarray" - | Parrayval Punboxedfloatarray -> Format.pp_print_string ppf ":unboxedfloatarray" + | Parrayval Punboxedfloatarray Pfloat64 -> Format.pp_print_string ppf ":unboxedfloatarray" | Parrayval Punboxedintarray Pint32 -> Format.pp_print_string ppf "unboxedint32array" | Parrayval Punboxedintarray Pint64 -> Format.pp_print_string ppf "unboxedint64array" | Parrayval Punboxedintarray Pnativeint -> Format.pp_print_string ppf "unboxednativeintarray" @@ -62,7 +62,7 @@ let layout (layout : Lambda.layout) = | Pvalue kind -> value_kind kind | Ptop -> ":top" | Pbottom -> ":bottom" - | Punboxed_float -> ":unboxed_float" + | Punboxed_float Pfloat64 -> ":unboxed_float" | Punboxed_int Pint32 -> ":unboxed_int32" | Punboxed_int Pint64 -> ":unboxed_int64" | Punboxed_int Pnativeint -> ":unboxed_nativeint" diff --git a/ocaml/middle_end/printclambda_primitives.ml b/ocaml/middle_end/printclambda_primitives.ml index 0cd07e1faeb..27f25578814 100644 --- a/ocaml/middle_end/printclambda_primitives.ml +++ b/ocaml/middle_end/printclambda_primitives.ml @@ -21,6 +21,9 @@ let boxed_integer_name = function | Lambda.Pint32 -> "int32" | Lambda.Pint64 -> "int64" +let boxed_float_name = function + | Lambda.Pfloat64 -> "float" + let boxed_integer_mark name = function | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name @@ -30,6 +33,18 @@ let alloc_kind = function | Lambda.Alloc_heap -> "" | Lambda.Alloc_local -> "[L]" +let float_comparison = function + | Lambda.CFeq -> "==" + | Lambda.CFneq -> "!=" + | Lambda.CFlt -> "<" + | Lambda.CFnlt -> "!<" + | Lambda.CFle -> "<=" + | Lambda.CFnle -> "!<=" + | Lambda.CFgt -> ">" + | Lambda.CFngt -> "!>" + | Lambda.CFge -> ">=" + | Lambda.CFnge -> "!>=" + let print_boxed_integer name ppf bi m = fprintf ppf "%s%s" (boxed_integer_mark name bi) (alloc_kind m) @@ -42,6 +57,20 @@ let unboxed_integer_mark name bi m = let print_unboxed_integer name ppf bi m = fprintf ppf "%s" (unboxed_integer_mark name bi m);; +let boxed_float_mark name bf m = + match bf with + | Lambda.Pfloat64 -> Printf.sprintf "Float.%s%s" name (alloc_kind m) + +let print_boxed_float name ppf bf m = + fprintf ppf "%s" (boxed_float_mark name bf m);; + +let unboxed_float_mark name bf m = + match bf with + | Lambda.Pfloat64 -> Printf.sprintf "Float_u.%s%s" name (alloc_kind m) + +let print_unboxed_float name ppf bf m = + fprintf ppf "%s" (unboxed_float_mark name bf m);; + let array_kind array_kind = let open Lambda in match array_kind with @@ -49,7 +78,7 @@ let array_kind array_kind = | Paddrarray -> "addr" | Pintarray -> "int" | Pfloatarray -> "float" - | Punboxedfloatarray -> "unboxed_float" + | Punboxedfloatarray Pfloat64 -> "unboxed_float" | Punboxedintarray Pint32 -> "unboxed_int32" | Punboxedintarray Pint64 -> "unboxed_int64" | Punboxedintarray Pnativeint -> "unboxed_nativeint" @@ -65,7 +94,7 @@ let pp_array_ref_kind ppf k = | Paddrarray_ref -> fprintf ppf "addr" | Pintarray_ref -> fprintf ppf "int" | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode - | Punboxedfloatarray_ref -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_ref Pfloat64 -> fprintf ppf "unboxed_float" | Punboxedintarray_ref Pint32 -> fprintf ppf "unboxed_int32" | Punboxedintarray_ref Pint64 -> fprintf ppf "unboxed_int64" | Punboxedintarray_ref Pnativeint -> fprintf ppf "unboxed_nativeint" @@ -81,7 +110,7 @@ let pp_array_set_kind ppf k = | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode | Pintarray_set -> fprintf ppf "int" | Pfloatarray_set -> fprintf ppf "float" - | Punboxedfloatarray_set -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_set Pfloat64 -> fprintf ppf "unboxed_float" | Punboxedintarray_set Pint32 -> fprintf ppf "unboxed_int32" | Punboxedintarray_set Pint64 -> fprintf ppf "unboxed_int64" | Punboxedintarray_set Pnativeint -> fprintf ppf "unboxed_nativeint" @@ -215,21 +244,23 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Pasrint -> fprintf ppf "asr" | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp | Pcompare_ints -> fprintf ppf "compare_ints" - | Pcompare_floats -> fprintf ppf "compare_floats" + | Pcompare_floats bf -> fprintf ppf "compare_floats %s" (boxed_float_name bf) | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer_name bi) | Poffsetint n -> fprintf ppf "%i+" n | Poffsetref n -> fprintf ppf "+:=%i"n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint m -> fprintf ppf "float_of_int%s" (alloc_kind m) - | Pnegfloat m -> fprintf ppf "~.%s" (alloc_kind m) - | Pabsfloat m -> fprintf ppf "abs.%s" (alloc_kind m) - | Paddfloat m -> fprintf ppf "+.%s" (alloc_kind m) - | Psubfloat m -> fprintf ppf "-.%s" (alloc_kind m) - | Pmulfloat m -> fprintf ppf "*.%s" (alloc_kind m) - | Pdivfloat m -> fprintf ppf "/.%s" (alloc_kind m) - | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp - | Punboxed_float_comp(cmp) -> - fprintf ppf "%a (unboxed)" Printlambda.float_comparison cmp + | Pintoffloat bf -> fprintf ppf "int_of_%s" (boxed_float_name bf) + | Pfloatofint (bf,m) -> + fprintf ppf "%s_of_int%s" (boxed_float_name bf) (alloc_kind m) + | Pabsfloat (bf,m) -> print_boxed_float "abs" ppf bf m + | Pnegfloat (bf,m) -> print_boxed_float "neg" ppf bf m + | Paddfloat (bf,m) -> print_boxed_float "add" ppf bf m + | Psubfloat (bf,m) -> print_boxed_float "sub" ppf bf m + | Pmulfloat (bf,m) -> print_boxed_float "mul" ppf bf m + | Pdivfloat (bf,m) -> print_boxed_float "div" ppf bf m + | Pfloatcomp (bf,cmp) -> + print_boxed_float (float_comparison cmp) ppf bf alloc_heap + | Punboxed_float_comp (bf,cmp) -> + print_unboxed_float (float_comparison cmp) ppf bf alloc_heap | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" @@ -324,8 +355,9 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add" | 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_float (bf,m) -> + fprintf ppf "box_%s.%s" (boxed_float_name bf) (alloc_kind m) + | Punbox_float bf -> fprintf ppf "unbox_%s" (boxed_float_name bf) | 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) diff --git a/ocaml/middle_end/semantics_of_primitives.ml b/ocaml/middle_end/semantics_of_primitives.ml index 937f7a5ed02..864ecfc15f6 100644 --- a/ocaml/middle_end/semantics_of_primitives.ml +++ b/ocaml/middle_end/semantics_of_primitives.ml @@ -60,7 +60,7 @@ let for_primitive (prim : Clambda_primitives.primitive) = | Pasrint | Pintcomp _ | Punboxed_int_comp _ -> No_effects, No_coeffects - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ -> No_effects, No_coeffects | Pdivbint { is_safe = Unsafe } | Pmodbint { is_safe = Unsafe } @@ -74,18 +74,18 @@ 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 _ - | Punboxed_float_comp _ -> No_effects, No_coeffects - | Pbox_float m | Pbox_int (_, m) - | Pfloatofint m - | Pnegfloat m - | Pabsfloat m - | Paddfloat m - | Psubfloat m - | Pmulfloat m - | Pdivfloat m -> No_effects, coeffects_of m + | Punbox_float Pfloat64 | Punbox_int _ + | Pintoffloat Pfloat64 + | Pfloatcomp (Pfloat64, _) + | Punboxed_float_comp (Pfloat64, _) -> No_effects, No_coeffects + | Pbox_float (Pfloat64, m) | Pbox_int (_, m) + | Pfloatofint (Pfloat64, m) + | Pnegfloat (Pfloat64, m) + | Pabsfloat (Pfloat64, m) + | Paddfloat (Pfloat64, m) + | Psubfloat (Pfloat64, m) + | Pmulfloat (Pfloat64, m) + | Pdivfloat (Pfloat64, m) -> No_effects, coeffects_of m | Pstringlength | Pbyteslength | Parraylength _ -> No_effects, No_coeffects | Pisint @@ -165,13 +165,13 @@ type return_type = let return_type_of_primitive (prim:Clambda_primitives.primitive) = match prim with - | Pfloatofint _ - | Pnegfloat _ - | Pabsfloat _ - | Paddfloat _ - | Psubfloat _ - | Pmulfloat _ - | Pdivfloat _ + | Pfloatofint (Pfloat64, _) + | Pnegfloat (Pfloat64, _) + | Pabsfloat (Pfloat64, _) + | Paddfloat (Pfloat64, _) + | Psubfloat (Pfloat64, _) + | Pmulfloat (Pfloat64, _) + | Pdivfloat (Pfloat64, _) | Pfloatfield _ | Parrayrefu (Pfloatarray_ref _) | Parrayrefs (Pfloatarray_ref _) -> @@ -211,22 +211,22 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool = | Plsrint | Pasrint | Pintcomp _ -> false - | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Pcompare_ints | Pcompare_floats Pfloat64 | Pcompare_bints _ -> false | Poffsetint _ -> false | Poffsetref _ -> false - | Punbox_float | Punbox_int _ - | Pintoffloat - | Pfloatcomp _ - | Punboxed_float_comp _ -> false - | Pbox_float m | Pbox_int (_, m) - | Pfloatofint m - | Pnegfloat m - | Pabsfloat m - | Paddfloat m - | Psubfloat m - | Pmulfloat m - | Pdivfloat m -> is_local_alloc m + | Punbox_float Pfloat64 | Punbox_int _ + | Pintoffloat Pfloat64 + | Pfloatcomp (Pfloat64, _) + | Punboxed_float_comp (Pfloat64, _) -> false + | Pbox_float (Pfloat64, m) | Pbox_int (_, m) + | Pfloatofint (Pfloat64, m) + | Pnegfloat (Pfloat64, m) + | Pabsfloat (Pfloat64, m) + | Paddfloat (Pfloat64, m) + | Psubfloat (Pfloat64, m) + | Pmulfloat (Pfloat64, m) + | Pdivfloat (Pfloat64, m) -> is_local_alloc m | Pstringlength | Pbyteslength | Parraylength _ -> false | Pisint diff --git a/ocaml/testsuite/tests/translprim/comparison_table.heap.reference b/ocaml/testsuite/tests/translprim/comparison_table.heap.reference index 29c1b3a8cb3..e3827b05d06 100644 --- a/ocaml/testsuite/tests/translprim/comparison_table.heap.reference +++ b/ocaml/testsuite/tests/translprim/comparison_table.heap.reference @@ -7,7 +7,8 @@ intlike_cmp = (function {nlocal = 0} x[int] y[int] : int (compare_ints x y)) float_cmp = - (function {nlocal = 0} x[float] y[float] : int (compare_floats x y)) + (function {nlocal = 0} x[float] y[float] : int + (compare_floats float x y)) string_cmp = (function {nlocal = 0} x y : int (caml_string_compare x y)) int32_cmp = (function {nlocal = 0} x[int32] y[int32] : int @@ -22,7 +23,8 @@ int_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) bool_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) intlike_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) - float_eq = (function {nlocal = 0} x[float] y[float] : int (==. x y)) + float_eq = + (function {nlocal = 0} x[float] y[float] : int (Float.== x y)) string_eq = (function {nlocal = 0} x y : int (caml_string_equal x y)) int32_eq = (function {nlocal = 0} x[int32] y[int32] : int (Int32.== x y)) @@ -35,7 +37,8 @@ int_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) bool_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) intlike_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) - float_ne = (function {nlocal = 0} x[float] y[float] : int (!=. x y)) + float_ne = + (function {nlocal = 0} x[float] y[float] : int (Float.!= x y)) string_ne = (function {nlocal = 0} x y : int (caml_string_notequal x y)) int32_ne = (function {nlocal = 0} x[int32] y[int32] : int (Int32.!= x y)) @@ -48,7 +51,7 @@ int_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) bool_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) intlike_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) - float_lt = (function {nlocal = 0} x[float] y[float] : int (<. x y)) + float_lt = (function {nlocal = 0} x[float] y[float] : int (Float.< x y)) string_lt = (function {nlocal = 0} x y : int (caml_string_lessthan x y)) int32_lt = (function {nlocal = 0} x[int32] y[int32] : int (Int32.< x y)) int64_lt = (function {nlocal = 0} x[int64] y[int64] : int (Int64.< x y)) @@ -59,7 +62,7 @@ int_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) bool_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) intlike_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) - float_gt = (function {nlocal = 0} x[float] y[float] : int (>. x y)) + float_gt = (function {nlocal = 0} x[float] y[float] : int (Float.> x y)) string_gt = (function {nlocal = 0} x y : int (caml_string_greaterthan x y)) int32_gt = (function {nlocal = 0} x[int32] y[int32] : int (Int32.> x y)) @@ -71,7 +74,8 @@ int_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) bool_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) intlike_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) - float_le = (function {nlocal = 0} x[float] y[float] : int (<=. x y)) + float_le = + (function {nlocal = 0} x[float] y[float] : int (Float.<= x y)) string_le = (function {nlocal = 0} x y : int (caml_string_lessequal x y)) int32_le = @@ -85,7 +89,8 @@ int_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) bool_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) intlike_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) - float_ge = (function {nlocal = 0} x[float] y[float] : int (>=. x y)) + float_ge = + (function {nlocal = 0} x[float] y[float] : int (Float.>= x y)) string_ge = (function {nlocal = 0} x y : int (caml_string_greaterequal x y)) int32_ge = @@ -109,7 +114,11 @@ ignore assert all zero_alloc : int (compare_ints prim prim)) eta_float_cmp = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (compare_floats float prim prim)) +======= ignore assert all zero_alloc : int (compare_floats prim prim)) +>>>>>>> main eta_string_cmp = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_compare prim prim)) @@ -137,7 +146,11 @@ ignore assert all zero_alloc : int (== prim prim)) eta_float_eq = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.== prim prim)) +======= ignore assert all zero_alloc : int (==. prim prim)) +>>>>>>> main eta_string_eq = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_equal prim prim)) @@ -164,7 +177,11 @@ ignore assert all zero_alloc : int (!= prim prim)) eta_float_ne = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.!= prim prim)) +======= ignore assert all zero_alloc : int (!=. prim prim)) +>>>>>>> main eta_string_ne = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_notequal prim prim)) @@ -191,7 +208,11 @@ ignore assert all zero_alloc : int (< prim prim)) eta_float_lt = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.< prim prim)) +======= ignore assert all zero_alloc : int (<. prim prim)) +>>>>>>> main eta_string_lt = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_lessthan prim prim)) @@ -218,7 +239,11 @@ ignore assert all zero_alloc : int (> prim prim)) eta_float_gt = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.> prim prim)) +======= ignore assert all zero_alloc : int (>. prim prim)) +>>>>>>> main eta_string_gt = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_greaterthan prim prim)) @@ -245,7 +270,11 @@ ignore assert all zero_alloc : int (<= prim prim)) eta_float_le = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.<= prim prim)) +======= ignore assert all zero_alloc : int (<=. prim prim)) +>>>>>>> main eta_string_le = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_lessequal prim prim)) @@ -272,7 +301,11 @@ ignore assert all zero_alloc : int (>= prim prim)) eta_float_ge = (function {nlocal = 0} prim[float] prim[float] stub +<<<<<<< HEAD + ignore assert all zero_alloc : int (Float.>= prim prim)) +======= ignore assert all zero_alloc : int (>=. prim prim)) +>>>>>>> main eta_string_ge = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_greaterequal prim prim)) diff --git a/ocaml/testsuite/tests/translprim/comparison_table.stack.reference b/ocaml/testsuite/tests/translprim/comparison_table.stack.reference index c4a57b9796b..30ebad6ac6f 100644 --- a/ocaml/testsuite/tests/translprim/comparison_table.stack.reference +++ b/ocaml/testsuite/tests/translprim/comparison_table.stack.reference @@ -7,7 +7,8 @@ intlike_cmp = (function {nlocal = 0} x[int] y[int] : int (compare_ints x y)) float_cmp = - (function {nlocal = 0} x[float] y[float] : int (compare_floats x y)) + (function {nlocal = 0} x[float] y[float] : int + (compare_floats float x y)) string_cmp = (function {nlocal = 0} x y : int (caml_string_compare x y)) int32_cmp = (function {nlocal = 0} x[int32] y[int32] : int @@ -22,7 +23,8 @@ int_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) bool_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) intlike_eq = (function {nlocal = 0} x[int] y[int] : int (== x y)) - float_eq = (function {nlocal = 0} x[float] y[float] : int (==. x y)) + float_eq = + (function {nlocal = 0} x[float] y[float] : int (Float.== x y)) string_eq = (function {nlocal = 0} x y : int (caml_string_equal x y)) int32_eq = (function {nlocal = 0} x[int32] y[int32] : int (Int32.== x y)) @@ -35,7 +37,8 @@ int_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) bool_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) intlike_ne = (function {nlocal = 0} x[int] y[int] : int (!= x y)) - float_ne = (function {nlocal = 0} x[float] y[float] : int (!=. x y)) + float_ne = + (function {nlocal = 0} x[float] y[float] : int (Float.!= x y)) string_ne = (function {nlocal = 0} x y : int (caml_string_notequal x y)) int32_ne = (function {nlocal = 0} x[int32] y[int32] : int (Int32.!= x y)) @@ -48,7 +51,7 @@ int_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) bool_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) intlike_lt = (function {nlocal = 0} x[int] y[int] : int (< x y)) - float_lt = (function {nlocal = 0} x[float] y[float] : int (<. x y)) + float_lt = (function {nlocal = 0} x[float] y[float] : int (Float.< x y)) string_lt = (function {nlocal = 0} x y : int (caml_string_lessthan x y)) int32_lt = (function {nlocal = 0} x[int32] y[int32] : int (Int32.< x y)) int64_lt = (function {nlocal = 0} x[int64] y[int64] : int (Int64.< x y)) @@ -59,7 +62,7 @@ int_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) bool_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) intlike_gt = (function {nlocal = 0} x[int] y[int] : int (> x y)) - float_gt = (function {nlocal = 0} x[float] y[float] : int (>. x y)) + float_gt = (function {nlocal = 0} x[float] y[float] : int (Float.> x y)) string_gt = (function {nlocal = 0} x y : int (caml_string_greaterthan x y)) int32_gt = (function {nlocal = 0} x[int32] y[int32] : int (Int32.> x y)) @@ -71,7 +74,8 @@ int_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) bool_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) intlike_le = (function {nlocal = 0} x[int] y[int] : int (<= x y)) - float_le = (function {nlocal = 0} x[float] y[float] : int (<=. x y)) + float_le = + (function {nlocal = 0} x[float] y[float] : int (Float.<= x y)) string_le = (function {nlocal = 0} x y : int (caml_string_lessequal x y)) int32_le = @@ -85,7 +89,8 @@ int_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) bool_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) intlike_ge = (function {nlocal = 0} x[int] y[int] : int (>= x y)) - float_ge = (function {nlocal = 0} x[float] y[float] : int (>=. x y)) + float_ge = + (function {nlocal = 0} x[float] y[float] : int (Float.>= x y)) string_ge = (function {nlocal = 0} x y : int (caml_string_greaterequal x y)) int32_ge = @@ -109,7 +114,7 @@ ignore assert all zero_alloc : int (compare_ints prim prim)) eta_float_cmp = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (compare_floats prim prim)) + ignore assert all zero_alloc : int (compare_floats float prim prim)) eta_string_cmp = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_compare prim prim)) @@ -137,7 +142,7 @@ ignore assert all zero_alloc : int (== prim prim)) eta_float_eq = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (==. prim prim)) + ignore assert all zero_alloc : int (Float.== prim prim)) eta_string_eq = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_equal prim prim)) @@ -164,7 +169,7 @@ ignore assert all zero_alloc : int (!= prim prim)) eta_float_ne = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (!=. prim prim)) + ignore assert all zero_alloc : int (Float.!= prim prim)) eta_string_ne = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_notequal prim prim)) @@ -191,7 +196,7 @@ ignore assert all zero_alloc : int (< prim prim)) eta_float_lt = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (<. prim prim)) + ignore assert all zero_alloc : int (Float.< prim prim)) eta_string_lt = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_lessthan prim prim)) @@ -218,7 +223,7 @@ ignore assert all zero_alloc : int (> prim prim)) eta_float_gt = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (>. prim prim)) + ignore assert all zero_alloc : int (Float.> prim prim)) eta_string_gt = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_greaterthan prim prim)) @@ -245,7 +250,7 @@ ignore assert all zero_alloc : int (<= prim prim)) eta_float_le = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (<=. prim prim)) + ignore assert all zero_alloc : int (Float.<= prim prim)) eta_string_le = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_lessequal prim prim)) @@ -272,7 +277,7 @@ ignore assert all zero_alloc : int (>= prim prim)) eta_float_ge = (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (>=. prim prim)) + ignore assert all zero_alloc : int (Float.>= prim prim)) eta_string_ge = (function {nlocal = 0} prim prim stub ignore assert all zero_alloc : int (caml_string_greaterequal prim prim)) diff --git a/ocaml/testsuite/tests/translprim/module_coercion.compilers.flat.reference b/ocaml/testsuite/tests/translprim/module_coercion.compilers.flat.reference index cc3d191f07d..4ff742cba21 100644 --- a/ocaml/testsuite/tests/translprim/module_coercion.compilers.flat.reference +++ b/ocaml/testsuite/tests/translprim/module_coercion.compilers.flat.reference @@ -43,19 +43,20 @@ ignore assert all zero_alloc : int (array.unsafe_set[float] prim prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (compare_floats prim prim)) + ignore assert all zero_alloc : int + (compare_floats float prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (==. prim prim)) + ignore assert all zero_alloc : int (Float.== prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (!=. prim prim)) + ignore assert all zero_alloc : int (Float.!= prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (<. prim prim)) + ignore assert all zero_alloc : int (Float.< prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (>. prim prim)) + ignore assert all zero_alloc : int (Float.> prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (<=. prim prim)) + ignore assert all zero_alloc : int (Float.<= prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - ignore assert all zero_alloc : int (>=. prim prim))) + ignore assert all zero_alloc : int (Float.>= prim prim))) (makeblock 0 (function {nlocal = 0} prim[addrarray] stub ignore assert all zero_alloc : int (array.length[addr] prim)) diff --git a/ocaml/testsuite/tests/translprim/module_coercion.compilers.no-flat.reference b/ocaml/testsuite/tests/translprim/module_coercion.compilers.no-flat.reference index d63bd7da813..0014464a379 100644 --- a/ocaml/testsuite/tests/translprim/module_coercion.compilers.no-flat.reference +++ b/ocaml/testsuite/tests/translprim/module_coercion.compilers.no-flat.reference @@ -31,13 +31,20 @@ (function {nlocal = 0} prim[addrarray] prim[int] prim[float] stub (array.unsafe_set[addr] prim prim prim)) (function {nlocal = 0} prim[float] prim[float] stub - (compare_floats prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (==. prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (!=. prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (<. prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (>. prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (<=. prim prim)) - (function {nlocal = 0} prim[float] prim[float] stub (>=. prim prim))) + ignore assert all zero_alloc : int + (compare_floats float prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.== prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.!= prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.< prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.> prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.<= prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (Float.>= prim prim))) (makeblock 0 (function {nlocal = 0} prim[addrarray] stub (array.length[addr] prim)) diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index 42baefb6228..017c0edf45f 100644 --- a/ocaml/typing/primitive.ml +++ b/ocaml/typing/primitive.ml @@ -22,11 +22,13 @@ type boxed_integer = Pnativeint | Pint32 | Pint64 type vec128_type = Int8x16 | Int16x8 | Int32x4 | Int64x2 | Float32x4 | Float64x2 +type boxed_float = Pfloat64 + type boxed_vector = Pvec128 of vec128_type type native_repr = | Same_as_ocaml_repr of Jkind.Sort.const - | Unboxed_float + | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer | Untagged_int @@ -66,7 +68,7 @@ type value_check = Bad_attribute | Bad_layout | Ok_value let check_ocaml_value = function | _, Same_as_ocaml_repr Value -> Ok_value | _, Same_as_ocaml_repr _ -> Bad_layout - | _, Unboxed_float + | _, Unboxed_float Pfloat64 | _, Unboxed_vector _ | _, Unboxed_integer _ | _, Untagged_int -> Bad_attribute @@ -74,14 +76,14 @@ let check_ocaml_value = function let is_unboxed = function | _, Same_as_ocaml_repr _ | _, Untagged_int -> false - | _, Unboxed_float + | _, Unboxed_float Pfloat64 | _, Unboxed_vector _ | _, Unboxed_integer _ -> true let is_untagged = function | _, Untagged_int -> true | _, Same_as_ocaml_repr _ - | _, Unboxed_float + | _, Unboxed_float Pfloat64 | _, Unboxed_vector _ | _, Unboxed_integer _ -> false @@ -204,8 +206,8 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res = Inconsistent_noalloc_attributes_for_effects)); let native_repr_args, native_repr_res = if old_style_float then - (make_native_repr_args arity (Prim_global, Unboxed_float), - (Prim_global, Unboxed_float)) + (make_native_repr_args arity (Prim_global, Unboxed_float Pfloat64), + (Prim_global, Unboxed_float Pfloat64)) else (native_repr_args, native_repr_res) in @@ -284,7 +286,7 @@ let print p osig_val_decl = @ (match repr with | Same_as_ocaml_repr _ -> [] - | Unboxed_float + | Unboxed_float Pfloat64 | Unboxed_vector _ | Unboxed_integer _ -> if all_unboxed then [] else [oattr_unboxed] | Untagged_int -> if all_untagged then [] else [oattr_untagged]) @@ -323,6 +325,10 @@ let equal_boxed_integer bi1 bi2 = | (Pnativeint | Pint32 | Pint64), _ -> false +let equal_boxed_float f1 f2 = + match f1, f2 with + | Pfloat64, Pfloat64 -> true + let equal_boxed_vector_size bi1 bi2 = (* For the purposes of layouts/native representations, all 128-bit vector types are equal. *) @@ -333,19 +339,24 @@ let equal_native_repr nr1 nr2 = match nr1, nr2 with | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Jkind.Sort.equal_const s1 s2 | Same_as_ocaml_repr _, - (Unboxed_float | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> false - | Unboxed_float, Unboxed_float -> true - | Unboxed_float, - (Same_as_ocaml_repr _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> false + (Unboxed_float Pfloat64 | Unboxed_integer _ | Untagged_int | + Unboxed_vector _) -> false + | Unboxed_float f1, Unboxed_float f2 -> equal_boxed_float f1 f2 + | Unboxed_float Pfloat64, + (Same_as_ocaml_repr _ | Unboxed_integer _ | Untagged_int | + Unboxed_vector _) -> false | Unboxed_vector vi1, Unboxed_vector vi2 -> equal_boxed_vector_size vi1 vi2 | Unboxed_vector _, - (Same_as_ocaml_repr _ | Unboxed_float | Untagged_int | Unboxed_integer _) -> false + (Same_as_ocaml_repr _ | Unboxed_float Pfloat64 | Untagged_int | + Unboxed_integer _) -> false | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 | Unboxed_integer _, - (Same_as_ocaml_repr _ | Unboxed_float | Untagged_int | Unboxed_vector _) -> false + (Same_as_ocaml_repr _ | Unboxed_float Pfloat64 | Untagged_int | + Unboxed_vector _) -> false | Untagged_int, Untagged_int -> true | Untagged_int, - (Same_as_ocaml_repr _ | Unboxed_float | Unboxed_integer _ | Unboxed_vector _) -> false + (Same_as_ocaml_repr _ | Unboxed_float Pfloat64 | Unboxed_integer _ | + Unboxed_vector _) -> false let equal_effects ef1 ef2 = match ef1, ef2 with @@ -369,7 +380,9 @@ let native_name_is_external p = let sort_of_native_repr = function | Same_as_ocaml_repr s -> s - | (Unboxed_float | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> Jkind.Sort.Value + | (Unboxed_float Pfloat64 | Unboxed_integer _ | Untagged_int | + Unboxed_vector _) -> + Jkind.Sort.Value let report_error ppf err = match err with diff --git a/ocaml/typing/primitive.mli b/ocaml/typing/primitive.mli index cf801a2ac4e..1a32ec1d114 100644 --- a/ocaml/typing/primitive.mli +++ b/ocaml/typing/primitive.mli @@ -17,6 +17,8 @@ type boxed_integer = Pnativeint | Pint32 | Pint64 +type boxed_float = Pfloat64 + type vec128_type = Int8x16 | Int16x8 | Int32x4 | Int64x2 | Float32x4 | Float64x2 type boxed_vector = Pvec128 of vec128_type @@ -25,7 +27,7 @@ type boxed_vector = Pvec128 of vec128_type of a primitive *) type native_repr = | Same_as_ocaml_repr of Jkind.Sort.const - | Unboxed_float + | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer | Untagged_int @@ -94,6 +96,7 @@ val byte_name: description -> string val vec128_name: vec128_type -> string val equal_boxed_integer : boxed_integer -> boxed_integer -> bool +val equal_boxed_float : boxed_float -> boxed_float -> bool val equal_boxed_vector_size : boxed_vector -> boxed_vector -> bool val equal_native_repr : native_repr -> native_repr -> bool val equal_effects : effects -> effects -> bool diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index 8982171b6f7..4a8ee82f0f2 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -526,7 +526,7 @@ let array_mode exp = match Typeopt.array_kind exp with | Lambda.Paddrarray | Lambda.Pintarray -> (* non-generic, non-float arrays act as constructors *) Guard - | Lambda.Punboxedfloatarray | Lambda.Punboxedintarray _ -> + | Lambda.Punboxedfloatarray Pfloat64 | Lambda.Punboxedintarray _ -> Guard (* Expression judgment: diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index 7a087d63c42..08fcee6a583 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -2176,7 +2176,7 @@ let native_repr_of_type env kind ty = | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int -> Some Untagged_int | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> - Some Unboxed_float + Some (Unboxed_float Pfloat64) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 -> Some (Unboxed_integer Pint32) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 -> diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 982251bb036..db5a83dfc4d 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -324,7 +324,7 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | Tconstr(p, _, _) when Path.same p Predef.path_char -> num_nodes_visited, Pintval | Tconstr(p, _, _) when Path.same p Predef.path_float -> - num_nodes_visited, Pfloatval + num_nodes_visited, (Pboxedfloatval Pfloat64) | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> num_nodes_visited, (Pboxedintval Pint32) | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> @@ -521,11 +521,11 @@ and value_kind_record env ~loc ~visited ~depth ~num_nodes_visited out void. *) match rep with | Record_float | Record_ufloat -> - (* We're using the `Pfloatval` value kind for unboxed floats. + (* We're using the `Pboxedfloatval` value kind for unboxed floats. This is kind of a lie (there are unboxed floats in here, not boxed floats), but that was already happening here due to the float record optimization. *) - num_nodes_visited, Pfloatval + num_nodes_visited, Pboxedfloatval Pfloat64 | Record_boxed _ | Record_inlined _ | Record_unboxed -> value_kind env ~loc ~visited ~depth ~num_nodes_visited label.ld_type @@ -565,7 +565,7 @@ let[@inline always] layout_of_const_sort_generic ~value_kind ~error : Jkind.Sort.const -> _ = function | Value -> Lambda.Pvalue (Lazy.force value_kind) | Float64 when Language_extension.(is_at_least Layouts Stable) -> - Lambda.Punboxed_float + Lambda.Punboxed_float Pfloat64 | Word when Language_extension.(is_at_least Layouts Stable) -> Lambda.Punboxed_int Pnativeint | Bits32 when Language_extension.(is_at_least Layouts Stable) -> @@ -662,7 +662,8 @@ let rec layout_union l1 l2 = | l, Pbottom -> l | Pvalue layout1, Pvalue layout2 -> Pvalue (value_kind_union layout1 layout2) - | Punboxed_float, Punboxed_float -> Punboxed_float + | Punboxed_float f1, Punboxed_float f2 -> + if equal_boxed_float f1 f2 then l1 else Ptop | Punboxed_int bi1, Punboxed_int bi2 -> if equal_boxed_integer bi1 bi2 then l1 else Ptop | Punboxed_vector vi1, Punboxed_vector vi2 -> @@ -670,7 +671,8 @@ let rec layout_union l1 l2 = | Punboxed_product layouts1, Punboxed_product layouts2 -> if List.compare_lengths layouts1 layouts2 <> 0 then Ptop else Punboxed_product (List.map2 layout_union layouts1 layouts2) - | (Ptop | Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _ | Punboxed_product _), + | (Ptop | Pvalue _ | Punboxed_float Pfloat64 | Punboxed_int _ | + Punboxed_vector _ | Punboxed_product _), _ -> Ptop