From 56067cce0e01f617e75d896b4cf0cd40f718b372 Mon Sep 17 00:00:00 2001 From: alanechang Date: Thu, 28 Dec 2023 12:12:32 -0500 Subject: [PATCH] flambda-backend: Implement unboxed int literals (#2139) * add unboxed int literals * workaround for matching * add tests and missing parmatch cases * fix matching bug * allocation tests * mark tests as flambda2 * update native test * add lambda primitive * fix test name * move format function to misc * correct test flags and remove unused functions * fix literal roundtrip and add test * alloc test with large values * add tests for invalid literals * refactor constant_integer to not build string all the time * define and use unboxed_integer alias --- asmcomp/cmmgen.ml | 13 +- bytecomp/bytegen.ml | 15 +- bytecomp/symtable.ml | 9 +- lambda/lambda.ml | 12 +- lambda/lambda.mli | 3 + lambda/matching.ml | 23 +- lambda/printlambda.ml | 31 ++- lambda/tmc.ml | 2 +- lambda/translprim.ml | 4 +- middle_end/clambda_primitives.ml | 5 +- middle_end/clambda_primitives.mli | 3 + middle_end/closure/closure.ml | 7 +- middle_end/convert_primitives.ml | 1 + middle_end/flambda/closure_conversion.ml | 7 +- middle_end/internal_variable_names.ml | 4 + middle_end/printclambda_primitives.ml | 15 ++ middle_end/semantics_of_primitives.ml | 6 +- parsing/pprintast.ml | 8 +- .../tests/parsetree/source_jane_street.ml | 101 ++++++++ testsuite/tests/parsetree/test_ppx.ml | 2 +- .../tests/typing-layouts-bits32/alloc.ml | 14 +- .../typing-layouts-bits32/alloc.reference | 2 + .../tests/typing-layouts-bits64/alloc.ml | 14 +- .../typing-layouts-bits64/alloc.reference | 2 + testsuite/tests/typing-layouts-word/alloc.ml | 14 +- .../tests/typing-layouts-word/alloc.reference | 2 + testsuite/tests/typing-layouts/literals.ml | 216 +++++++++++------- .../tests/typing-layouts/literals_native.ml | 84 ++++--- .../typing-layouts/literals_native.reference | 9 + typing/parmatch.ml | 28 ++- typing/printpat.ml | 15 +- typing/printtyped.ml | 3 + typing/typecore.ml | 58 ++++- typing/typedtree.ml | 3 + typing/typedtree.mli | 3 + typing/untypeast.ml | 6 + utils/misc.ml | 5 + utils/misc.mli | 11 + 38 files changed, 586 insertions(+), 174 deletions(-) diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index f7b0ad861fb..2a79476d1fd 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -672,8 +672,8 @@ let rec transl env e = | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _ - | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ + | Pasrbint _ | Pbintcomp (_, _) | Punboxed_int_comp (_, _) | Pstring_load _ + | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _ | Pbbswap _ | Pget_header _), _) -> @@ -1030,7 +1030,7 @@ and transl_prim_1 env p arg dbg = | Pduparray (_, _) | Parrayrefu _ | Parraysetu _ | Parrayrefs _ | Parraysets _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ - | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) + | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) | Punboxed_int_comp (_, _) | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _ | Pprobe_is_enabled _) @@ -1209,6 +1209,10 @@ and transl_prim_2 env p arg1 arg2 dbg = tag_int (Cop(Ccmpi cmp, [transl_unbox_int dbg env bi arg1; transl_unbox_int dbg env bi arg2], dbg)) dbg + | Punboxed_int_comp(_, cmp) -> + tag_int (Cop(Ccmpi cmp, + [transl env arg1; + transl env arg2], dbg)) dbg | Patomic_exchange -> Cop (Cextcall ("caml_atomic_exchange", typ_val, [], false), [transl env arg1; transl env arg2], dbg) @@ -1325,7 +1329,8 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = | Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _ | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ - | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _) + | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ + | Pbintcomp (_, _) | Punboxed_int_comp (_, _) | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _ | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _ | Pprobe_is_enabled _ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 451d1d586d7..279bf78c6f9 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -137,7 +137,8 @@ let preserve_tailcall_for_prim = function | Parrayrefs _ | Parraysets _ | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pbintcomp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ + | 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 _ @@ -540,12 +541,12 @@ let comp_primitive stack_info p sz args = | Plslbint(bi,_) -> comp_bint_primitive bi "shift_left" args | Plsrbint(bi,_) -> comp_bint_primitive bi "shift_right_unsigned" args | Pasrbint(bi,_) -> comp_bint_primitive bi "shift_right" args - | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2) - | Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2) - | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2) - | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2) - | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2) - | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2) + | Pbintcomp(_, Ceq) | Punboxed_int_comp(_, Ceq) -> Kccall("caml_equal", 2) + | Pbintcomp(_, Cne) | Punboxed_int_comp(_, Cne) -> Kccall("caml_notequal", 2) + | Pbintcomp(_, Clt) | Punboxed_int_comp(_, Clt) -> Kccall("caml_lessthan", 2) + | Pbintcomp(_, Cgt) | Punboxed_int_comp(_, Cgt) -> Kccall("caml_greaterthan", 2) + | Pbintcomp(_, Cle) | Punboxed_int_comp(_, Cle) -> Kccall("caml_lessequal", 2) + | Pbintcomp(_, Cge) | Punboxed_int_comp(_, Cge) -> Kccall("caml_greaterequal", 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ Int.to_string n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ Int.to_string n, n + 2) | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ Int.to_string n, 1) diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 6b889623516..2d21ff73763 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -150,9 +150,12 @@ let rec transl_const = function | Const_base(Const_string (s, _, _)) -> Obj.repr s | Const_base(Const_float f) | Const_base(Const_unboxed_float f) -> Obj.repr (float_of_string f) - | Const_base(Const_int32 i) -> Obj.repr i - | Const_base(Const_int64 i) -> Obj.repr i - | Const_base(Const_nativeint i) -> Obj.repr i + | Const_base(Const_int32 i) + | Const_base(Const_unboxed_int32 i) -> Obj.repr i + | Const_base(Const_int64 i) + | Const_base(Const_unboxed_int64 i) -> Obj.repr i + | Const_base(Const_nativeint i) + | Const_base(Const_unboxed_nativeint i) -> Obj.repr i | Const_immstring s -> Obj.repr s | Const_block(tag, fields) -> let block = Obj.new_block tag (List.length fields) in diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 8a8dfc934d9..5816a4cee64 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -217,6 +217,7 @@ type primitive = | Plsrbint of boxed_integer * alloc_mode | Pasrbint of boxed_integer * alloc_mode | Pbintcomp of boxed_integer * integer_comparison + | Punboxed_int_comp of unboxed_integer * integer_comparison (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -320,6 +321,8 @@ and array_set_kind = and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_integer = boxed_integer + and vec128_type = | Unknown128 | Int8x16 @@ -1523,7 +1526,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Plslbint (_, m) | Plsrbint (_, m) | Pasrbint (_, m) -> Some m - | Pbintcomp _ -> None + | Pbintcomp _ | Punboxed_int_comp _ -> None | Pbigarrayset _ | Pbigarraydim _ -> None | Pbigarrayref (_, _, _, _) -> (* Boxes arising from Bigarray access are always Alloc_heap *) @@ -1563,6 +1566,9 @@ let constant_layout: constant -> layout = function | Const_int32 _ -> Pvalue (Pboxedintval Pint32) | Const_int64 _ -> Pvalue (Pboxedintval Pint64) | Const_nativeint _ -> Pvalue (Pboxedintval Pnativeint) + | 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 @@ -1626,7 +1632,7 @@ let primitive_result_layout (p : primitive) = | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytesrefs | Parraylength _ | Pisint _ | Pisout | Pintofbint _ - | Pbintcomp _ + | Pbintcomp _ | Punboxed_int_comp _ | Pstring_load_16 _ | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pprobe_is_enabled _ | Pbswap16 -> layout_int @@ -1785,5 +1791,3 @@ let may_allocate_in_region lam = | () -> false | exception Exit -> true end - - diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 11bccb7f17b..1657b99cc08 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -179,6 +179,7 @@ type primitive = | Plsrbint of boxed_integer * alloc_mode | Pasrbint of boxed_integer * alloc_mode | Pbintcomp of boxed_integer * integer_comparison + | Punboxed_int_comp of unboxed_integer * integer_comparison (* Operations on Bigarrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -297,6 +298,8 @@ and block_shape = and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_integer = boxed_integer + and vec128_type = | Unknown128 | Int8x16 diff --git a/lambda/matching.ml b/lambda/matching.ml index b117a44228e..11813bd962e 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1177,7 +1177,10 @@ let can_group discr pat = | Constant (Const_unboxed_float _), Constant (Const_unboxed_float _) | Constant (Const_int32 _), Constant (Const_int32 _) | Constant (Const_int64 _), Constant (Const_int64 _) - | Constant (Const_nativeint _), Constant (Const_nativeint _) -> + | Constant (Const_nativeint _), Constant (Const_nativeint _) + | Constant (Const_unboxed_int32 _), Constant (Const_unboxed_int32 _) + | Constant (Const_unboxed_int64 _), Constant (Const_unboxed_int64 _) + | Constant (Const_unboxed_nativeint _), Constant (Const_unboxed_nativeint _)-> true | Construct { cstr_tag = Extension _ as discr_tag }, Construct pat_cstr -> @@ -1198,7 +1201,8 @@ let can_group discr pat = ( Any | Constant ( Const_int _ | Const_char _ | Const_string _ | Const_float _ - | Const_unboxed_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Const_unboxed_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ + | Const_unboxed_int32 _ | Const_unboxed_int64 _ | Const_unboxed_nativeint _ ) | Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) -> false @@ -2889,6 +2893,21 @@ let combine_constant value_kind loc arg cst partial ctx def (Pbintcomp (Pnativeint, Cne)) (Pbintcomp (Pnativeint, Clt)) arg const_lambda_list + | Const_unboxed_int32 _ -> + make_test_sequence value_kind loc fail + (Punboxed_int_comp (Pint32, Cne)) + (Punboxed_int_comp (Pint32, Clt)) + arg const_lambda_list + | Const_unboxed_int64 _ -> + make_test_sequence value_kind loc fail + (Punboxed_int_comp (Pint64, Cne)) + (Punboxed_int_comp (Pint64, Clt)) + arg const_lambda_list + | Const_unboxed_nativeint _ -> + make_test_sequence value_kind loc fail + (Punboxed_int_comp (Pnativeint, Cne)) + (Punboxed_int_comp (Pnativeint, Clt)) + arg const_lambda_list in (lambda1, Jumps.union local_jumps total) diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 5f739e83f43..1a55dda6973 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -19,7 +19,6 @@ open Primitive open Types open Lambda - let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> fprintf ppf "%C" c @@ -27,16 +26,16 @@ let rec struct_const ppf = function | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f | Const_base(Const_unboxed_float f) -> - let s = - match String.split_on_char '-' f with - | [""; f] -> "-#" ^ f - | [f] -> "#" ^ f - | _ -> Misc.fatal_errorf "Invalid Const_unboxed_float constant: %s" f - in - fprintf ppf "%s" s + fprintf ppf "%s" (Misc.format_as_unboxed_literal f) | Const_base(Const_int32 n) -> fprintf ppf "%lil" n | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n + | Const_base(Const_unboxed_int32 i) -> + fprintf ppf "%sl" (Misc.format_as_unboxed_literal (Int32.to_string i)) + | Const_base(Const_unboxed_int64 i) -> + fprintf ppf "%sL" (Misc.format_as_unboxed_literal (Int64.to_string i)) + | Const_base(Const_unboxed_nativeint i) -> + fprintf ppf "%sn" (Misc.format_as_unboxed_literal (Nativeint.to_string i)) | Const_block(tag, []) -> fprintf ppf "[%i]" tag | Const_block(tag, sc1::scl) -> @@ -205,6 +204,15 @@ let boxed_integer_mark name bi m = let print_boxed_integer name ppf bi m = fprintf ppf "%s" (boxed_integer_mark name bi m);; +let unboxed_integer_mark name bi m = + match bi with + | Pnativeint -> Printf.sprintf "Nativeint_u.%s%s" name (alloc_kind m) + | Pint32 -> Printf.sprintf "Int32_u.%s%s" name (alloc_kind m) + | Pint64 -> Printf.sprintf "Int64_u.%s%s" name (alloc_kind m) + +let print_unboxed_integer name ppf bi m = + fprintf ppf "%s" (unboxed_integer_mark name bi m);; + let print_bigarray name unsafe kind ppf layout = fprintf ppf "Bigarray.%s[%s,%s]" (if unsafe then "unsafe_"^ name else name) @@ -480,6 +488,12 @@ let primitive ppf = function | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Ceq) -> print_unboxed_integer "==" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cne) -> print_unboxed_integer "!=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Clt) -> print_unboxed_integer "<" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cgt) -> print_unboxed_integer ">" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cle) -> print_unboxed_integer "<=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cge) -> print_unboxed_integer ">=" ppf bi alloc_heap | Pbigarrayref(unsafe, _n, kind, layout) -> print_bigarray "get" unsafe kind ppf layout | Pbigarrayset(unsafe, _n, kind, layout) -> @@ -671,6 +685,7 @@ let name_of_primitive = function | Plsrbint _ -> "Plsrbint" | Pasrbint _ -> "Pasrbint" | Pbintcomp _ -> "Pbintcomp" + | Punboxed_int_comp _ -> "Punboxed_int_comp" | Pbigarrayref _ -> "Pbigarrayref" | Pbigarrayset _ -> "Pbigarrayset" | Pbigarraydim _ -> "Pbigarraydim" diff --git a/lambda/tmc.ml b/lambda/tmc.ml index 544a1e95c28..faf7f47a697 100644 --- a/lambda/tmc.ml +++ b/lambda/tmc.ml @@ -885,7 +885,7 @@ let rec choice ctx t = | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintcomp _ + | Pintcomp _ | Punboxed_int_comp _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ diff --git a/lambda/translprim.ml b/lambda/translprim.ml index efcb3bf4cd2..9a4efe01c4e 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -1058,8 +1058,8 @@ let lambda_primitive_needs_event_after = function | Parrayrefu (Pgenarray_ref _ | Pfloatarray_ref _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ - | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ - | Pcompare_bints _ + | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ + | Pbintcomp _ | Punboxed_int_comp _ | Pcompare_bints _ | 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 _ diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index c4af0254990..db8e006f17b 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -111,6 +111,7 @@ type primitive = | Plsrbint of boxed_integer * alloc_mode | Pasrbint of boxed_integer * alloc_mode | Pbintcomp of boxed_integer * integer_comparison + | Punboxed_int_comp of unboxed_integer * integer_comparison (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -191,6 +192,8 @@ and block_shape = Lambda.block_shape and boxed_integer = Lambda.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_integer = boxed_integer + and vec128_type = Lambda.vec128_type = | Unknown128 | Int8x16 @@ -251,7 +254,7 @@ let result_layout (p : primitive) = | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytesrefs | Parraylength _ | Pisint | Pisout | Pintofbint _ - | Pbintcomp _ + | Pbintcomp _ | Punboxed_int_comp _ | Pprobe_is_enabled _ | Pbswap16 -> Lambda.layout_int | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index 96fc36ced9b..518e34dc7f1 100644 --- a/middle_end/clambda_primitives.mli +++ b/middle_end/clambda_primitives.mli @@ -114,6 +114,7 @@ type primitive = | Plsrbint of boxed_integer * alloc_mode | Pasrbint of boxed_integer * alloc_mode | Pbintcomp of boxed_integer * integer_comparison + | Punboxed_int_comp of unboxed_integer * integer_comparison (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout @@ -195,6 +196,8 @@ and block_shape = Lambda.block_shape and boxed_integer = Lambda.boxed_integer = Pnativeint | Pint32 | Pint64 +and unboxed_integer = boxed_integer + and vec128_type = Lambda.vec128_type = | Unknown128 | Int8x16 diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index d81604eb3ed..8fe0ef5d276 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -1027,9 +1027,10 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) | Const_base (Const_string (s, _, _)) -> str (Uconst_string s) | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) - | Const_base(Const_unboxed_float _) -> - (* CR alanechang: implement unboxed float constants in closure *) - Misc.fatal_error "Unboxed float constants are not supported in closure. Consider using flambda2." + | Const_base (Const_unboxed_float _ | Const_unboxed_int32 _ + | Const_unboxed_int64 _ | Const_unboxed_nativeint _) -> + (* CR alanechang: implement unboxed constants in closure *) + Misc.fatal_error "Unboxed constants are not supported in closure. Consider using flambda2." | Const_base(Const_int32 x) -> str (Uconst_int32 x) | Const_base(Const_int64 x) -> str (Uconst_int64 x) | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 7f618451876..d186ebb8a0f 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -122,6 +122,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pdivbint { size; is_safe; mode } -> Pdivbint { size; is_safe; mode } | Pmodbint { size; is_safe; mode } -> Pmodbint { size; is_safe; mode } | Pbintcomp (bi, comp) -> Pbintcomp (bi, comp) + | Punboxed_int_comp (bi, comp) -> Punboxed_int_comp (bi, comp) | Pbigarrayref (safe, dims, kind, layout) -> Pbigarrayref (safe, dims, kind, layout) | Pbigarrayset (safe, dims, kind, layout) -> diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index dba0262eaf4..0b5b5f2ae40 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -123,9 +123,10 @@ let rec declare_const t (const : Lambda.structured_constant) match const with | Const_base (Const_int c) -> (Const (Int c), Names.const_int) | Const_base (Const_char c) -> (Const (Char c), Names.const_char) - | Const_base (Const_unboxed_float _) -> - (* CR alanechang: implement unboxed float constants in flambda *) - Misc.fatal_error "Unboxed float constants are not supported in flambda. Consider using flambda2." + | Const_base (Const_unboxed_float _ | Const_unboxed_int32 _ + | Const_unboxed_int64 _ | Const_unboxed_nativeint _) -> + (* CR alanechang: implement unboxed constants in flambda *) + Misc.fatal_error "Unboxed constants are not supported in flambda. Consider using flambda2." | Const_base (Const_string (s, _, _)) -> let const, name = (Flambda.Allocated_const (Immutable_string s), diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index c2b3094a132..fee8351c97c 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -91,6 +91,7 @@ let pbigstring_set_32 = "Pbigstring_set_32" let pbigstring_set_64 = "Pbigstring_set_64" let pbigstring_set_128 = "Pbigstring_set_128" let pbintcomp = "Pbintcomp" +let punboxed_int_comp = "Punboxed_int_comp" let pbintofint = "Pbintofint" let pbswap16 = "Pbswap16" let pbytes_of_string = "Pbytes_of_string" @@ -223,6 +224,7 @@ let pbigstring_set_32_arg = "Pbigstring_set_32_arg" let pbigstring_set_64_arg = "Pbigstring_set_64_arg" let pbigstring_set_128_arg = "Pbigstring_set_128_arg" let pbintcomp_arg = "Pbintcomp_arg" +let punboxed_int_comp_arg = "Punboxed_int_comp_arg" let pbintofint_arg = "Pbintofint_arg" let pbswap16_arg = "Pbswap16_arg" let pbytes_of_string_arg = "Pbytes_of_string_arg" @@ -456,6 +458,7 @@ let of_primitive : Lambda.primitive -> string = function | Plsrbint _ -> plsrbint | Pasrbint _ -> pasrbint | Pbintcomp _ -> pbintcomp + | Punboxed_int_comp _ -> punboxed_int_comp | Pbigarrayref _ -> pbigarrayref | Pbigarrayset _ -> pbigarrayset | Pbigarraydim _ -> pbigarraydim @@ -591,6 +594,7 @@ let of_primitive_arg : Lambda.primitive -> string = function | Plsrbint _ -> plsrbint_arg | Pasrbint _ -> pasrbint_arg | Pbintcomp _ -> pbintcomp_arg + | Punboxed_int_comp _ -> punboxed_int_comp_arg | Pbigarrayref _ -> pbigarrayref_arg | Pbigarrayset _ -> pbigarrayset_arg | Pbigarraydim _ -> pbigarraydim_arg diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml index fd6bc93371c..3d619e1deef 100644 --- a/middle_end/printclambda_primitives.ml +++ b/middle_end/printclambda_primitives.ml @@ -33,6 +33,15 @@ let alloc_kind = function let print_boxed_integer name ppf bi m = fprintf ppf "%s%s" (boxed_integer_mark name bi) (alloc_kind m) +let unboxed_integer_mark name bi m = + match bi with + | Lambda.Pnativeint -> Printf.sprintf "Nativeint_u.%s%s" name (alloc_kind m) + | Lambda.Pint32 -> Printf.sprintf "Int32_u.%s%s" name (alloc_kind m) + | Lambda.Pint64 -> Printf.sprintf "Int64_u.%s%s" name (alloc_kind m) + +let print_unboxed_integer name ppf bi m = + fprintf ppf "%s" (unboxed_integer_mark name bi m);; + let array_kind array_kind = let open Lambda in match array_kind with @@ -266,6 +275,12 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Ceq) -> print_unboxed_integer "==" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cne) -> print_unboxed_integer "!=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Clt) -> print_unboxed_integer "<" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cgt) -> print_unboxed_integer ">" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cle) -> print_unboxed_integer "<=" ppf bi alloc_heap + | Punboxed_int_comp(bi, Cge) -> print_unboxed_integer ">=" ppf bi alloc_heap | Pbigarrayref(unsafe, _n, kind, layout) -> Printlambda.print_bigarray "get" unsafe kind ppf layout | Pbigarrayset(unsafe, _n, kind, layout) -> diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml index 6d427f7bc6b..937f7a5ed02 100644 --- a/middle_end/semantics_of_primitives.ml +++ b/middle_end/semantics_of_primitives.ml @@ -58,7 +58,8 @@ let for_primitive (prim : Clambda_primitives.primitive) = | Plslint | Plsrint | Pasrint - | Pintcomp _ -> No_effects, No_coeffects + | Pintcomp _ + | Punboxed_int_comp _ -> No_effects, No_coeffects | Pcompare_ints | Pcompare_floats | Pcompare_bints _ -> No_effects, No_coeffects | Pdivbint { is_safe = Unsafe } @@ -231,7 +232,8 @@ let may_locally_allocate (prim:Clambda_primitives.primitive) : bool = | Pisint | Pisout | Pintofbint _ - | Pbintcomp _ -> false + | Pbintcomp _ + | Punboxed_int_comp _ -> false | Pdivbint { mode = m } | Pmodbint { mode = m } | Pbintofint (_,m) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 33564ff86b8..e4edbdc63da 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -2050,8 +2050,12 @@ and layout_expr ctxt f (x : Jane_syntax.Layouts.expression) ~parens = and unboxed_constant _ctxt f (x : Jane_syntax.Layouts.constant) = match x with - | Float (x, suffix) -> pp f "#%a" constant (Pconst_float (x, suffix)) - | Integer (x, suffix) -> pp f "#%a" constant (Pconst_integer (x, Some suffix)) + | Float (x, None) -> + paren (first_is '-' x) (fun f -> pp f "%s") f (Misc.format_as_unboxed_literal x) + | Float (x, Some suffix) + | Integer (x, suffix) -> + paren (first_is '-' x) (fun f (x, suffix) -> pp f "%s%c" x suffix) f + (Misc.format_as_unboxed_literal x, suffix) and function_param ctxt f ({ pparam_desc; pparam_loc = _ } : diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index 98be808b3ed..9aebde2acfe 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -180,3 +180,104 @@ let matches = let matches = let (~y, ~x, .. ) = lt in (x, y) + +(********************) +(* Unboxed literals *) + +module Float_u = Stdlib__Float_u +module Int32_u = Stdlib__Int32_u +module Int64_u = Stdlib__Int64_u +module Nativeint_u = Stdlib__Nativeint_u + +let test_float s f = + Format.printf "%s: %f\n" s (Float_u.to_float f); Format.print_flush () +let test_int32 s f = + Format.printf "%s: %ld\n" s (Int32_u.to_int32 f); Format.print_flush () +let test_int64 s f = + Format.printf "%s: %Ld\n" s (Int64_u.to_int64 f); Format.print_flush () +let test_nativeint s f = + Format.printf "%s: %s\n" s (Nativeint_u.to_string f); Format.print_flush () + +(* Expressions *) + +let () = test_float "e" #2.718281828459045 +let () = test_float "negative_one_half" (-#0.5) +let () = test_float "negative_one_half" (- #0.5) +let () = test_float "negative_one_half" (-.#0.5) +let () = test_float "negative_one_half" (-. #0.5) +let () = test_float "positive_one_dot" (+#1.) +let () = test_float "positive_one_dot" (+ #1.) +let () = test_float "positive_one_dot" (+.#1.) +let () = test_float "positive_one_dot" (+. #1.) +let () = test_float "one_billion" (#1e9) +let () = test_float "one_twenty_seven_point_two_five_in_floating_hex" (#0x7f.4) +let () = test_float "five_point_three_seven_five_in_floating_hexponent" (#0xa.cp-1) + +let () = test_nativeint "zero" (#0n) +let () = test_int32 "positive_one" (+#1l) +let () = test_int32 "positive_one" (+ #1l) +let () = test_int64 "negative_one" (-#1L) +let () = test_int64 "negative_one" (- #1L) +let () = test_nativeint "two_fifty_five_in_hex" (#0xFFn) +let () = test_int32 "twenty_five_in_octal" (#0o31l) +let () = test_int64 "forty_two_in_binary" (#0b101010L) + +(* Patterns *) + +let f x = + match x with + | #4. -> `Four + | #5. -> `Five + | _ -> `Other +;; + +let () = + match f #5. with + | `Five -> () + | _ -> assert false;; + +let f x = + match x with + | #4. -> #0. + | #5. -> #1. + | x -> x +;; + +test_float "result" (f #7.);; + +let f x = + match x with + | #4. -> #0. + | #5. -> #1. + | #6. -> #2. + | #7. -> #3. + | #8. -> #4. + | #9. -> #5. + | #10. -> #6. + | #11. -> #7. + | x -> x +;; + +test_float "larger match result" (f #7.);; + + +let f x = + match x with + | #4L -> `Four + | #5L -> `Five + | _ -> `Other +;; + +let () = + match f #4L with + | `Four -> () + | _ -> assert false;; + +let f x = + match x with + | #4L -> #0L + | #5L -> #1L + | x -> x +;; + +test_int64 "result" (f #7L);; diff --git a/testsuite/tests/parsetree/test_ppx.ml b/testsuite/tests/parsetree/test_ppx.ml index 3ce00588e87..6efe3fc8afe 100644 --- a/testsuite/tests/parsetree/test_ppx.ml +++ b/testsuite/tests/parsetree/test_ppx.ml @@ -9,7 +9,7 @@ all_modules = "ppx_no_op.ml" module = "source_jane_street.ml" flags = "-I ${test_build_directory} \ -w -26 \ - -extension layouts \ + -extension layouts_beta \ -extension comprehensions \ -ppx ${program}" **** check-ocamlc.byte-output diff --git a/testsuite/tests/typing-layouts-bits32/alloc.ml b/testsuite/tests/typing-layouts-bits32/alloc.ml index a4a619a3aeb..ae8dc3bc158 100644 --- a/testsuite/tests/typing-layouts-bits32/alloc.ml +++ b/testsuite/tests/typing-layouts-bits32/alloc.ml @@ -1,6 +1,7 @@ (* TEST + * flambda2 flags = "-extension layouts_alpha" - * native + ** native *) (* A test comparing allocations when using unboxed [int32#]es to allocations @@ -98,3 +99,14 @@ end let () = Collatz_unboxed.go () let () = Collatz_boxed.go () + +let[@inline never] literal_test x y = + let open Int32_u in + let[@inline never] f x y = (#1l + x) * (y - #4l) in + match x with + | #2l | #0x7fffffffl-> (f x y) / (#3l % #10l) + | _ -> #0l + +let _ = measure_alloc "literals (should be -1): %ld" (fun () -> literal_test #2l #3l) +let _ = measure_alloc "literals (should be -715827882): %ld" + (fun () -> literal_test #0x7fffffffl #0x7fffffffl) diff --git a/testsuite/tests/typing-layouts-bits32/alloc.reference b/testsuite/tests/typing-layouts-bits32/alloc.reference index efdf281ca54..93995822e15 100644 --- a/testsuite/tests/typing-layouts-bits32/alloc.reference +++ b/testsuite/tests/typing-layouts-bits32/alloc.reference @@ -1,2 +1,4 @@ Unboxed: Collatz took 111 steps to reach 1; did not allocate Boxed: Collatz took 111 steps to reach 1; allocated +literals (should be -1): -1; did not allocate +literals (should be -715827882): -715827882; did not allocate diff --git a/testsuite/tests/typing-layouts-bits64/alloc.ml b/testsuite/tests/typing-layouts-bits64/alloc.ml index 7bf2d706c48..6acfe1d62ea 100644 --- a/testsuite/tests/typing-layouts-bits64/alloc.ml +++ b/testsuite/tests/typing-layouts-bits64/alloc.ml @@ -1,6 +1,7 @@ (* TEST + * flambda2 flags = "-extension layouts_alpha" - * native + ** native *) (* A test comparing allocations when using unboxed [int64#]es to allocations @@ -98,3 +99,14 @@ end let () = Collatz_unboxed.go () let () = Collatz_boxed.go () + +let[@inline never] literal_test x y = + let open Int64_u in + let[@inline never] f x y = (#1L + x) * (y - #4L) in + match x with + | #2L | #0x7fffffffffffffffL -> (f x y) / (#3L % #10L) + | _ -> #0L + +let _ = measure_alloc "literals (should be -1): %Ld" (fun () -> literal_test #2L #3L) +let _ = measure_alloc "literals (should be -3074457345618258602): %Ld" + (fun () -> literal_test #0x7fffffffffffffffL #0x7fffffffffffffffL) diff --git a/testsuite/tests/typing-layouts-bits64/alloc.reference b/testsuite/tests/typing-layouts-bits64/alloc.reference index efdf281ca54..98ca450330f 100644 --- a/testsuite/tests/typing-layouts-bits64/alloc.reference +++ b/testsuite/tests/typing-layouts-bits64/alloc.reference @@ -1,2 +1,4 @@ Unboxed: Collatz took 111 steps to reach 1; did not allocate Boxed: Collatz took 111 steps to reach 1; allocated +literals (should be -1): -1; did not allocate +literals (should be -3074457345618258602): -3074457345618258602; did not allocate diff --git a/testsuite/tests/typing-layouts-word/alloc.ml b/testsuite/tests/typing-layouts-word/alloc.ml index 792d90e0bc9..25b522e59ef 100644 --- a/testsuite/tests/typing-layouts-word/alloc.ml +++ b/testsuite/tests/typing-layouts-word/alloc.ml @@ -1,6 +1,7 @@ (* TEST + * flambda2 flags = "-extension layouts_alpha" - * native + ** native *) (* A test comparing allocations when using unboxed [nativeint#]es to allocations @@ -98,3 +99,14 @@ end let () = Collatz_unboxed.go () let () = Collatz_boxed.go () + +let[@inline never] literal_test x y = + let open Nativeint_u in + let[@inline never] f x y = (#1n + x) * (y - #4n) in + match x with + | #2n | #0x7fffffffffffffffn -> (f x y) / (#3n % #10n) + | _ -> #0n + +let _ = measure_alloc "literals (should be -1): %nd" (fun () -> literal_test #2n #3n) +let _ = measure_alloc "literals (should be -3074457345618258602): %nd" + (fun () -> literal_test #0x7fffffffffffffffn #0x7fffffffffffffffn) diff --git a/testsuite/tests/typing-layouts-word/alloc.reference b/testsuite/tests/typing-layouts-word/alloc.reference index efdf281ca54..98ca450330f 100644 --- a/testsuite/tests/typing-layouts-word/alloc.reference +++ b/testsuite/tests/typing-layouts-word/alloc.reference @@ -1,2 +1,4 @@ Unboxed: Collatz took 111 steps to reach 1; did not allocate Boxed: Collatz took 111 steps to reach 1; allocated +literals (should be -1): -1; did not allocate +literals (should be -3074457345618258602): -3074457345618258602; did not allocate diff --git a/testsuite/tests/typing-layouts/literals.ml b/testsuite/tests/typing-layouts/literals.ml index 0a1738edd47..d9ef1f9db6f 100644 --- a/testsuite/tests/typing-layouts/literals.ml +++ b/testsuite/tests/typing-layouts/literals.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-extension layouts" + flags = "-extension layouts_beta" * expect *) @@ -7,148 +7,165 @@ (* Prelude: Functions on unboxed floats. *) module Float_u = Stdlib__Float_u - -let test s f = Format.printf "%s: %f\n" s (Float_u.to_float f); Format.print_flush () +module Int32_u = Stdlib__Int32_u +module Int64_u = Stdlib__Int64_u +module Nativeint_u = Stdlib__Nativeint_u + +let test_float s f = + Format.printf "%s: %f\n" s (Float_u.to_float f); Format.print_flush () +let test_int32 s f = + Format.printf "%s: %ld\n" s (Int32_u.to_int32 f); Format.print_flush () +let test_int64 s f = + Format.printf "%s: %Ld\n" s (Int64_u.to_int64 f); Format.print_flush () +let test_nativeint s f = + Format.printf "%s: %s\n" s (Nativeint_u.to_string f); Format.print_flush () [%%expect{| module Float_u = Stdlib__Float_u -val test : string -> float# -> unit = +module Int32_u = Stdlib__Int32_u +module Int64_u = Stdlib__Int64_u +module Nativeint_u = Stdlib__Nativeint_u +val test_float : string -> float# -> unit = +val test_int32 : string -> int32# -> unit = +val test_int64 : string -> int64# -> unit = +val test_nativeint : string -> nativeint# -> unit = |}] (*****************************************) (* Expressions *) -let () = test "e" #2.718281828459045 +let () = test_float "e" #2.718281828459045 [%%expect{| e: 2.718282 |}] -let () = test "negative_one_half" (-#0.5) +let () = test_float "negative_one_half" (-#0.5) [%%expect{| negative_one_half: -0.500000 |}] -let () = test "negative_one_half" (- #0.5) +let () = test_float "negative_one_half" (- #0.5) [%%expect{| negative_one_half: -0.500000 |}] -let () = test "negative_one_half" (-.#0.5) +let () = test_float "negative_one_half" (-.#0.5) [%%expect{| negative_one_half: -0.500000 |}] -let () = test "negative_one_half" (-. #0.5) +let () = test_float "negative_one_half" (-. #0.5) [%%expect{| negative_one_half: -0.500000 |}] -let () = test "positive_one_dot" (+#1.) +let () = test_float "positive_one_dot" (+#1.) [%%expect{| positive_one_dot: 1.000000 |}] -let () = test "positive_one_dot" (+ #1.) +let () = test_float "positive_one_dot" (+ #1.) [%%expect{| positive_one_dot: 1.000000 |}] -let () = test "positive_one_dot" (+.#1.) +let () = test_float "positive_one_dot" (+.#1.) [%%expect{| positive_one_dot: 1.000000 |}] -let () = test "positive_one_dot" (+. #1.) +let () = test_float "positive_one_dot" (+. #1.) [%%expect{| positive_one_dot: 1.000000 |}] -let () = test "one_billion" (#1e9) +let () = test_float "one_billion" (#1e9) [%%expect{| one_billion: 1000000000.000000 |}] - -let zero = #0n +let () = test_nativeint "zero" (#0n) [%%expect{| -Line 1, characters 11-14: -1 | let zero = #0n - ^^^ -Error: Unboxed int literals aren't supported yet. +zero: 0 |}] - -let positive_one = +#1l +let () = test_int32 "positive_one" (+#1l) [%%expect{| -Line 1, characters 19-23: -1 | let positive_one = +#1l - ^^^^ -Error: Unboxed int literals aren't supported yet. +positive_one: 1 |}] - -let positive_one = + #1l +let () = test_int32 "positive_one" (+ #1l) [%%expect{| -Line 1, characters 19-24: -1 | let positive_one = + #1l - ^^^^^ -Error: Unboxed int literals aren't supported yet. +positive_one: 1 |}] - -let negative_one = -#1L +let () = test_int64 "negative_one" (-#1L) +[%%expect{| +negative_one: -1 +|}] +let () = test_int64 "negative_one" (- #1L) +[%%expect{| +negative_one: -1 +|}] +let () = test_nativeint "two_fifty_five_in_hex" (#0xFFn) +[%%expect{| +two_fifty_five_in_hex: 255 +|}] +let () = test_int32 "twenty_five_in_octal" (#0o31l) [%%expect{| -Line 1, characters 19-23: -1 | let negative_one = -#1L - ^^^^ -Error: Unboxed int literals aren't supported yet. +twenty_five_in_octal: 25 +|}] +let () = test_int64 "forty_two_in_binary" (#0b101010L) +[%%expect{| +forty_two_in_binary: 42 |}] -let negative_one = - #1L +let () = test_float "one_twenty_seven_point_two_five_in_floating_hex" (#0x7f.4) [%%expect{| -Line 1, characters 19-24: -1 | let negative_one = - #1L - ^^^^^ -Error: Unboxed int literals aren't supported yet. +one_twenty_seven_point_two_five_in_floating_hex: 127.250000 |}] -let two_fifty_five_in_hex = #0xFFn +let () = test_float "five_point_three_seven_five_in_floating_hexponent" (#0xa.cp-1) [%%expect{| -Line 1, characters 28-34: -1 | let two_fifty_five_in_hex = #0xFFn - ^^^^^^ -Error: Unboxed int literals aren't supported yet. +five_point_three_seven_five_in_floating_hexponent: 5.375000 |}] -let twenty_five_in_octal = #0o31l +let () = test_float "unknown_floating_point_suffix" (#0.P) [%%expect{| -Line 1, characters 27-33: -1 | let twenty_five_in_octal = #0o31l - ^^^^^^ -Error: Unboxed int literals aren't supported yet. +Line 1, characters 52-58: +1 | let () = test_float "unknown_floating_point_suffix" (#0.P) + ^^^^^^ +Error: Unknown modifier 'P' for literal #0.P |}] -let forty_two_in_binary = #0b101010L +let () = test_int32 "unknown_int_suffix" (#0g) [%%expect{| -Line 1, characters 26-36: -1 | let forty_two_in_binary = #0b101010L - ^^^^^^^^^^ -Error: Unboxed int literals aren't supported yet. +Line 1, characters 41-46: +1 | let () = test_int32 "unknown_int_suffix" (#0g) + ^^^^^ +Error: Unknown modifier 'g' for literal #0g |}] -let () = test "one_twenty_seven_point_two_five_in_floating_hex" (#0x7f.4) + +let () = test_nativeint "invalid_nativeint" (#0x10000000000000000n) [%%expect{| -one_twenty_seven_point_two_five_in_floating_hex: 127.250000 +Line 1, characters 44-67: +1 | let () = test_nativeint "invalid_nativeint" (#0x10000000000000000n) + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: Integer literal exceeds the range of representable integers of type nativeint# |}] -let () = test "five_point_three_seven_five_in_floating_hexponent" (#0xa.cp-1) +let () = test_int64 "invalid_int64" (#0x10000000000000000L) [%%expect{| -five_point_three_seven_five_in_floating_hexponent: 5.375000 +Line 1, characters 36-59: +1 | let () = test_int64 "invalid_int64" (#0x10000000000000000L) + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: Integer literal exceeds the range of representable integers of type int64# |}] -let () = test "unknown_floating_point_suffix" (#0.P) +let () = test_int32 "invalid_int32" (#0x100000000l) [%%expect{| -Line 1, characters 46-52: -1 | let () = test "unknown_floating_point_suffix" (#0.P) - ^^^^^^ -Error: Unknown modifier 'P' for literal #0.P +Line 1, characters 36-51: +1 | let () = test_int32 "invalid_int32" (#0x100000000l) + ^^^^^^^^^^^^^^^ +Error: Integer literal exceeds the range of representable integers of type int32# |}] (*****************************************) @@ -163,10 +180,49 @@ let f x = f #4L;; [%%expect {| -Line 3, characters 4-7: -3 | | #4L -> `Four - ^^^ -Error: Unboxed int literals aren't supported yet. +val f : int64# -> [> `Five | `Four | `Other ] = +- : [> `Five | `Four | `Other ] = `Four +|}];; + +let f x = + match x with + | #4L -> #0L + | #5L -> #1L + | x -> x +;; + +test_int64 "result" (f #7L);; +[%%expect {| +val f : int64# -> int64# = +result: 7 +- : unit = () +|}];; + +let f x = + match x with + | #0L -> #0L + | #1L -> #0L + | #2L -> #0L + | #4L -> #0L + | #5L -> #1L +;; + +test_int64 "result" (f #7L);; +(* This is here to test the [partial-match] warning *) +[%%expect {| +Lines 2-7, characters 2-14: +2 | ..match x with +3 | | #0L -> #0L +4 | | #1L -> #0L +5 | | #2L -> #0L +6 | | #4L -> #0L +7 | | #5L -> #1L +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +#3L + +val f : int64# -> int64# = +Exception: Match_failure ("", 2, 2). |}];; let f x = @@ -189,7 +245,7 @@ let f x = | x -> x ;; -test "result" (f #7.);; +test_float "result" (f #7.);; [%%expect {| val f : float# -> float# = result: 7.000000 @@ -202,7 +258,7 @@ let f x = | #5. -> #1. ;; -test "result" (f #7.);; +test_float "result" (f #7.);; (* This is here to test the [partial-match] warning *) [%%expect {| Lines 2-4, characters 2-14: @@ -222,22 +278,20 @@ Exception: Match_failure ("", 2, 2). (* Lexing edge cases *) (* Unboxed literals at the beginning of the line aren't directives. *) -let f (_ : float#) _ = ();; -let () = f +let f1 (_ : float#) (_ : int64#) = ();; +let f2 (_ : float#) (_ : float#) = ();; +let () = f1 #2. #2L ;; -let () = f +let () = f2 #2. #2. ;; [%%expect{| -val f : float# -> 'a -> unit = -Line 4, characters 0-3: -4 | #2L - ^^^ -Error: Unboxed int literals aren't supported yet. +val f1 : float# -> int64# -> unit = +val f2 : float# -> float# -> unit = |}];; let f _ _ = ();; diff --git a/testsuite/tests/typing-layouts/literals_native.ml b/testsuite/tests/typing-layouts/literals_native.ml index 102854ee4ba..559e8840916 100644 --- a/testsuite/tests/typing-layouts/literals_native.ml +++ b/testsuite/tests/typing-layouts/literals_native.ml @@ -1,6 +1,6 @@ (* TEST * flambda2 - flags = "-extension layouts" + flags = "-extension layouts_beta" ** native ** bytecode *) @@ -8,34 +8,44 @@ (*****************************************) (* Prelude: Functions on unboxed floats. *) -module Float_u = struct - include Stdlib__Float_u +module Float_u = Stdlib__Float_u +module Int32_u = Stdlib__Int32_u +module Int64_u = Stdlib__Int64_u +module Nativeint_u = Stdlib__Nativeint_u - let ( + ) = add - let ( - ) = sub - let ( * ) = mul - let ( / ) = div - let ( ** ) = pow - let ( > ) x y = (compare x y) > 0 -end - -let test s f = Format.printf "%s: %f\n%!" s (Float_u.to_float f) +let test_float s f = + Format.printf "%s: %f\n" s (Float_u.to_float f); Format.print_flush () +let test_int32 s f = + Format.printf "%s: %ld\n" s (Int32_u.to_int32 f); Format.print_flush () +let test_int64 s f = + Format.printf "%s: %Ld\n" s (Int64_u.to_int64 f); Format.print_flush () +let test_nativeint s f = + Format.printf "%s: %s\n" s (Nativeint_u.to_string f); Format.print_flush () (*****************************************) (* Expressions *) -let () = test "e" #2.718281828459045 -let () = test "negative_one_half" (-#0.5) -let () = test "negative_one_half" (- #0.5) -let () = test "negative_one_half" (-.#0.5) -let () = test "negative_one_half" (-. #0.5) -let () = test "positive_one_dot" (+#1.) -let () = test "positive_one_dot" (+ #1.) -let () = test "positive_one_dot" (+.#1.) -let () = test "positive_one_dot" (+. #1.) -let () = test "one_billion" (#1e9) -let () = test "one_twenty_seven_point_two_five_in_floating_hex" (#0x7f.4) -let () = test "five_point_three_seven_five_in_floating_hexponent" (#0xa.cp-1) +let () = test_float "e" #2.718281828459045 +let () = test_float "negative_one_half" (-#0.5) +let () = test_float "negative_one_half" (- #0.5) +let () = test_float "negative_one_half" (-.#0.5) +let () = test_float "negative_one_half" (-. #0.5) +let () = test_float "positive_one_dot" (+#1.) +let () = test_float "positive_one_dot" (+ #1.) +let () = test_float "positive_one_dot" (+.#1.) +let () = test_float "positive_one_dot" (+. #1.) +let () = test_float "one_billion" (#1e9) +let () = test_float "one_twenty_seven_point_two_five_in_floating_hex" (#0x7f.4) +let () = test_float "five_point_three_seven_five_in_floating_hexponent" (#0xa.cp-1) + +let () = test_nativeint "zero" (#0n) +let () = test_int32 "positive_one" (+#1l) +let () = test_int32 "positive_one" (+ #1l) +let () = test_int64 "negative_one" (-#1L) +let () = test_int64 "negative_one" (- #1L) +let () = test_nativeint "two_fifty_five_in_hex" (#0xFFn) +let () = test_int32 "twenty_five_in_octal" (#0o31l) +let () = test_int64 "forty_two_in_binary" (#0b101010L) (*****************************************) (* Patterns *) @@ -59,7 +69,7 @@ let f x = | x -> x ;; -test "result" (f #7.);; +test_float "result" (f #7.);; let f x = match x with @@ -74,4 +84,26 @@ let f x = | x -> x ;; -test "larger match result" (f #7.);; +test_float "larger match result" (f #7.);; + + +let f x = + match x with + | #4L -> `Four + | #5L -> `Five + | _ -> `Other +;; + +let () = + match f #4L with + | `Four -> () + | _ -> assert false;; + +let f x = + match x with + | #4L -> #0L + | #5L -> #1L + | x -> x +;; + +test_int64 "result" (f #7L);; diff --git a/testsuite/tests/typing-layouts/literals_native.reference b/testsuite/tests/typing-layouts/literals_native.reference index 79b92ee7944..14969634039 100644 --- a/testsuite/tests/typing-layouts/literals_native.reference +++ b/testsuite/tests/typing-layouts/literals_native.reference @@ -10,5 +10,14 @@ positive_one_dot: 1.000000 one_billion: 1000000000.000000 one_twenty_seven_point_two_five_in_floating_hex: 127.250000 five_point_three_seven_five_in_floating_hexponent: 5.375000 +zero: 0 +positive_one: 1 +positive_one: 1 +negative_one: -1 +negative_one: -1 +two_fifty_five_in_hex: 255 +twenty_five_in_octal: 25 +forty_two_in_binary: 42 result: 7.000000 larger match result: 3.000000 +result: 7 diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 79e8839423d..33f169d7559 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -130,6 +130,9 @@ let all_coherent column = | Const_int32 _, Const_int32 _ | Const_int64 _, Const_int64 _ | Const_nativeint _, Const_nativeint _ + | Const_unboxed_int32 _, Const_unboxed_int32 _ + | Const_unboxed_int64 _, Const_unboxed_int64 _ + | Const_unboxed_nativeint _, Const_unboxed_nativeint _ | Const_float _, Const_float _ | Const_unboxed_float _, Const_unboxed_float _ | Const_string _, Const_string _ -> true @@ -138,6 +141,9 @@ let all_coherent column = | Const_int32 _ | Const_int64 _ | Const_nativeint _ + | Const_unboxed_int32 _ + | Const_unboxed_int64 _ + | Const_unboxed_nativeint _ | Const_float _ | Const_unboxed_float _ | Const_string _), _ -> false @@ -255,6 +261,9 @@ let const_compare x y = |Const_int32 _ |Const_int64 _ |Const_nativeint _ + |Const_unboxed_int32 _ + |Const_unboxed_int64 _ + |Const_unboxed_nativeint _ ), _ -> Stdlib.compare x y let records_args l1 l2 = @@ -1046,6 +1055,21 @@ let build_other ext env = (function Constant(Const_nativeint i) -> i | _ -> assert false) (function i -> Tpat_constant(Const_nativeint i)) 0n Nativeint.succ d env + | Constant Const_unboxed_int32 _ -> + build_other_constant + (function Constant(Const_unboxed_int32 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_unboxed_int32 i)) + 0l Int32.succ d env + | Constant Const_unboxed_int64 _ -> + build_other_constant + (function Constant(Const_unboxed_int64 i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_unboxed_int64 i)) + 0L Int64.succ d env + | Constant Const_unboxed_nativeint _ -> + build_other_constant + (function Constant(Const_unboxed_nativeint i) -> i | _ -> assert false) + (function i -> Tpat_constant(Const_unboxed_nativeint i)) + 0n Nativeint.succ d env | Constant Const_string _ -> build_other_constant (function Constant(Const_string (s, _, _)) -> String.length s @@ -2114,7 +2138,9 @@ let inactive ~partial pat = match c with | Const_string _ | Const_int _ | Const_char _ | Const_float _ | Const_unboxed_float _ - | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true + | Const_int32 _ | Const_int64 _ | Const_nativeint _ + | Const_unboxed_int32 _ | Const_unboxed_int64 _ | Const_unboxed_nativeint _ + -> true end | Tpat_tuple ps -> List.for_all (fun (_,p) -> loop p) ps diff --git a/typing/printpat.ml b/typing/printpat.ml index 8453c2bbb3d..05a8fa6f41e 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -29,17 +29,16 @@ let pretty_const c = match c with | Const_char c -> Printf.sprintf "%C" c | Const_string (s, _, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f -| Const_unboxed_float f -> - let s = - match String.split_on_char '-' f with - | [""; f] -> "-#" ^ f - | [f] -> "#" ^ f - | _ -> assert false - in - Printf.sprintf "%s" s +| Const_unboxed_float f -> Printf.sprintf "%s" (Misc.format_as_unboxed_literal f) | Const_int32 i -> Printf.sprintf "%ldl" i | Const_int64 i -> Printf.sprintf "%LdL" i | Const_nativeint i -> Printf.sprintf "%ndn" i +| Const_unboxed_int32 i -> + Printf.sprintf "%sl" (Misc.format_as_unboxed_literal (Int32.to_string i)) +| Const_unboxed_int64 i -> + Printf.sprintf "%sL" (Misc.format_as_unboxed_literal (Int64.to_string i)) +| Const_unboxed_nativeint i -> + Printf.sprintf "%sn" (Misc.format_as_unboxed_literal (Nativeint.to_string i)) let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest = match cstr with diff --git a/typing/printtyped.ml b/typing/printtyped.ml index e41dfae743c..d8237107adf 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -71,6 +71,9 @@ let fmt_constant f x = | Const_int32 (i) -> fprintf f "Const_int32 %ld" i | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i + | Const_unboxed_int32 (i) -> fprintf f "Const_unboxed_int32 %ld" i + | Const_unboxed_int64 (i) -> fprintf f "Const_unboxed_int64 %Ld" i + | Const_unboxed_nativeint (i) -> fprintf f "Const_unboxed_nativeint %nd" i let fmt_mutable_flag f x = match x with diff --git a/typing/typecore.ml b/typing/typecore.ml index d420a66e15c..39f8754552d 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -601,29 +601,53 @@ let type_constant: Typedtree.constant -> type_expr = function | Const_int32 _ -> instance Predef.type_int32 | Const_int64 _ -> instance Predef.type_int64 | Const_nativeint _ -> instance Predef.type_nativeint - -let constant_integer i ~suffix : (Typedtree.constant, error) result = + | Const_unboxed_int32 _ -> instance Predef.type_unboxed_int32 + | Const_unboxed_int64 _ -> instance Predef.type_unboxed_int64 + | Const_unboxed_nativeint _ -> instance Predef.type_unboxed_nativeint + +type constant_integer_result = + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + +type constant_integer_error = + | Int32_literal_overflow + | Int64_literal_overflow + | Nativeint_literal_overflow + | Unknown_constant_literal + +let constant_integer i ~suffix : + (constant_integer_result, constant_integer_error) result = match suffix with | 'l' -> begin - try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) - with Failure _ -> Error (Literal_overflow "int32") + try Ok (Int32 (Misc.Int_literal_converter.int32 i)) + with Failure _ -> Error Int32_literal_overflow end | 'L' -> begin - try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) - with Failure _ -> Error (Literal_overflow "int64") + try Ok (Int64 (Misc.Int_literal_converter.int64 i)) + with Failure _ -> Error Int64_literal_overflow end | 'n' -> begin - try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i)) - with Failure _ -> Error (Literal_overflow "nativeint") + try Ok (Nativeint (Misc.Int_literal_converter.nativeint i)) + with Failure _ -> Error Nativeint_literal_overflow end - | c -> Error (Unknown_literal (i, c)) + | _ -> Error Unknown_constant_literal let constant : Parsetree.constant -> (Typedtree.constant, error) result = function - | Pconst_integer (i, Some suffix) -> constant_integer i ~suffix + | Pconst_integer (i, Some suffix) -> + begin match constant_integer i ~suffix with + | Ok (Int32 v) -> Ok (Const_int32 v) + | Ok (Int64 v) -> Ok (Const_int64 v) + | Ok (Nativeint v) -> Ok (Const_nativeint v) + | Error Int32_literal_overflow -> Error (Literal_overflow "int32") + | Error Int64_literal_overflow -> Error (Literal_overflow "int64") + | Error Nativeint_literal_overflow -> Error (Literal_overflow "nativeint") + | Error Unknown_constant_literal -> Error (Unknown_literal (i, suffix)) + end | Pconst_integer (i,None) -> begin try Ok (Const_int (Misc.Int_literal_converter.int i)) @@ -642,8 +666,18 @@ let constant_or_raise env loc cst = let unboxed_constant : Jane_syntax.Layouts.constant -> (Typedtree.constant, error) result = function | Float (f, None) -> Ok (Const_unboxed_float f) - | Float (x, Some c) -> Error (Unknown_literal ("#" ^ x, c)) - | Integer (_, _) -> Error Unboxed_int_literals_not_supported + | Float (x, Some c) -> Error (Unknown_literal (Misc.format_as_unboxed_literal x, c)) + | Integer (i, suffix) -> + begin match constant_integer i ~suffix with + | Ok (Int32 v) -> Ok (Const_unboxed_int32 v) + | Ok (Int64 v) -> Ok (Const_unboxed_int64 v) + | Ok (Nativeint v) -> Ok (Const_unboxed_nativeint v) + | Error Int32_literal_overflow -> Error (Literal_overflow "int32#") + | Error Int64_literal_overflow -> Error (Literal_overflow "int64#") + | Error Nativeint_literal_overflow -> Error (Literal_overflow "nativeint#") + | Error Unknown_constant_literal -> + Error (Unknown_literal (Misc.format_as_unboxed_literal i, suffix)) + end let unboxed_constant_or_raise env loc cst = match unboxed_constant cst with diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 5b24d4f52a7..2d5077fcd53 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -27,6 +27,9 @@ type constant = | Const_int32 of int32 | Const_int64 of int64 | Const_nativeint of nativeint + | Const_unboxed_int32 of int32 + | Const_unboxed_int64 of int64 + | Const_unboxed_nativeint of nativeint module Uid = Shape.Uid diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 644fe1c0e35..56a4c0a84d5 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -36,6 +36,9 @@ type constant = | Const_int32 of int32 | Const_int64 of int64 | Const_nativeint of nativeint + | Const_unboxed_int32 of int32 + | Const_unboxed_int64 of int64 + | Const_unboxed_nativeint of nativeint module Uid = Shape.Uid diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 2c756b35707..0e7147419ae 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -141,6 +141,12 @@ let constant = function | Const_nativeint i -> `Parsetree (Pconst_integer (Nativeint.to_string i, Some 'n')) | Const_float f -> `Parsetree (Pconst_float (f,None)) | Const_unboxed_float f -> `Jane_syntax (Jane_syntax.Layouts.Float (f, None)) + | Const_unboxed_int32 i -> + `Jane_syntax (Jane_syntax.Layouts.Integer (Int32.to_string i, 'l')) + | Const_unboxed_int64 i -> + `Jane_syntax (Jane_syntax.Layouts.Integer (Int64.to_string i, 'L')) + | Const_unboxed_nativeint i -> + `Jane_syntax (Jane_syntax.Layouts.Integer (Nativeint.to_string i, 'n')) let attribute sub a = { attr_name = map_loc sub a.attr_name; diff --git a/utils/misc.ml b/utils/misc.ml index a378c6aaf62..dbe42bce9ef 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -761,6 +761,11 @@ let ordinal_suffix n = | 3 when not teen -> "rd" | _ -> "th" +let format_as_unboxed_literal s = + if String.starts_with ~prefix:"-" s + then "-#" ^ (String.sub s 1 (String.length s - 1)) + else "#" ^ s + (* Color handling *) module Color = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) diff --git a/utils/misc.mli b/utils/misc.mli index 53824dd6437..fd6e0e69719 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -407,6 +407,17 @@ val ordinal_suffix : int -> string [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and the numbers 11--13 (which all get ["th"]) correctly. *) +val format_as_unboxed_literal : string -> string +(** [format_as_unboxed_literal constant_literal] converts [constant_literal] to its + corresponding unboxed literal by either adding "#" in front or changing + "-" to "-#". + + Examples: + + [0.1] to [#0.1] + [-3] to [-#3] + [0xa.cp-1] to [#0xa.cp-1] *) + val normalise_eol : string -> string (** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters removed. Intended for pre-processing text which will subsequently be printed