diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index a44ae8ae58e..3932b06aa4f 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -227,31 +227,72 @@ let equal (x: primitive) (y: primitive) = x = y let result_layout (p : primitive) = match p with - | Punbox_float -> Lambda.Punboxed_float - | Punbox_int bi -> Lambda.Punboxed_int bi - | Pmake_unboxed_product layouts -> Lambda.Punboxed_product layouts - | Punboxed_product_field (field, layouts) -> List.nth layouts field - | Pccall {prim_native_repr_res = (_, repr_res); _} -> - Lambda.layout_of_native_repr repr_res - | Pufloatfield _ -> Lambda.Punboxed_float - | Pread_symbol _ | Pmakeblock _ | Pmakeufloatblock _ | Pfield _ - | Pfield_computed | Psetfield _ | Psetfield_computed _ | Pfloatfield _ - | Psetfloatfield _ | Psetufloatfield _ | Pduprecord _ | Praise _ - | 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 _ | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ - | Parrayrefs _ | Parraysets _ | Pisint | Pisout | Pbintofint _ | Pintofbint _ - | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ - | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ + | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _ + | Psetufloatfield _ + | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _ + -> Lambda.layout_unit + | Pmakeblock _ | Pmakearray _ | Pduprecord _ + | Pmakeufloatblock _ + | Pduparray _ | Pbigarraydim _ -> Lambda.layout_block + | Pfield _ | Pfield_computed -> Lambda.layout_field + | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) + | Pmake_unboxed_product layouts -> Lambda.layout_unboxed_product layouts + | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ + | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ + | Pbox_float _ -> Lambda.layout_boxed_float + | Pufloatfield _ | Punbox_float -> Punboxed_float + | Pccall { prim_native_repr_res = _, repr_res } -> Lambda.layout_of_native_repr repr_res + | Praise _ -> Lambda.layout_bottom + | Psequor | Psequand | Pnot + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint _ | Pmodint _ + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp _ + | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Poffsetint _ | Pintoffloat | Pfloatcomp _ + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytesrefs + | Parraylength _ | Pisint | Pisout | Pintofbint _ + | Pbintcomp _ + | Pprobe_is_enabled _ | Pbswap16 + -> Lambda.layout_int + | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> + Lambda.array_ref_kind_result_layout array_ref_kind + | Pbintofint (bi, _) | Pcvtbint (_,bi,_) + | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) + | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi} + | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _) + | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _) + | Pbbswap (bi, _) | Pbox_int (bi, _) -> + Lambda.layout_boxedint bi + | Punbox_int bi -> Punboxed_int bi + | Pbigarrayref (_, _, kind, _) -> + begin match kind with + | Pbigarray_unknown -> Lambda.layout_any_value + | Pbigarray_float32 | Pbigarray_float64 -> Lambda.layout_boxed_float + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_caml_int -> Lambda.layout_int + | Pbigarray_int32 -> Lambda.layout_boxedint Pint32 + | Pbigarray_int64 -> Lambda.layout_boxedint Pint64 + | Pbigarray_native_int -> Lambda.layout_boxedint Pnativeint + | Pbigarray_complex32 | Pbigarray_complex64 -> + Lambda.layout_block + end + | Pint_as_pointer _ -> + (* CR ncourant: use an unboxed int64 here when it exists *) + Lambda.layout_any_value + | Pget_header _ -> Lambda.layout_boxedint Pnativeint + | Prunstack | Presume | Pperform | Preperform -> + (* CR mshinwell/ncourant: to be thought about later *) + Misc.fatal_error "Effects-related primitives are not yet supported" + | Patomic_load { immediate_or_pointer = Immediate } -> Lambda.layout_int + | Patomic_load { immediate_or_pointer = Pointer } -> Lambda.layout_any_value + | Patomic_exchange + | Patomic_cas + | Patomic_fetch_add + | Pdls_get + | Popaque | Pread_symbol _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ - | Pbigstring_set _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque - | Pprobe_is_enabled _ | Pbox_float _ | Pbox_int _ | Pget_header _ - | Prunstack | Pperform | Presume | Preperform | Patomic_exchange - | Patomic_cas | Patomic_fetch_add | Pdls_get | Patomic_load _ - -> Lambda.layout_any_value + | Pbigstring_set _ -> Lambda.layout_any_value diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index e5aafabf775..99c228811d7 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/middle_end/clambda_primitives.ml @@ -225,29 +225,70 @@ let equal (x: primitive) (y: primitive) = x = y let result_layout (p : primitive) = match p with - | Punbox_float -> Lambda.Punboxed_float - | Punbox_int bi -> Lambda.Punboxed_int bi - | Pccall {prim_native_repr_res = (_, repr_res); _} -> - Lambda.layout_of_native_repr repr_res - | Pufloatfield _ -> Lambda.Punboxed_float - | Pread_symbol _ | Pmakeblock _ | Pmakeufloatblock _ | Pfield _ - | Pfield_computed | Psetfield _ | Psetfield_computed _ | Pfloatfield _ - | Psetfloatfield _ | Psetufloatfield _ | Pduprecord _ | Praise _ - | 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 _ | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ | Parraysetu _ - | Parrayrefs _ | Parraysets _ | Pisint | Pisout | Pbintofint _ | Pintofbint _ - | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ - | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ + | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _ + | Psetufloatfield _ + | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _ + -> Lambda.layout_unit + | Pmakeblock _ | Pmakearray _ | Pduprecord _ + | 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 + | Pccall { prim_native_repr_res = _, repr_res } -> Lambda.layout_of_native_repr repr_res + | Praise _ -> Lambda.layout_bottom + | Psequor | Psequand | Pnot + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint _ | Pmodint _ + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp _ + | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Poffsetint _ | Pintoffloat | Pfloatcomp _ + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytesrefs + | Parraylength _ | Pisint | Pisout | Pintofbint _ + | Pbintcomp _ + | Pprobe_is_enabled _ | Pbswap16 + -> Lambda.layout_int + | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> + Lambda.array_ref_kind_result_layout array_ref_kind + | Pbintofint (bi, _) | Pcvtbint (_,bi,_) + | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) + | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi} + | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _) + | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _) + | Pbbswap (bi, _) | Pbox_int (bi, _) -> + Lambda.layout_boxedint bi + | Punbox_int bi -> Punboxed_int bi + | Pbigarrayref (_, _, kind, _) -> + begin match kind with + | Pbigarray_unknown -> Lambda.layout_any_value + | Pbigarray_float32 | Pbigarray_float64 -> Lambda.layout_boxed_float + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_caml_int -> Lambda.layout_int + | Pbigarray_int32 -> Lambda.layout_boxedint Pint32 + | Pbigarray_int64 -> Lambda.layout_boxedint Pint64 + | Pbigarray_native_int -> Lambda.layout_boxedint Pnativeint + | Pbigarray_complex32 | Pbigarray_complex64 -> + Lambda.layout_block + end + | Pint_as_pointer _ -> + (* CR ncourant: use an unboxed int64 here when it exists *) + Lambda.layout_any_value + | Pget_header _ -> Lambda.layout_boxedint Pnativeint + | Prunstack | Presume | Pperform | Preperform -> + (* CR mshinwell/ncourant: to be thought about later *) + Misc.fatal_error "Effects-related primitives are not yet supported" + | Patomic_load { immediate_or_pointer = Immediate } -> Lambda.layout_int + | Patomic_load { immediate_or_pointer = Pointer } -> Lambda.layout_any_value + | Patomic_exchange + | Patomic_cas + | Patomic_fetch_add + | Pdls_get + | Popaque | Pread_symbol _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ - | Pbigstring_set _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque - | Pprobe_is_enabled _ | Pbox_float _ | Pbox_int _ | Pget_header _ - | Prunstack | Pperform | Presume | Preperform | Patomic_exchange - | Patomic_cas | Patomic_fetch_add | Pdls_get | Patomic_load _ - -> Lambda.layout_any_value + | Pbigstring_set _ -> Lambda.layout_any_value diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml index b1231d1658e..97149f1a991 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml @@ -1,23 +1,22 @@ (* TEST reference = "${test_source_directory}/unboxed_floats.reference" - * flambda2 - ** native + * native flags = "-extension layouts_alpha" - ** bytecode + * bytecode flags = "-extension layouts_alpha" - ** native + * native flags = "-extension layouts_beta" - ** bytecode + * bytecode flags = "-extension layouts_beta" - ** native + * native flags = "-extension layouts" - ** bytecode + * bytecode flags = "-extension layouts" - ** setup-ocamlc.byte-build-env + * setup-ocamlc.byte-build-env ocamlc_byte_exit_status = "2" - *** ocamlc.byte + ** ocamlc.byte compiler_reference = "${test_source_directory}/unboxed_floats_disabled.compilers.reference" - **** check-ocamlc.byte-output + *** check-ocamlc.byte-output *) @@ -484,4 +483,12 @@ let rb' = { xb = 3.14; yb = 42.1 } let _ = Printf.printf "Test 11, heterogeneous polymorphic equality.\n"; Printf.printf " equal: %b\n" (Ex ru = Ex rb); - Printf.printf " unequal: %b\n" (Ex ru = Ex rb'); + Printf.printf " unequal: %b\n" (Ex ru = Ex rb') + +(*************************************************) +(* Test 12: If-then-else with float64 and assert *) + +let _ = + let a = if Sys.opaque_identity true then Float_u.of_int 1 else assert false in + Printf.printf "Test 12, If-then-else with assert and float64.\n"; + print_floatu " result (1.00)" a diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference index 17511276f06..8fe460ccafd 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference @@ -147,3 +147,5 @@ Test 10, float# records in recursive groups. Test 11, heterogeneous polymorphic equality. equal: true unequal: false +Test 12, If-then-else with assert and float64. + result (1.00): 1.00 diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference index 4218268df18..fa40f58108a 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference @@ -1,4 +1,4 @@ -File "unboxed_floats.ml", line 326, characters 25-31: -326 | let ( let* ) x (f : _ -> float#) = f x +File "unboxed_floats.ml", line 325, characters 25-31: +325 | let ( let* ) x (f : _ -> float#) = f x ^^^^^^ Error: This construct requires the stable version of the extension "layouts", which is disabled and cannot be used