Skip to content

Commit 4769d5a

Browse files
TheNumbatTheNumbat
committed
squash for review
1 parent 4d53751 commit 4769d5a

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

42 files changed

+819
-565
lines changed

‎backend/cmm_helpers.ml

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1241,7 +1241,7 @@ module Extended_machtype = struct
12411241
| Ptop -> Misc.fatal_error "No Extended_machtype for layout [Ptop]"
12421242
| Pbottom ->
12431243
Misc.fatal_error "No unique Extended_machtype for layout [Pbottom]"
1244-
| Punboxed_float -> typ_float
1244+
| Punboxed_float Pfloat64 -> typ_float
12451245
| Punboxed_vector (Pvec128 _) -> typ_vec128
12461246
| Punboxed_int _ ->
12471247
(* Only 64-bit architectures, so this is always [typ_int] *)
@@ -2817,7 +2817,7 @@ let arraylength kind arg dbg =
28172817
Cop (Cor, [len; Cconst_int (1, dbg)], dbg)
28182818
| Paddrarray | Pintarray ->
28192819
Cop (Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
2820-
| Pfloatarray | Punboxedfloatarray ->
2820+
| Pfloatarray | Punboxedfloatarray Pfloat64 ->
28212821
(* Note: we only support 64 bit targets now, so this is ok for
28222822
Punboxedfloatarray *)
28232823
Cop (Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
@@ -3602,12 +3602,13 @@ let transl_attrib : Lambda.check_attribute -> Cmm.codegen_option list = function
36023602

36033603
let kind_of_layout (layout : Lambda.layout) =
36043604
match layout with
3605-
| Pvalue Pfloatval -> Boxed_float
3605+
| Pvalue (Pboxedfloatval Pfloat64) -> Boxed_float
36063606
| Pvalue (Pboxedintval bi) -> Boxed_integer bi
36073607
| Pvalue (Pboxedvectorval vi) -> Boxed_vector vi
36083608
| Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _)
3609-
| Ptop | Pbottom | Punboxed_float | Punboxed_int _ | Punboxed_vector _
3610-
| Punboxed_product _ ->
3609+
| Ptop | Pbottom
3610+
| Punboxed_float Pfloat64
3611+
| Punboxed_int _ | Punboxed_vector _ | Punboxed_product _ ->
36113612
Any
36123613

36133614
(* Atomics *)

‎middle_end/flambda2/from_lambda/closure_conversion.ml

Lines changed: 38 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -503,7 +503,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
503503
let box_return_value =
504504
match prim_native_repr_res with
505505
| _, Same_as_ocaml_repr _ -> None
506-
| _, Unboxed_float -> Some (P.Box_number (Naked_float, alloc_mode))
506+
| _, Unboxed_float Pfloat64 -> Some (P.Box_number (Naked_float, alloc_mode))
507507
| _, Unboxed_integer Pnativeint ->
508508
Some (P.Box_number (Naked_nativeint, alloc_mode))
509509
| _, 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
531531
kind
532532
(from_lambda_values_and_unboxed_numbers_only
533533
(Typeopt.layout_of_const_sort sort)))
534-
| Unboxed_float -> K.naked_float
534+
| Unboxed_float Pfloat64 -> K.naked_float
535535
| Unboxed_integer Pnativeint -> K.naked_nativeint
536536
| Unboxed_integer Pint32 -> K.naked_int32
537537
| Unboxed_integer Pint64 -> K.naked_int64
@@ -577,7 +577,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
577577
then Misc.fatal_errorf "Expected arity one for %s" prim_native_name
578578
else
579579
match prim_native_repr_args, prim_native_repr_res with
580-
| [(_, Unboxed_integer Pint64)], (_, Unboxed_float) -> (
580+
| [(_, Unboxed_integer Pint64)], (_, Unboxed_float Pfloat64) -> (
581581
match args with
582582
| [arg] ->
583583
let result = Variable.create "reinterpreted_int64" in
@@ -620,7 +620,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
620620
let unbox_arg : P.unary_primitive option =
621621
match arg_repr with
622622
| _, Same_as_ocaml_repr _ -> None
623-
| _, Unboxed_float -> Some (P.Unbox_number Naked_float)
623+
| _, Unboxed_float Pfloat64 -> Some (P.Unbox_number Naked_float)
624624
| _, Unboxed_integer Pnativeint ->
625625
Some (P.Unbox_number Naked_nativeint)
626626
| _, Unboxed_integer Pint32 -> Some (P.Unbox_number Naked_int32)
@@ -808,29 +808,40 @@ let close_primitive acc env ~let_bound_ids_with_kinds named
808808
| Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint
809809
| Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint
810810
| Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints
811-
| Pcompare_floats | Pcompare_bints _ | Poffsetint _ | Poffsetref _
812-
| Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _
813-
| Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _
814-
| Punboxed_float_comp _ | Pstringlength | Pstringrefu | Pstringrefs
815-
| Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
816-
| Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
817-
| Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pbintofint _
818-
| Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _
819-
| Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _
820-
| Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _
821-
| Punboxed_int_comp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _
822-
| Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _
823-
| Pstring_load_128 _ | Pbytes_load_16 _ | Pbytes_load_32 _
824-
| Pbytes_load_64 _ | Pbytes_load_128 _ | Pbytes_set_16 _ | Pbytes_set_32 _
825-
| Pbytes_set_64 _ | Pbytes_set_128 _ | Pbigstring_load_16 _
826-
| Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_load_128 _
827-
| Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
828-
| Pbigstring_set_128 _ | Pctconst _ | Pbswap16 | Pbbswap _
829-
| Pint_as_pointer _ | Popaque _ | Pprobe_is_enabled _ | Pobj_dup
830-
| Pobj_magic _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
831-
| Pmake_unboxed_product _ | Punboxed_product_field _ | Pget_header _
832-
| Prunstack | Pperform | Presume | Preperform | Patomic_exchange
833-
| Patomic_cas | Patomic_fetch_add | Pdls_get | Patomic_load _ ->
811+
| Pcompare_floats Pfloat64
812+
| Pcompare_bints _ | Poffsetint _ | Poffsetref _
813+
| Pintoffloat Pfloat64
814+
| Pfloatofint (Pfloat64, _)
815+
| Pnegfloat (Pfloat64, _)
816+
| Pabsfloat (Pfloat64, _)
817+
| Paddfloat (Pfloat64, _)
818+
| Psubfloat (Pfloat64, _)
819+
| Pmulfloat (Pfloat64, _)
820+
| Pdivfloat (Pfloat64, _)
821+
| Pfloatcomp (Pfloat64, _)
822+
| Punboxed_float_comp (Pfloat64, _)
823+
| Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu
824+
| Pbytessetu | Pbytesrefs | Pbytessets | Pduparray _ | Parraylength _
825+
| Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Pisint _
826+
| Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
827+
| Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _
828+
| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
829+
| Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _ | Pbigarrayref _
830+
| Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _
831+
| Pstring_load_64 _ | Pstring_load_128 _ | Pbytes_load_16 _
832+
| Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _
833+
| Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _
834+
| Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _
835+
| Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _
836+
| Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pctconst _ | Pbswap16
837+
| Pbbswap _ | Pint_as_pointer _ | Popaque _ | Pprobe_is_enabled _
838+
| Pobj_dup | Pobj_magic _
839+
| Punbox_float Pfloat64
840+
| Pbox_float (Pfloat64, _)
841+
| Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _
842+
| Punboxed_product_field _ | Pget_header _ | Prunstack | Pperform
843+
| Presume | Preperform | Patomic_exchange | Patomic_cas
844+
| Patomic_fetch_add | Pdls_get | Patomic_load _ ->
834845
(* Inconsistent with outer match *)
835846
assert false
836847
in

‎middle_end/flambda2/from_lambda/lambda_to_flambda.ml

Lines changed: 46 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -272,22 +272,26 @@ let transform_primitive env (prim : L.primitive) args loc =
272272
Misc.fatal_errorf "Pmakeblock with wrong or non-scannable block tag %d" tag
273273
| Pmakefloatblock (_mut, _mode), args when List.length args < 1 ->
274274
Misc.fatal_errorf "Pmakefloatblock must have at least one argument"
275-
| Pfloatcomp CFnlt, args ->
276-
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFlt, args, loc)], loc)
277-
| Pfloatcomp CFngt, args ->
278-
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFgt, args, loc)], loc)
279-
| Pfloatcomp CFnle, args ->
280-
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFle, args, loc)], loc)
281-
| Pfloatcomp CFnge, args ->
282-
Primitive (L.Pnot, [L.Lprim (Pfloatcomp CFge, args, loc)], loc)
283-
| Punboxed_float_comp CFnlt, args ->
284-
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFlt, args, loc)], loc)
285-
| Punboxed_float_comp CFngt, args ->
286-
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFgt, args, loc)], loc)
287-
| Punboxed_float_comp CFnle, args ->
288-
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFle, args, loc)], loc)
289-
| Punboxed_float_comp CFnge, args ->
290-
Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp CFge, args, loc)], loc)
275+
| Pfloatcomp (bf, CFnlt), args ->
276+
Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFlt), args, loc)], loc)
277+
| Pfloatcomp (bf, CFngt), args ->
278+
Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFgt), args, loc)], loc)
279+
| Pfloatcomp (bf, CFnle), args ->
280+
Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFle), args, loc)], loc)
281+
| Pfloatcomp (bf, CFnge), args ->
282+
Primitive (L.Pnot, [L.Lprim (Pfloatcomp (bf, CFge), args, loc)], loc)
283+
| Punboxed_float_comp (bf, CFnlt), args ->
284+
Primitive
285+
(L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFlt), args, loc)], loc)
286+
| Punboxed_float_comp (bf, CFngt), args ->
287+
Primitive
288+
(L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFgt), args, loc)], loc)
289+
| Punboxed_float_comp (bf, CFnle), args ->
290+
Primitive
291+
(L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFle), args, loc)], loc)
292+
| Punboxed_float_comp (bf, CFnge), args ->
293+
Primitive
294+
(L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFge), args, loc)], loc)
291295
| Pbigarrayref (_unsafe, num_dimensions, kind, layout), args -> (
292296
match
293297
P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout
@@ -605,14 +609,23 @@ let primitive_can_raise (prim : Lambda.primitive) =
605609
| Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
606610
| Pmakeufloatblock _ | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor
607611
| Pnot | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint
608-
| Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats
609-
| Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _
610-
| Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
611-
| Pdivfloat _ | Pfloatcomp _ | Punboxed_float_comp _ | Pstringlength
612-
| Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu | Pmakearray _
613-
| Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _
614-
| Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _
615-
| Psubbint _ | Pmulbint _
612+
| Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints
613+
| Pcompare_floats Pfloat64
614+
| Pcompare_bints _ | Poffsetint _ | Poffsetref _
615+
| Pintoffloat Pfloat64
616+
| Pfloatofint (Pfloat64, _)
617+
| Pnegfloat (Pfloat64, _)
618+
| Pabsfloat (Pfloat64, _)
619+
| Paddfloat (Pfloat64, _)
620+
| Psubfloat (Pfloat64, _)
621+
| Pmulfloat (Pfloat64, _)
622+
| Pdivfloat (Pfloat64, _)
623+
| Pfloatcomp (Pfloat64, _)
624+
| Punboxed_float_comp (Pfloat64, _)
625+
| Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu
626+
| Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _
627+
| Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _
628+
| Paddbint _ | Psubbint _ | Pmulbint _
616629
| Pdivbint { is_safe = Unsafe; _ }
617630
| Pmodbint { is_safe = Unsafe; _ }
618631
| Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _
@@ -654,7 +667,9 @@ let primitive_can_raise (prim : Lambda.primitive) =
654667
| Pbigstring_set_64 true
655668
| Pbigstring_set_128 { unsafe = true; _ }
656669
| Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque _
657-
| Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float
670+
| Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _
671+
| Pbox_float (Pfloat64, _)
672+
| Punbox_float Pfloat64
658673
| Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _
659674
| Punboxed_product_field _ | Pget_header _ ->
660675
false
@@ -848,7 +863,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
848863
match layout with
849864
| Ptop | Pbottom ->
850865
Misc.fatal_error "Cannot bind layout [Ptop] or [Pbottom]"
851-
| Pvalue _ | Punboxed_int _ | Punboxed_float | Punboxed_vector _ ->
866+
| Pvalue _ | Punboxed_int _
867+
| Punboxed_float Pfloat64
868+
| Punboxed_vector _ ->
852869
( env,
853870
[ ( id,
854871
Flambda_kind.With_subkind
@@ -971,8 +988,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation)
971988
let id = Ident.create_local name in
972989
let result_layout = L.primitive_result_layout prim in
973990
(match result_layout with
974-
| Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _
975-
| Punboxed_product _ ->
991+
| Pvalue _
992+
| Punboxed_float Pfloat64
993+
| Punboxed_int _ | Punboxed_vector _ | Punboxed_product _ ->
976994
()
977995
| Ptop | Pbottom ->
978996
Misc.fatal_errorf "Invalid result layout %a for primitive %a"

0 commit comments

Comments
 (0)