From f22a16644665a8bea581cca7bb85a5006f4e699c Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Tue, 12 Sep 2023 21:02:21 -0400 Subject: [PATCH] Move `float64` to `layouts_beta` (#1812) * move float64 to layouts_beta * Revert changes to alpha tests * fix typo in error --- ocaml/boot/menhir/parser.ml | 4 +- ocaml/parsing/builtin_attributes.ml | 4 +- ocaml/parsing/builtin_attributes.mli | 13 +- ocaml/parsing/parser.mly | 4 +- .../tests/typing-layouts-float64/alloc.ml | 2 +- .../{basics_alpha.ml => basics_alpha_beta.ml} | 6 +- .../typing-layouts-float64/basics_beta.ml | 23 - .../{c_api_alpha.ml => c_api.ml} | 10 +- ...{c_api_alpha.reference => c_api.reference} | 0 .../tests/typing-layouts-float64/parsing.ml | 2 + ...lib_float_u_alpha.ml => stdlib_float_u.ml} | 9 +- .../unboxed_floats.compilers.reference | 5 - .../typing-layouts-float64/unboxed_floats.ml | 236 ++++- ...pha.reference => unboxed_floats.reference} | 0 .../unboxed_floats_alpha.ml | 312 ------ .../unboxed_floats_beta.compilers.reference | 5 - .../unboxed_floats_beta.ml | 106 --- ...nboxed_floats_disabled.compilers.reference | 4 + .../tests/typing-layouts/annots_beta.ml | 61 +- .../tests/typing-layouts/basics_alpha.ml | 4 +- .../tests/typing-layouts/basics_beta.ml | 899 ++++++++++++++++-- .../tests/typing-layouts/datatypes_beta.ml | 13 +- .../tests/typing-layouts/modules_beta.ml | 205 +++- .../parsing.compilers.reference | 2 +- .../parsing_beta.compilers.reference | 5 +- ocaml/typing/layouts.ml | 4 +- ocaml/typing/typeopt.ml | 6 +- ocaml/typing/typetexp.ml | 2 +- 28 files changed, 1363 insertions(+), 583 deletions(-) rename ocaml/testsuite/tests/typing-layouts-float64/{basics_alpha.ml => basics_alpha_beta.ml} (99%) delete mode 100644 ocaml/testsuite/tests/typing-layouts-float64/basics_beta.ml rename ocaml/testsuite/tests/typing-layouts-float64/{c_api_alpha.ml => c_api.ml} (85%) rename ocaml/testsuite/tests/typing-layouts-float64/{c_api_alpha.reference => c_api.reference} (100%) rename ocaml/testsuite/tests/typing-layouts-float64/{stdlib_float_u_alpha.ml => stdlib_float_u.ml} (97%) delete mode 100644 ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference rename ocaml/testsuite/tests/typing-layouts-float64/{unboxed_floats_alpha.reference => unboxed_floats.reference} (100%) delete mode 100644 ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml delete mode 100644 ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference delete mode 100644 ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference diff --git a/ocaml/boot/menhir/parser.ml b/ocaml/boot/menhir/parser.ml index 619896ec2b9..c410692143a 100644 --- a/ocaml/boot/menhir/parser.ml +++ b/ocaml/boot/menhir/parser.ml @@ -1171,7 +1171,7 @@ end = struct let assert_unboxed_literals ~loc = Language_extension.( - Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta) let unboxed ~loc x = assert_unboxed_literals ~loc:(make_loc loc); @@ -1216,7 +1216,7 @@ let unboxed_float sloc sign (f, m) = let assert_unboxed_float_type ~loc = Language_extension.( - Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta) let unboxed_float_type sloc tys = assert_unboxed_float_type ~loc:(make_loc sloc); diff --git a/ocaml/parsing/builtin_attributes.ml b/ocaml/parsing/builtin_attributes.ml index 6a084155e28..1fac21991a2 100644 --- a/ocaml/parsing/builtin_attributes.ml +++ b/ocaml/parsing/builtin_attributes.ml @@ -478,7 +478,9 @@ let layout ~legacy_immediate attrs = | Immediate | Immediate64 -> check (legacy_immediate || Language_extension.(is_at_least Layouts Beta)) - | Any | Void | Float64 -> + | Float64 -> + check Language_extension.(is_at_least Layouts Beta) + | Any | Void -> check Language_extension.(is_at_least Layouts Alpha) (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" diff --git a/ocaml/parsing/builtin_attributes.mli b/ocaml/parsing/builtin_attributes.mli index 212c9f033a9..6592d87d10f 100644 --- a/ocaml/parsing/builtin_attributes.mli +++ b/ocaml/parsing/builtin_attributes.mli @@ -175,8 +175,7 @@ val has_unique: Parsetree.attributes -> (bool,unit) result val has_once : Parsetree.attributes -> (bool, unit) result -(* [layout] gets the layout in the attributes if one is present. It is the - central point at which the layout extension flags are checked. We always +(* [layout] gets the layout in the attributes if one is present. We always allow the [value] annotation, even if the layouts extensions are disabled. If [~legacy_immediate] is true, we allow [immediate] and [immediate64] attributes even if the layouts extensions are disabled - this is used to @@ -190,14 +189,20 @@ val has_once : Parsetree.attributes -> (bool, unit) result - If no layout extensions are on and [~legacy_immediate] is false, this will always return [Ok None], [Ok (Some Value)], or [Error ...]. - If no layout extensions are on and [~legacy_immediate] is true, this will - error on [void] or [any], but allow [immediate], [immediate64], and [value]. + error on [void], [float64], or [any], but allow [immediate], [immediate64], + and [value]. - If the [Layouts_beta] extension is on, this behaves like the previous case - regardless of the value of [~legacy_immediate]. + regardless of the value of [~legacy_immediate], except that it allows + [float64]. - If the [Layouts_alpha] extension is on, this can return any layout and never errors. Currently, the [Layouts] extension is ignored - it's no different than turning on no layout extensions. + + This is not the only place the layouts extension level is checked. If you're + changing what's allowed in a given level, you may also need to make changes + in the parser, Layouts.get_required_layouts_level, and Typeopt. *) (* CR layouts: we should eventually be able to delete ~legacy_immediate (after we turn on layouts by default). *) diff --git a/ocaml/parsing/parser.mly b/ocaml/parsing/parser.mly index b19f86830e3..abd543b9604 100644 --- a/ocaml/parsing/parser.mly +++ b/ocaml/parsing/parser.mly @@ -946,7 +946,7 @@ end = struct let assert_unboxed_literals ~loc = Language_extension.( - Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta) let unboxed ~loc x = assert_unboxed_literals ~loc:(make_loc loc); @@ -991,7 +991,7 @@ let unboxed_float sloc sign (f, m) = let assert_unboxed_float_type ~loc = Language_extension.( - Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Alpha) + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Beta) let unboxed_float_type sloc tys = assert_unboxed_float_type ~loc:(make_loc sloc); diff --git a/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml b/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml index 816db8b5ddb..b48b59abfba 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/alloc.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-extension layouts_alpha" + flags = "-extension layouts_beta" * native *) diff --git a/ocaml/testsuite/tests/typing-layouts-float64/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/basics_alpha_beta.ml similarity index 99% rename from ocaml/testsuite/tests/typing-layouts-float64/basics_alpha.ml rename to ocaml/testsuite/tests/typing-layouts-float64/basics_alpha_beta.ml index 189a085064c..64eedb7f6f7 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/basics_alpha_beta.ml @@ -1,6 +1,8 @@ (* TEST - flags = "-extension layouts_alpha" * expect + flags = "-extension layouts_alpha" + * expect + flags = "-extension layouts_beta" *) (* This file contains typing tests for the layout [float64]. @@ -320,7 +322,7 @@ type f7_4 = [ `A of t_float64 ];; Line 1, characters 20-29: 1 | type f7_4 = [ `A of t_float64 ];; ^^^^^^^^^ -Error: Polymorpic variant constructor argument types must have layout value. +Error: Polymorphic variant constructor argument types must have layout value. t_float64 has layout float64, which is not a sublayout of value. |}];; diff --git a/ocaml/testsuite/tests/typing-layouts-float64/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts-float64/basics_beta.ml deleted file mode 100644 index 54149d44380..00000000000 --- a/ocaml/testsuite/tests/typing-layouts-float64/basics_beta.ml +++ /dev/null @@ -1,23 +0,0 @@ -(* TEST - flags = "-extension layouts_beta" - * expect -*) - -(* This file contains typing tests for the layout [float64]. - - Runtime tests for the type [float#] can be found in the [unboxed_float] and - [alloc] tests in this directory. The type [float#] here is used as a - convenient example of a concrete [float64] type in some tests, but its - behavior isn't the primary purpose of this test. *) - -(* CR layouts: Bring tests here from [basics_alpha.ml] once we have float64 in - layouts_beta *) - -type t_float64 [@@float64] -type ('a : float64) t_float64_id = 'a;; -[%%expect{| -Line 1, characters 15-26: -1 | type t_float64 [@@float64] - ^^^^^^^^^^^ -Error: Layout float64 is used here, but the appropriate layouts extension is not enabled -|}] diff --git a/ocaml/testsuite/tests/typing-layouts-float64/c_api_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/c_api.ml similarity index 85% rename from ocaml/testsuite/tests/typing-layouts-float64/c_api_alpha.ml rename to ocaml/testsuite/tests/typing-layouts-float64/c_api.ml index 58472687127..cebd559058d 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/c_api_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/c_api.ml @@ -1,6 +1,14 @@ (* TEST modules = "stubs.c" - flags = "-extension layouts_alpha" + reference = "${test_source_directory}/c_api.reference" + * native + flags = "-extension layouts_alpha" + * bytecode + flags = "-extension layouts_alpha" + * native + flags = "-extension layouts_beta" + * bytecode + flags = "-extension layouts_beta" *) (* This file tests using external C functions with float#. *) diff --git a/ocaml/testsuite/tests/typing-layouts-float64/c_api_alpha.reference b/ocaml/testsuite/tests/typing-layouts-float64/c_api.reference similarity index 100% rename from ocaml/testsuite/tests/typing-layouts-float64/c_api_alpha.reference rename to ocaml/testsuite/tests/typing-layouts-float64/c_api.reference diff --git a/ocaml/testsuite/tests/typing-layouts-float64/parsing.ml b/ocaml/testsuite/tests/typing-layouts-float64/parsing.ml index 257b5a2e8ba..e2a58c90b05 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/parsing.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/parsing.ml @@ -1,6 +1,8 @@ (* TEST flags = "-extension layouts_alpha" * expect + flags = "-extension layouts_beta" + * expect *) (* These tests show how potential ambiguities are resolved diff --git a/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u.ml similarity index 97% rename from ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml rename to ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u.ml index 866ea45f55b..47d746d8262 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/stdlib_float_u.ml @@ -1,5 +1,12 @@ (* TEST - flags = "-extension layouts_alpha" + * native + flags = "-extension layouts_alpha" + * bytecode + flags = "-extension layouts_alpha" + * native + flags = "-extension layouts_beta" + * bytecode + flags = "-extension layouts_beta" *) module Float_u = Stdlib__Float_u diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference deleted file mode 100644 index aa33a7c1b14..00000000000 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.compilers.reference +++ /dev/null @@ -1,5 +0,0 @@ -File "unboxed_floats.ml", line 74, characters 11-18: -74 | type ('a : float64) t_float64 = 'a - ^^^^^^^ -Error: Layout float64 is more experimental than allowed by -extension layouts. - You must enable -extension layouts_alpha to use this feature. diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml index e715f44f62b..9bf42b05bde 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.ml @@ -1,18 +1,26 @@ (* TEST - flags = "-extension layouts" - - ocamlc_byte_exit_status = "2" + reference = "${test_source_directory}/unboxed_floats.reference" + * native + flags = "-extension layouts_alpha" + * bytecode + flags = "-extension layouts_alpha" + * native + flags = "-extension layouts_beta" + * bytecode + flags = "-extension layouts_beta" * setup-ocamlc.byte-build-env + ocamlc_byte_exit_status = "2" + flags = "-extension layouts" ** ocamlc.byte + compiler_reference = "${test_source_directory}/unboxed_floats_disabled.compilers.reference" *** check-ocamlc.byte-output *) (* This file contains various tests for float#. It's not an expect test to make sure it gets tested for native code. *) -(* CR layouts: This should work when we allow unboxed floats by default. The - test stanza above should be edit to match the one in the alpha version of the - test, with an updated flag, and the reference file changed. *) +(* CR layouts v2.5: When unboxed literals work, change this file to use them + instead of [of_float] on boxed literals everywhere. *) (*****************************************) (* Prelude: Functions on unboxed floats. *) @@ -66,8 +74,8 @@ let test1 () = let _ = test1 () -(*******************************************) -(* Test 2: higher-order functions, capture *) +(**********************************) +(* Test 2: higher-order functions *) (* CR layouts v1.5: This type definition can be eliminated once we have annotations. *) @@ -104,3 +112,215 @@ let _ = let add_two_after = compose add_two in let minus_four = add_two_after (twice (fun x -> x - (of_float 3.0))) in minus_four (of_float 3.14)) + +(******************************) +(* Test 3: float# in closures *) + +(* [go]'s closure should haave an [int] (immediate), a [float#] (float64) and a + [float array] (value). *) +let[@inline never] f3 n m steps () = + let[@inline never] rec go k = + if k = n + then Float_u.of_float 0. + else begin + let acc = go (k + 1) in + steps.(k) <- Float_u.to_float acc; + Float_u.(+) m acc + end + in + go 0 + +(* many args - even args are tuples, odd args are unboxed floats *) +let[@inline_never] f3_manyargs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 steps () = + let (start_k, end_k) = x0 in + let[@inline never] rec go k = + if k = end_k + then Float_u.of_float 0. + else begin + let (x2_1, x2_2) = x2 in + let (x4_1, x4_2) = x4 in + let (x6_1, x6_2) = x6 in + let (x8_1, x8_2) = x8 in + let sum = x2_1 + x2_2 + x4_1 + x4_2 + x6_1 + x6_2 + x8_1 + x8_2 in + let acc = go (k + 1) in + steps.(k) <- Float_u.to_float acc; + Float_u.(acc + ((x1 + x3 + x5 + x7 + x9) * (of_float (Float.of_int sum)))) + end + in + go start_k + +let test3 () = + (* Test f3 *) + let steps = Array.init 10 (fun _ -> 0.0) in + let five_pi = f3 5 (Float_u.of_float 3.14) steps in + print_floatu "Test 3, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps; + + (* Test f3_manyargs + + (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 50.86 + 3 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 152.58 + 6 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 306.16 + 9 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 457.74 + + ( but we expect some floating point error ) + *) + let steps = Array.init 10 (fun _ -> 0.0) in + let x1 = Float_u.of_float 3.14 in + let x3 = Float_u.of_float 2.72 in + let x5 = Float_u.of_float 1.62 in + let x7 = Float_u.of_float 1.41 in + let x9 = Float_u.of_float 42.0 in + + (* these sum to 3 *) + let x2 = (7, 42) in + let x4 = (-23, 109) in + let x6 = (-242, 90) in + let x8 = (-2, 22) in + + let f3_manyargs = f3_manyargs (4,8) x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + print_floatu "Test 3, 610.68: " (f3_manyargs ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps + +let _ = test3 () + +(*********************************************) +(* Test 4: Partial and indirect applications *) + +let[@inline never] test4 () = + (* Simple indirect call *) + let[@inline never] go f = + Float_u.to_float (f (Float_u.of_float 1.) (Float_u.of_float 2.)) + in + let (x1, x2) = (go Float_u.(+), go Float_u.(-)) in + print_floatu "Test 4, 1 + 2" (Float_u.of_float x1); + print_floatu "Test 4, 1 - 2" (Float_u.of_float x2); + + (* partial application to float# *) + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 5 (Float_u.of_float 3.14)) in + let five_pi = f steps in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; + + (* partial application with float# remaining *) + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 6) in + let five_pi = f (Float_u.of_float 3.14) steps in + print_floatu "Test 4, 6 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; + + (* Those two tests again, but making f3 also opaque to prevent expansion of + the partial application. *) + let f3 = Sys.opaque_identity f3 in + + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 5 (Float_u.of_float 3.14)) in + let five_pi = f steps in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; + + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 6) in + let five_pi = f (Float_u.of_float 3.14) steps in + print_floatu "Test 4, 6 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps + +let _ = test4 () + +(****************************) +(* Test 5: Over application *) + +let[@inline never] f5 n m = + let open Float_u in + (* Also testing a closure with only float# values *) + let[@inline never] go f = + f (n + m) + in + go + +let test5 () = + let open Float_u in + let _ : unit = + f5 (of_float 3.14) (of_float 2.72) + (fun n s m -> print_floatu s (n + m)) "Test 5, pi+e+1" + (of_float 1.0) + in + () + +let _ = test5 () + +(*****************************) +(* Test 6: methods on floats *) + +(* CR layouts: add tests that capture floats in objects, once that is + allowed. *) + +(* float# args and returns *) +let f6_1 () = object + method f6_m1 f1 f2 f3 = + let open Float_u in + (f1 - f2) / f3 +end + +(* capture a pair, recursion *) +let f6_2 n = object(self) + method f6_m2 n3 m1 f = + if n3 = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) then + m1 + else f (self#f6_m2 (n3+1) m1 f) +end + +(* overapplication to float# and non-float# args *) +let f6_3 n k = object + method f6_m3 n3 m1 f = + let n = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) in + f (n + k + n3) m1 +end + +let test6 () = + let add3 n (m, k) = n + m + k in + let open Float_u in + + (* (3.14 - 2.72) / 2.5 = ~0.17 *) + let o = (Sys.opaque_identity f6_1) () in + print_floatu "Test 6, 0.17" + (o#f6_m1 (of_float 3.14) (of_float 2.72) (of_float 2.5)); + + (* 4.25 * 8 = 34 *) + let o = (Sys.opaque_identity f6_2) (4,7) in + let result = o#f6_m2 8 (of_float 4.25) (fun x -> x * of_float 2.) in + print_floatu "Test 6, 34.00" result; + + (* (1 + 2 + 3 + (-2) + (-12) + 4) * (2.72 + (-1) + 10) = -46.88 *) + let o = (Sys.opaque_identity f6_3) (1,2) 3 in + let result = + o#f6_m3 (-2) (of_float 2.72) + (fun[@inline never] i m1 m2 n m3 -> + (of_float (Float.of_int (add3 i n))) * (m1 + m2 + m3)) + (of_float (-1.)) (-12,4) (of_float 10.) + in + print_floatu "Test 6, -46.88" result + +let _ = test6 () + +(*****************************) +(* Test 7: letop with floats *) + +let ( let* ) x f = f Float_u.(x + (of_float 1.5)) + +let _ = + let* x = Float_u.of_float 42.0 in + print_floatu "Test 7, 36.50" Float_u.(x - of_float 7.0) + +let ( let* ) x (f : _ -> float#) = f x +let ( and* ) x y = Float_u.(x, to_float (y - (of_float 1.2))) +let _ = + let result = + let* x = 42.0 + and* y = Float_u.of_float 3.3 + and* z = Float_u.of_float (-10.7) in + Float_u.of_float (x +. y +. z) + in + print_floatu "Test 7, 32.20" result + diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference similarity index 100% rename from ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.reference rename to ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats.reference diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml deleted file mode 100644 index abd280a56b6..00000000000 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_alpha.ml +++ /dev/null @@ -1,312 +0,0 @@ -(* TEST - flags = "-extension layouts_alpha" -*) - -(* This file contains various tests for float#. It's not an expect test to make - sure it gets tested for native code. *) - -(* CR layouts v2.5: When unboxed literals work, change this file to use them - instead of [of_float] on boxed literals everywhere. *) - -(*****************************************) -(* Prelude: Functions on unboxed floats. *) - -module Float_u = struct - include Stdlib__Float_u - - let ( + ) = add - let ( - ) = sub - let ( * ) = mul - let ( / ) = div - let ( ** ) = pow - let ( > ) x y = (compare x y) > 0 -end - -(*********************************) -(* Test 1: some basic arithmetic *) - -let print_floatu prefix x = Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) - -(* Tests all the operators above *) -let test1 () = - (* CR layouts: When float64 defs are allowed at the module level, get rid of - [test1] and move these definitions there. *) - let open Float_u in - let pi = of_float 3.14 in - print_floatu "Test 1, pi" pi; - - let twice_pi = pi + (of_float 3.14) in - print_floatu "Test 1, twice_pi" twice_pi; - - let thrice_pi = (of_float 3.0) * pi in - print_floatu "Test 1, thrice_pi" thrice_pi; - - let twice_pi_again = thrice_pi - pi in - print_floatu "Test 1, twice_pi_again" twice_pi; - - let pi_again = twice_pi_again / (of_float 2.0) in - print_floatu "Test 1, pi_again" pi_again; - - let twice_pi_to_the_pi = twice_pi ** pi in - print_floatu "Test 1, twice_pi_to_the_pi" twice_pi_to_the_pi; - - let twice_pi_greater_than_pi = twice_pi > pi in - Printf.printf "Test 1, twice_pi_greater_than_pi: %b\n" - twice_pi_greater_than_pi; - - let pi_with_effort = - ((of_float 3.14) + twice_pi) * (of_float 2.0) / (of_float 6.0) in - print_floatu "Test 1, pi_with_effort" pi_with_effort - -let _ = test1 () - -(**********************************) -(* Test 2: higher-order functions *) - -(* CR layouts v1.5: This type definition can be eliminated once we have - annotations. *) -type ('a : float64) t_float64 = 'a - -let[@inline never] twice f (x : 'a t_float64) = f (f x) -let[@inline never] compose f g (x : 'a t_float64) = f (g x) - -let[@inline never] twice_on_pi f = - let pi = Float_u.of_float 3.14 in - twice f pi - -let times_four = twice Float_u.(fun x -> x * (of_float 2.0)) - -let _ = - let open Float_u in - print_floatu "Test 2, add pi twice" - (twice (fun x -> x + (of_float 3.14)) (of_float 0.0)); - print_floatu "Test 2, add pi four times" - (twice (twice (fun x -> x + (of_float 3.14))) (of_float 0.0)); - print_floatu "Test 2, increment pi twice" - (twice_on_pi (fun x -> (of_float 1.0) + x)); - print_floatu "Test 2, increment pi four times" - (twice_on_pi (twice (fun x -> (of_float 1.0) + x))); - print_floatu "Test 2, e times four" - (times_four (of_float 2.72)); - print_floatu "Test 2, pi times sixteen" - (twice_on_pi times_four); - print_floatu "Test 2, pi times sixteen again" - (compose times_four times_four (of_float 3.14)); - print_floatu "Test 2, pi minus four" - (let two = twice (fun x -> x + (of_float 1.0)) (of_float 0.0) in - let add_two = Float_u.(+) two in - let add_two_after = compose add_two in - let minus_four = add_two_after (twice (fun x -> x - (of_float 3.0))) in - minus_four (of_float 3.14)) - -(******************************) -(* Test 3: float# in closures *) - -(* [go]'s closure should haave an [int] (immediate), a [float#] (float64) and a - [float array] (value). *) -let[@inline never] f3 n m steps () = - let[@inline never] rec go k = - if k = n - then Float_u.of_float 0. - else begin - let acc = go (k + 1) in - steps.(k) <- Float_u.to_float acc; - Float_u.(+) m acc - end - in - go 0 - -(* many args - even args are tuples, odd args are unboxed floats *) -let[@inline_never] f3_manyargs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 steps () = - let (start_k, end_k) = x0 in - let[@inline never] rec go k = - if k = end_k - then Float_u.of_float 0. - else begin - let (x2_1, x2_2) = x2 in - let (x4_1, x4_2) = x4 in - let (x6_1, x6_2) = x6 in - let (x8_1, x8_2) = x8 in - let sum = x2_1 + x2_2 + x4_1 + x4_2 + x6_1 + x6_2 + x8_1 + x8_2 in - let acc = go (k + 1) in - steps.(k) <- Float_u.to_float acc; - Float_u.(acc + ((x1 + x3 + x5 + x7 + x9) * (of_float (Float.of_int sum)))) - end - in - go start_k - -let test3 () = - (* Test f3 *) - let steps = Array.init 10 (fun _ -> 0.0) in - let five_pi = f3 5 (Float_u.of_float 3.14) steps in - print_floatu "Test 3, 5 * pi: " (five_pi ()); - Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps; - - (* Test f3_manyargs - - (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 50.86 - 3 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 152.58 - 6 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 306.16 - 9 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 457.74 - - ( but we expect some floating point error ) - *) - let steps = Array.init 10 (fun _ -> 0.0) in - let x1 = Float_u.of_float 3.14 in - let x3 = Float_u.of_float 2.72 in - let x5 = Float_u.of_float 1.62 in - let x7 = Float_u.of_float 1.41 in - let x9 = Float_u.of_float 42.0 in - - (* these sum to 3 *) - let x2 = (7, 42) in - let x4 = (-23, 109) in - let x6 = (-242, 90) in - let x8 = (-2, 22) in - - let f3_manyargs = f3_manyargs (4,8) x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in - print_floatu "Test 3, 610.68: " (f3_manyargs ()); - Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps - -let _ = test3 () - -(*********************************************) -(* Test 4: Partial and indirect applications *) - -let[@inline never] test4 () = - (* Simple indirect call *) - let[@inline never] go f = - Float_u.to_float (f (Float_u.of_float 1.) (Float_u.of_float 2.)) - in - let (x1, x2) = (go Float_u.(+), go Float_u.(-)) in - print_floatu "Test 4, 1 + 2" (Float_u.of_float x1); - print_floatu "Test 4, 1 - 2" (Float_u.of_float x2); - - (* partial application to float# *) - let steps = Array.init 10 (fun _ -> 0.0) in - let f = Sys.opaque_identity (f3 5 (Float_u.of_float 3.14)) in - let five_pi = f steps in - print_floatu "Test 4, 5 * pi: " (five_pi ()); - Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; - - (* partial application with float# remaining *) - let steps = Array.init 10 (fun _ -> 0.0) in - let f = Sys.opaque_identity (f3 6) in - let five_pi = f (Float_u.of_float 3.14) steps in - print_floatu "Test 4, 6 * pi: " (five_pi ()); - Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; - - (* Those two tests again, but making f3 also opaque to prevent expansion of - the partial application. *) - let f3 = Sys.opaque_identity f3 in - - let steps = Array.init 10 (fun _ -> 0.0) in - let f = Sys.opaque_identity (f3 5 (Float_u.of_float 3.14)) in - let five_pi = f steps in - print_floatu "Test 4, 5 * pi: " (five_pi ()); - Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; - - let steps = Array.init 10 (fun _ -> 0.0) in - let f = Sys.opaque_identity (f3 6) in - let five_pi = f (Float_u.of_float 3.14) steps in - print_floatu "Test 4, 6 * pi: " (five_pi ()); - Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps - -let _ = test4 () - -(****************************) -(* Test 5: Over application *) - -let[@inline never] f5 n m = - let open Float_u in - (* Also testing a closure with only float# values *) - let[@inline never] go f = - f (n + m) - in - go - -let test5 () = - let open Float_u in - let _ : unit = - f5 (of_float 3.14) (of_float 2.72) - (fun n s m -> print_floatu s (n + m)) "Test 5, pi+e+1" - (of_float 1.0) - in - () - -let _ = test5 () - -(*****************************) -(* Test 6: methods on floats *) - -(* CR layouts: add tests that capture floats in objects, once that is - allowed. *) - -(* float# args and returns *) -let f6_1 () = object - method f6_m1 f1 f2 f3 = - let open Float_u in - (f1 - f2) / f3 -end - -(* capture a pair, recursion *) -let f6_2 n = object(self) - method f6_m2 n3 m1 f = - if n3 = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) then - m1 - else f (self#f6_m2 (n3+1) m1 f) -end - -(* overapplication to float# and non-float# args *) -let f6_3 n k = object - method f6_m3 n3 m1 f = - let n = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) in - f (n + k + n3) m1 -end - -let test6 () = - let add3 n (m, k) = n + m + k in - let open Float_u in - - (* (3.14 - 2.72) / 2.5 = ~0.17 *) - let o = (Sys.opaque_identity f6_1) () in - print_floatu "Test 6, 0.17" - (o#f6_m1 (of_float 3.14) (of_float 2.72) (of_float 2.5)); - - (* 4.25 * 8 = 34 *) - let o = (Sys.opaque_identity f6_2) (4,7) in - let result = o#f6_m2 8 (of_float 4.25) (fun x -> x * of_float 2.) in - print_floatu "Test 6, 34.00" result; - - (* (1 + 2 + 3 + (-2) + (-12) + 4) * (2.72 + (-1) + 10) = -46.88 *) - let o = (Sys.opaque_identity f6_3) (1,2) 3 in - let result = - o#f6_m3 (-2) (of_float 2.72) - (fun[@inline never] i m1 m2 n m3 -> - (of_float (Float.of_int (add3 i n))) * (m1 + m2 + m3)) - (of_float (-1.)) (-12,4) (of_float 10.) - in - print_floatu "Test 6, -46.88" result - -let _ = test6 () - -(*****************************) -(* Test 7: letop with floats *) - -let ( let* ) x f = f Float_u.(x + (of_float 1.5)) - -let _ = - let* x = Float_u.of_float 42.0 in - print_floatu "Test 7, 36.50" Float_u.(x - of_float 7.0) - -let ( let* ) x (f : _ -> float#) = f x -let ( and* ) x y = Float_u.(x, to_float (y - (of_float 1.2))) -let _ = - let result = - let* x = 42.0 - and* y = Float_u.of_float 3.3 - and* z = Float_u.of_float (-10.7) in - Float_u.of_float (x +. y +. z) - in - print_floatu "Test 7, 32.20" result - diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference deleted file mode 100644 index cadb7e5bd21..00000000000 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.compilers.reference +++ /dev/null @@ -1,5 +0,0 @@ -File "unboxed_floats_beta.ml", line 74, characters 11-18: -74 | type ('a : float64) t_float64 = 'a - ^^^^^^^ -Error: Layout float64 is more experimental than allowed by -extension layouts_beta. - You must enable -extension layouts_alpha to use this feature. diff --git a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml deleted file mode 100644 index 490523454a7..00000000000 --- a/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_beta.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* TEST - flags = "-extension layouts_beta" - - ocamlc_byte_exit_status = "2" - * setup-ocamlc.byte-build-env - ** ocamlc.byte - *** check-ocamlc.byte-output -*) - -(* This file contains various tests for float#. It's not an expect test to make - sure it gets tested for native code. *) - -(* CR layouts: This should work when we allow unboxed floats in layouts_beta. - The test stanza above should be edit to match the one in the alpha version of - the test, with an updated flag, and the reference file changed. *) - -(*****************************************) -(* Prelude: Functions on unboxed floats. *) - -module Float_u = struct - include Stdlib__Float_u - - let ( + ) = add - let ( - ) = sub - let ( * ) = mul - let ( / ) = div - let ( ** ) = pow - let ( > ) x y = (compare x y) > 0 -end - -(*********************************) -(* Test 1: some basic arithmetic *) - -let print_floatu prefix x = Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) - -(* Tests all the operators above *) -let test1 () = - (* CR layouts: When float64 defs are allowed at the module level, get rid of - [test1] and move these definitions there. *) - let open Float_u in - let pi = of_float 3.14 in - print_floatu "Test 1, pi" pi; - - let twice_pi = pi + (of_float 3.14) in - print_floatu "Test 1, twice_pi" twice_pi; - - let thrice_pi = (of_float 3.0) * pi in - print_floatu "Test 1, thrice_pi" thrice_pi; - - let twice_pi_again = thrice_pi - pi in - print_floatu "Test 1, twice_pi_again" twice_pi; - - let pi_again = twice_pi_again / (of_float 2.0) in - print_floatu "Test 1, pi_again" pi_again; - - let twice_pi_to_the_pi = twice_pi ** pi in - print_floatu "Test 1, twice_pi_to_the_pi" twice_pi_to_the_pi; - - let twice_pi_greater_than_pi = twice_pi > pi in - Printf.printf "Test 1, twice_pi_greater_than_pi: %b\n" - twice_pi_greater_than_pi; - - let pi_with_effort = - ((of_float 3.14) + twice_pi) * (of_float 2.0) / (of_float 6.0) in - print_floatu "Test 1, pi_with_effort" pi_with_effort - -let _ = test1 () - -(*******************************************) -(* Test 2: higher-order functions, capture *) - -(* CR layouts v1.5: This type definition can be eliminated once we have - annotations. *) -type ('a : float64) t_float64 = 'a - -let[@inline never] twice f (x : 'a t_float64) = f (f x) -let[@inline never] compose f g (x : 'a t_float64) = f (g x) - -let[@inline never] twice_on_pi f = - let pi = Float_u.of_float 3.14 in - twice f pi - -let times_four = twice Float_u.(fun x -> x * (of_float 2.0)) - -let _ = - let open Float_u in - print_floatu "Test 2, add pi twice" - (twice (fun x -> x + (of_float 3.14)) (of_float 0.0)); - print_floatu "Test 2, add pi four times" - (twice (twice (fun x -> x + (of_float 3.14))) (of_float 0.0)); - print_floatu "Test 2, increment pi twice" - (twice_on_pi (fun x -> (of_float 1.0) + x)); - print_floatu "Test 2, increment pi four times" - (twice_on_pi (twice (fun x -> (of_float 1.0) + x))); - print_floatu "Test 2, e times four" - (times_four (of_float 2.72)); - print_floatu "Test 2, pi times sixteen" - (twice_on_pi times_four); - print_floatu "Test 2, pi times sixteen again" - (compose times_four times_four (of_float 3.14)); - print_floatu "Test 2, pi minus four" - (let two = twice (fun x -> x + (of_float 1.0)) (of_float 0.0) in - let add_two = Float_u.(+) two in - let add_two_after = compose add_two in - let minus_four = add_two_after (twice (fun x -> x - (of_float 3.0))) in - minus_four (of_float 3.14)) 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 new file mode 100644 index 00000000000..ad4b78dea84 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-float64/unboxed_floats_disabled.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_floats.ml", line 316, characters 25-31: +316 | let ( let* ) x (f : _ -> float#) = f x + ^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/ocaml/testsuite/tests/typing-layouts/annots_beta.ml b/ocaml/testsuite/tests/typing-layouts/annots_beta.ml index 8c6477aca09..b8ea6a85433 100644 --- a/ocaml/testsuite/tests/typing-layouts/annots_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/annots_beta.ml @@ -6,14 +6,16 @@ type t_value : value type t_imm : immediate type t_imm64 : immediate64 +type t_float64 : float64 type t_any : any;; [%%expect{| type t_value : value type t_imm : immediate type t_imm64 : immediate64 -Line 4, characters 13-16: -4 | type t_any : any;; +type t_float64 : float64 +Line 5, characters 13-16: +5 | type t_any : any;; ^^^ Error: Layout any is used here, but the appropriate layouts extension is not enabled |}] @@ -41,6 +43,16 @@ val x : int = 5 val x : int = 5 |}] +let x : int as ('a : float64) = 5;; +[%%expect {| +Line 1, characters 8-29: +1 | let x : int as ('a : float64) = 5;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This alias is bound to type int but is used as an instance of type + ('a : float64) + int has layout immediate, which is not a sublayout of float64. +|}] + let x : (int as ('a : immediate)) list as ('b : value) = [3;4;5] ;; [%%expect {| @@ -66,12 +78,19 @@ type ('a : immediate) t2_imm type (_ : immediate) t2_imm' type t1 = int t2_imm type t2 = bool t2_imm +type ('a : float64) t2_float64 +type (_ : float64) t2_float64' +type t3 = float# t2_float64 + [%%expect {| type ('a : immediate) t2_imm type (_ : immediate) t2_imm' type t1 = int t2_imm type t2 = bool t2_imm +type ('a : float64) t2_float64 +type (_ : float64) t2_float64' +type t3 = float# t2_float64 |}] module M1 : sig @@ -198,6 +217,12 @@ Error: The universal type variable 'a was declared to have (* CR layouts v2.5: This error message should change to complain about the [fun x], not the arrow type. *) +let f : ('a : float64). 'a -> 'a = fun x -> x +;; +[%%expect {| +val f : ('a : float64). 'a -> 'a = +|}] + (********************************************) (* Test 4: Annotation on record field types *) @@ -209,6 +234,13 @@ type r = { field : ('a : immediate). 'a -> 'a; } val f : r -> int = |}] +type rf = { fieldf : ('a : float64). 'a -> 'a } +let f { fieldf } = fieldf (Stdlib__Float_u.of_float 3.14);; +[%%expect {| +type rf = { fieldf : ('a : float64). 'a -> 'a; } +val f : rf -> float# = +|}] + let f { field } = field "hello" ;; [%%expect {| @@ -286,6 +318,12 @@ let f = fun (type (a : immediate)) (x : a) -> x val f : ('a : immediate). 'a -> 'a = |}] +let f = fun (type (a : float64)) (x : a) -> x +;; +[%%expect {| +val f : ('a : float64). 'a -> 'a = +|}] + let f = fun (type (a : any)) (x : a) -> x ;; [%%expect {| @@ -313,6 +351,12 @@ let f : type (a : immediate). a -> a = fun x -> x val f : ('a : immediate). 'a -> 'a = |}] +let f : type (a : float64). a -> a = fun x -> x +;; +[%%expect {| +val f : ('a : float64). 'a -> 'a = +|}] + let f : type (a : any). a -> a = fun x -> x ;; [%%expect {| @@ -378,6 +422,19 @@ module type S = end |}] +module type S = sig + val f : 'a t2_float64 -> 'a t2_float64 + val g : ('a : float64). 'a t2_float64 -> 'a t2_float64 +end +;; +[%%expect {| +module type S = + sig + val f : ('a : float64). 'a t2_float64 -> 'a t2_float64 + val g : ('a : float64). 'a t2_float64 -> 'a t2_float64 + end +|}] + (************************************************************) (* Test 9: Annotation on universal in polymorphic parameter *) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml index e0cf7006dcb..0dba820e583 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml @@ -447,7 +447,7 @@ end Line 2, characters 40-46: 2 | type foo1 = [ `Foo1 of int | `Baz1 of t_void | `Bar1 of string ];; ^^^^^^ -Error: Polymorpic variant constructor argument types must have layout value. +Error: Polymorphic variant constructor argument types must have layout value. t_void has layout void, which is not a sublayout of value. |}];; @@ -501,7 +501,7 @@ end;; Line 2, characters 17-23: 2 | val x : [`A of t_void] ^^^^^^ -Error: Polymorpic variant constructor argument types must have layout value. +Error: Polymorphic variant constructor argument types must have layout value. t_void has layout void, which is not a sublayout of value. |}] diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index 3d203aad952..2bc1b7c18a3 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -5,12 +5,14 @@ type t_value : value type t_imm : immediate -type t_imm64 : immediate64;; +type t_imm64 : immediate64 +type t_float64 : float64;; [%%expect{| type t_value : value type t_imm : immediate type t_imm64 : immediate64 +type t_float64 : float64 |}] type t_any : any;; @@ -38,8 +40,8 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (*****************************************************) (* Test 2: Permit representable function arg/returns *) -(* CR layouts v2.5: much of this test moved to basics_alpha. Add float# versions - and bring them here. *) +(* CR layouts v5: the void bits of this test should be copied here from + basics_alpha *) module type S = sig val f1 : t_value -> t_value val f2 : t_imm -> t_imm64 @@ -49,6 +51,66 @@ end;; module type S = sig val f1 : t_value -> t_value val f2 : t_imm -> t_imm64 end |}];; +module type S2 = sig + val g : float# -> int +end;; +[%%expect{| +module type S2 = sig val g : float# -> int end +|}];; + +module type S2 = sig + val g : int -> float# +end +[%%expect {| +module type S2 = sig val g : int -> float# end +|}];; + +module type S2 = sig + type t' : float64 + type s' = r' -> int + and r' = t' +end;; +[%%expect{| +module type S2 = sig type t' : float64 type s' = r' -> int and r' = t' end +|}] + +module type S2 = sig + val f : int -> t_float64 +end;; +[%%expect {| +module type S2 = sig val f : int -> t_float64 end +|}];; + +module type S = sig + type t' : float64 + type 'a s' = 'a -> int constraint 'a = t' +end;; +[%%expect{| +module type S = + sig type t' : float64 type 'a s' = 'a -> int constraint 'a = t' end +|}] + +module F2 (X : sig val x : t_float64 end) = struct + let f () = X.x +end;; +[%%expect{| +Line 1, characters 27-36: +1 | module F2 (X : sig val x : t_float64 end) = struct + ^^^^^^^^^ +Error: This type signature for x is not a value type. + x has layout float64, which is not a sublayout of value. +|}];; +(* CR layouts v5: the test above should be made to work *) + +module F2 (X : sig val f : t_float64 -> unit end) = struct + let g z = X.f z +end;; +[%%expect{| +module F2 : + functor (X : sig val f : t_float64 -> unit end) -> + sig val g : t_float64 -> unit end +|}];; + (**************************************) (* Test 3: basic annotated parameters *) type ('a : immediate) imm_id = 'a @@ -151,8 +213,6 @@ Error: |}] (* CR layouts v2.9: improve error, which requires layout histories *) -(* CR layouts: bring [: any] and [: void] bits back here from [basics_alpha.ml] when we allow - them in beta. *) type ('a : any) t4 = 'a and s4 = string t4;; [%%expect{| @@ -247,17 +307,148 @@ Error: This type int * int should be an instance of type ('a : immediate) (**********************************************************) (* Test 8: Polymorphic variants take value args (for now) *) -(* CR layouts: these tests moved to [basics_alphs.ml] because they use void. - Similar tests should be added here once we have another sort (though we - will probably chose to allow it as an arg to polymorphic variants, not - ban it). *) +(* CR layouts v5: Bring over void versions of these tests. *) + +module M8_1f = struct + type foo1 = [ `Foo1 of int | `Baz1 of t_float64 | `Bar1 of string ];; +end +[%%expect{| +Line 2, characters 40-49: +2 | type foo1 = [ `Foo1 of int | `Baz1 of t_float64 | `Bar1 of string ];; + ^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M8_2f = struct + let foo x = + match x with + | `Baz 42 -> Stdlib__Float_u.of_float 3.14 + | `Bar v -> v + | `Bas i -> Stdlib__Float_u.of_float 3.14 +end;; +[%%expect {| +Line 5, characters 16-17: +5 | | `Bar v -> v + ^ +Error: This expression has type ('a : value) + but an expression was expected of type float# + float# has layout float64, which is not a sublayout of value. +|}];; + +module M8_3f = struct + type 'a t = [ `Foo of 'a | `Baz of int ] + + type bad = t_float64 t +end;; +[%%expect {| +Line 4, characters 13-22: +4 | type bad = t_float64 t + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M8_4f = struct + type 'a t = [ `Foo of 'a | `Baz of int ] constraint 'a = t_float64 +end;; +[%%expect {| +Line 2, characters 54-68: +2 | type 'a t = [ `Foo of 'a | `Baz of int ] constraint 'a = t_float64 + ^^^^^^^^^^^^^^ +Error: The type constraints are not consistent. + Type ('a : value) is not compatible with type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module type S8_5f = sig + val x : [`A of t_float64] +end;; +[%%expect{| +Line 2, characters 17-26: +2 | val x : [`A of t_float64] + ^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}] (************************************************) (* Test 9: Tuples only work on values (for now) *) -(* CR layouts: these tests moved to [basics_alphs.ml] because they need a - non-value layout. Similar tests should be added here once we have another - sort. *) +(* CR layouts v5: bring over void tests. *) +module M9_1f = struct + type foo1 = int * t_float64 * [ `Foo1 of int | `Bar1 of string ];; +end +[%%expect{| +Line 2, characters 20-29: +2 | type foo1 = int * t_float64 * [ `Foo1 of int | `Bar1 of string ];; + ^^^^^^^^^ +Error: Tuple element types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M9_2f = struct + type result = V of (string * t_float64) | I of int +end;; +[%%expect {| +Line 2, characters 31-40: +2 | type result = V of (string * t_float64) | I of int + ^^^^^^^^^ +Error: Tuple element types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M9_4f = struct + let f_id (x : float#) = x + + let foo x = + match x with + | (a, _) -> f_id a +end;; +[%%expect {| +Line 6, characters 21-22: +6 | | (a, _) -> f_id a + ^ +Error: This expression has type ('a : value) + but an expression was expected of type float# + float# has layout float64, which is not a sublayout of value. +|}];; + +module M9_5f = struct + type 'a t = (int * 'a) + + type bad = t_float64 t +end;; +[%%expect {| +Line 4, characters 13-22: +4 | type bad = t_float64 t + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M9_6f = struct + type 'a t = int * 'a constraint 'a = t_float64 +end;; +[%%expect {| +Line 2, characters 34-48: +2 | type 'a t = int * 'a constraint 'a = t_float64 + ^^^^^^^^^^^^^^ +Error: The type constraints are not consistent. + Type ('a : value) is not compatible with type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module type S9_7f = sig + val x : int * t_float64 +end;; +[%%expect{| +Line 2, characters 16-25: +2 | val x : int * t_float64 + ^^^^^^^^^ +Error: Tuple element types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; (*************************************************) (* Test 10: layouts are checked by "more general" *) @@ -336,12 +527,10 @@ Error: Signature mismatch: string has layout value, which is not a sublayout of immediate. |}] -(**************************************************************) -(* Test 11: objects are values and methods take/return values *) +(**********************************************************************) +(* Test 11: objects are values. methods may take/return other sorts. *) -(* CR layouts v2.5: These tests moved to [basics_alpha.ml] as they need a - non-value sort. Bring back here when we have one (and update to use that - sort instead of void). *) +(* CR layouts v5: bring the void versions back here. *) module M11_1 = struct type ('a : void) t = { x : int; v : 'a } @@ -356,22 +545,340 @@ Error: Layout void is more experimental than allowed by -extension layouts_beta. You must enable -extension layouts_alpha to use this feature. |}] +module M11_1f = struct + type ('a : float64) t = 'a + + let f (x : 'a t) = + x # baz11 +end;; +[%%expect{| +Line 5, characters 4-5: +5 | x # baz11 + ^ +Error: Methods must have layout value. + This expression has layout float64, which does not overlap with value. +|}] + +module M11_2f = struct + type ('a : float64) t = 'a + let f_id (x : 'a t) = x + let foo x = f_id (x # getfloat) +end;; +[%%expect{| +Line 4, characters 19-33: +4 | let foo x = f_id (x # getfloat) + ^^^^^^^^^^^^^^ +Error: This expression has type ('a : value) + but an expression was expected of type 'b t = ('b : float64) + 'a t has layout float64, which does not overlap with value. +|}];; + +module M11_3f = struct + type ('a : float64) t = 'a + + let foo o (x : 'a t) = o # usefloat x +end;; +[%%expect{| +module M11_3f : + sig + type ('a : float64) t = 'a + val foo : 'b ('a : float64). < usefloat : 'a t -> 'b; .. > -> 'a t -> 'b + end +|}];; + +module M11_4f = struct + val x : < l : t_float64 > +end;; +[%%expect{| +Line 2, characters 12-25: +2 | val x : < l : t_float64 > + ^^^^^^^^^^^^^ +Error: Object field types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +module M11_5f = struct + type 'a t = < l : 'a s > + and ('a : float64) s = 'a +end;; +[%%expect{| +Line 3, characters 2-27: +3 | and ('a : float64) s = 'a + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + 'a s has layout float64, which does not overlap with value. +|}];; + +module M11_6f = struct + type 'a t = < l : 'a > constraint 'a = t_float64 +end;; +[%%expect{| +Line 2, characters 36-50: +2 | type 'a t = < l : 'a > constraint 'a = t_float64 + ^^^^^^^^^^^^^^ +Error: The type constraints are not consistent. + Type ('a : value) is not compatible with type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + (*******************************************************************) (* Test 12: class parameters and bound vars must have layout value *) -(* CR layouts v2.5: These tests moved to [basics_alpha.ml] as they need a - non-value sort. Bring back here when we have one (and update to use that - sort instead of void). *) +(* CR layouts v5: Bring the void versions back here. *) + +(* Hits `Pcl_let` *) +module M12_1f = struct + let f : ('a : float64) . unit -> 'a = fun () -> assert false + class foo12 u = + let d = f u in + object + val bar = () + end;; +end +[%%expect{| +Line 4, characters 8-9: +4 | let d = f u in + ^ +Error: Variables bound in a class must have layout value. + d has layout float64, which is not a sublayout of value. +|}];; + +(* Hits the Cfk_concrete case of Pcf_val *) +module M12_2f = struct + let f : ('a : float64) . unit -> 'a = fun () -> assert false + class foo u = + object + val bar = f u + end +end;; +[%%expect{| +Line 5, characters 10-13: +5 | val bar = f u + ^^^ +Error: Variables bound in a class must have layout value. + bar has layout float64, which does not overlap with value. +|}];; + +(* Hits the Cfk_virtual case of Pcf_val *) +module M12_3f = struct + class virtual foo = + object + val virtual bar : t_float64 + end +end;; +[%%expect{| +Line 4, characters 18-21: +4 | val virtual bar : t_float64 + ^^^ +Error: Variables bound in a class must have layout value. + bar has layout float64, which is not a sublayout of value. +|}];; + +module M12_4f = struct + type ('a : float64) t + + class virtual ['a] foo = + object + val virtual baz : 'a t + end +end +[%%expect{| +Line 6, characters 24-26: +6 | val virtual baz : 'a t + ^^ +Error: This type ('a : float64) should be an instance of type ('a0 : value) + 'a has layout value, which does not overlap with float64. +|}];; + +module M12_5f = struct + type ('a : float64) t = 'a + + class ['a] foo = + object + method void_id (a : 'a t) : 'a t = a + end +end;; +[%%expect{| +Line 6, characters 26-28: +6 | method void_id (a : 'a t) : 'a t = a + ^^ +Error: This type ('a : float64) should be an instance of type ('a0 : value) + 'a has layout value, which does not overlap with float64. +|}];; + +module type S12_6f = sig + type ('a : float64) t = 'a + + class ['a] foo : + 'a t -> + object + method baz : int + end +end;; +[%%expect{| +Line 5, characters 4-6: +5 | 'a t -> + ^^ +Error: This type ('a : float64) should be an instance of type ('a0 : value) + 'a has layout value, which does not overlap with float64. +|}];; + +module type S12_7f = sig + class foo : + object + val baz : t_float64 + end +end;; +[%%expect{| +Line 4, characters 6-25: +4 | val baz : t_float64 + ^^^^^^^^^^^^^^^^^^^ +Error: Variables bound in a class must have layout value. + baz has layout float64, which is not a sublayout of value. +|}];; (***********************************************************) (* Test 13: built-in type constructors work only on values *) -(* CR layouts v2.5: These tests moved to [basics_alpha.ml] as they need a - non-value sort. Bring back here when we have one (and update to use that - sort instead of void). *) +(* CR layouts v5: Bring the void versions over from basics_alpha *) + +(* lazy *) +type t13f = t_float64 Lazy.t;; +[%%expect{| +Line 1, characters 12-21: +1 | type t13f = t_float64 Lazy.t;; + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13f (v : t_float64) = lazy v;; +[%%expect{| +Line 1, characters 32-33: +1 | let x13f (v : t_float64) = lazy v;; + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let f_id (x : t_float64) = x +let x13f v = + match v with + | lazy v -> f_id v +[%%expect{| +val f_id : t_float64 -> t_float64 = +Line 4, characters 19-20: +4 | | lazy v -> f_id v + ^ +Error: This expression has type ('a : value) + but an expression was expected of type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +(* option *) +(* CR layouts v5: allow this *) +type t13f = t_float64 option;; +[%%expect{| +Line 1, characters 12-21: +1 | type t13f = t_float64 option;; + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13f (v : t_float64) = Some v;; +[%%expect{| +Line 1, characters 32-33: +1 | let x13f (v : t_float64) = Some v;; + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13f v = + match v with + | Some v -> f_id v + | None -> assert false +[%%expect{| +Line 3, characters 19-20: +3 | | Some v -> f_id v + ^ +Error: This expression has type ('a : value) + but an expression was expected of type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +(* list *) +type t13f = t_float64 list;; +[%%expect{| +Line 1, characters 12-21: +1 | type t13f = t_float64 list;; + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13 (v : t_float64) = [v];; +[%%expect{| +Line 1, characters 27-28: +1 | let x13 (v : t_float64) = [v];; + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13 v = + match v with + | [v] -> f_id v + | _ -> assert false +[%%expect{| +Line 3, characters 16-17: +3 | | [v] -> f_id v + ^ +Error: This expression has type ('a : value) + but an expression was expected of type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +(* array *) +type t13f = t_float64 array;; +[%%expect{| +Line 1, characters 12-21: +1 | type t13f = t_float64 array;; + ^^^^^^^^^ +Error: This type t_float64 should be an instance of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13f (v : t_float64) = [| v |];; +[%%expect{| +Line 1, characters 30-31: +1 | let x13f (v : t_float64) = [| v |];; + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}];; + +let x13f v = + match v with + | [| v |] -> f_id v + | _ -> assert false +[%%expect{| +Line 3, characters 20-21: +3 | | [| v |] -> f_id v + ^ +Error: This expression has type ('a : value) + but an expression was expected of type t_float64 + t_float64 has layout float64, which is not a sublayout of value. +|}];; (****************************************************************************) (* Test 14: Examples motivating the trick with the manifest in [enter_type] *) + type t14 = foo14 list and foo14 = string;; [%%expect{| @@ -379,20 +886,36 @@ type t14 = foo14 list and foo14 = string |}];; -(* CR layouts v2.5: Part of this test moved to [basics_alpha.ml] as it needs a - non-value sort. Bring back here when we have one. *) +(* CR layouts v5: Bring back void version from basics_alpha. *) + +type t14 = foo14 list +and foo14 = t_float64;; +[%%expect{| +Line 2, characters 0-21: +2 | and foo14 = t_float64;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: + foo14 has layout float64, which is not a sublayout of value. +|}];; (****************************************************) (* Test 15: Type aliases need not have layout value *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: Bring back void version from basics_alpha. *) + +type ('a : float64) t15 +type ('a, 'b) foo15 = ('a as 'b) t15 -> 'b t15;; +[%%expect{| +type ('a : float64) t15 +type ('a : float64, 'b) foo15 = 'a t15 -> 'a t15 constraint 'b = 'a +|}] + (********************************************************) (* Test 16: seperability: [msig_of_external_type] logic *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: This test moved to [basics_alpha.ml] as it needs a non-value + sort in a variant. Bring back here when we have one. *) type 'a t_void_16 : void;; [%%expect{| @@ -434,94 +957,346 @@ val f18 : 'a -> 'a = (********************************) (* Test 19: non-value coercions *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let f19f () = + let x : t_float64 = assert false in + let _y = (x :> t_float64) in + ();; +[%%expect{| +val f19f : unit -> unit = +|}];; (********************************************) (* Test 20: Non-value bodies for let module *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let f20f () = + let x : t_float64 = assert false in + let _y = + let module M = struct end in + x + in + ();; +[%%expect{| +val f20f : unit -> unit = +|}];; (**********************************) (* Test 21: Non-value unpack body *) +module type M21 = sig end -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let f21f () = + let x : t_float64 = assert false in + let _y = + let (module M) = (module struct end : M21) in + x + in + ();; +[%%expect{| +module type M21 = sig end +val f21f : unit -> unit = +|}];; (***************************************************************) (* Test 22: approx_type catch-all can't be restricted to value *) -(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) -type t_void : void;; +type ('a : float64) t22f = 'a + +let f () = + let rec g x : _ t22f = g x in + g (assert false);; [%%expect{| -Line 1, characters 14-18: -1 | type t_void : void;; - ^^^^ -Error: Layout void is used here, but the appropriate layouts extension is not enabled +type ('a : float64) t22f = 'a +val f : ('a : float64). unit -> 'a t22f t22f = |}];; + (********************************************************************) (* Test 23: checking the error message from impossible GADT matches *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +type (_ : any, _ : any) eq = Refl : ('a, 'a) eq + +module Mf : sig + type t_float64 : float64 + type t_imm : immediate +end = struct + type t_float64 : float64 + type t_imm : immediate +end +(* these are abstract, so the only trouble with unifying them in a GADT + match is around their layouts *) + +let f (x : (Mf.t_float64, Mf.t_imm) eq) = + match x with + | Refl -> () + +[%%expect{| +type (_ : any, _ : any) eq = Refl : ('a : any). ('a, 'a) eq +module Mf : sig type t_float64 : float64 type t_imm : immediate end +Line 15, characters 4-8: +15 | | Refl -> () + ^^^^ +Error: This pattern matches values of type (Mf.t_float64, Mf.t_float64) eq + but a pattern was expected which matches values of type + (Mf.t_float64, Mf.t_imm) eq + Mf.t_float64 has layout float64, + which does not overlap with immediate. +|}] (*****************************************************) (* Test 24: Polymorphic parameter with exotic layout *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) +type 'a t2_float : float64 + +let f (x : 'a. 'a t2_float) = x + +[%%expect{| +type 'a t2_float : float64 +val f : ('a. 'a t2_float) -> 'b t2_float = +|}] (**************************************************) (* Test 25: Optional parameter with exotic layout *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let f (x : t_float64) = + let g ?(x2 = x) () = () in + () + +[%%expect{| +Line 2, characters 15-16: +2 | let g ?(x2 = x) () = () in + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}] (*********************************************************) (* Test 26: Inferring an application to an exotic layout *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let g f (x : t_float64) : t_float64 = f x + +[%%expect{| +val g : (t_float64 -> t_float64) -> t_float64 -> t_float64 = +|}] (******************************************) (* Test 27: Exotic layouts in approx_type *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let rec f : _ -> _ = fun (x : t_float64) -> x + +[%%expect{| +val f : t_float64 -> t_float64 = +|}] (************************************) (* Test 28: Exotic layouts in letop *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +(* 28.1: non-value letop arg *) +let ( let* ) (x : t_float64) f = () + +let q () = + let* x = assert false in + () + +[%%expect{| +val ( let* ) : t_float64 -> 'a -> unit = +val q : unit -> unit = +|}] + +(* 28.2: non-value letop binder arg without and *) +let ( let* ) x (f : t_float64 -> _) = () + +let q () = + let* x = assert false in + () + +[%%expect{| +val ( let* ) : 'a -> (t_float64 -> 'b) -> unit = +val q : unit -> unit = +|}] + +(* 28.3: non-value letop binder result *) +let ( let* ) x (f : _ -> t_float64) = () + +let q () = + let* x = assert false in + assert false + +[%%expect{| +val ( let* ) : 'a -> ('b -> t_float64) -> unit = +val q : unit -> unit = +|}] + +(* 28.4: non-value letop result *) +let ( let* ) x f : t_float64 = assert false + +let q () = + let* x = 5 in + () + +[%%expect{| +val ( let* ) : 'a -> 'b -> t_float64 = +val q : unit -> t_float64 = +|}] + +(* 28.5: non-value andop second arg *) +let ( let* ) x f = () +let ( and* ) x1 (x2 : t_float64) = () +let q () = + let* x = 5 + and* y = assert false + in + () + +[%%expect{| +val ( let* ) : 'a -> 'b -> unit = +val ( and* ) : 'a -> t_float64 -> unit = +val q : unit -> unit = +|}] + +(* 28.6: non-value andop first arg *) +let ( let* ) x f = () +let ( and* ) (x1 : t_float64) x2 = () +let q () = + let* x = assert false + and* y = 5 + in + () + +[%%expect{| +val ( let* ) : 'a -> 'b -> unit = +val ( and* ) : t_float64 -> 'a -> unit = +val q : unit -> unit = +|}] + +(* 28.7: non-value andop result *) +let ( let* ) (x : (_ : float64)) f = () +let ( and* ) x1 x2 : t_float64 = assert false +let q () = + let* x = 5 + and* y = 5 + in + () + +[%%expect{| +val ( let* ) : 'b ('a : float64). 'a -> 'b -> unit = +val ( and* ) : 'a -> 'b -> t_float64 = +val q : unit -> unit = +|}] + +(* 28.8: non-value letop binder arg with and *) +let ( let* ) x f = () +let ( and* ) x1 x2 = assert false +let q () = + let* x : t_float64 = assert false + and* y = 5 + in + () + +[%%expect{| +val ( let* ) : 'a -> 'b -> unit = +val ( and* ) : 'a -> 'b -> 'c = +Line 4, characters 9-22: +4 | let* x : t_float64 = assert false + ^^^^^^^^^^^^^ +Error: This pattern matches values of type t_float64 + but a pattern was expected which matches values of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}] (*******************************************) (* Test 29: [external]s default to [value] *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +external eq : 'a -> 'a -> bool = "%equal" +let mk_float64 () : t_float64 = assert false +let x () = eq (mk_float64 ()) (mk_float64 ()) + +[%%expect{| +external eq : 'a -> 'a -> bool = "%equal" +val mk_float64 : unit -> t_float64 = +Line 3, characters 14-29: +3 | let x () = eq (mk_float64 ()) (mk_float64 ()) + ^^^^^^^^^^^^^^^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}] (**************************************) (* Test 30: [val]s default to [value] *) -(* CR layouts v2.5: This test moved to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +module M : sig + val f : 'a -> 'a +end = struct + let f x = x +end + +let g (x : t_float64) = M.f x + +[%%expect{| +module M : sig val f : 'a -> 'a end +Line 7, characters 28-29: +7 | let g (x : t_float64) = M.f x + ^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}] (**************************************************) (* Test 31: checking that #poly_var patterns work *) -(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +type ('a : float64) poly_var = [`A of int * 'a | `B] + +let f #poly_var = "hello" + +[%%expect{| +Line 1, characters 44-46: +1 | type ('a : float64) poly_var = [`A of int * 'a | `B] + ^^ +Error: This type ('a : value) should be an instance of type ('a0 : float64) + 'a has layout float64, which does not overlap with value. +|}] (*********************************************************) (* Test 32: Polymorphic variant constructors take values *) -(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value - sort. Bring back here when we have one. *) +(* CR layouts v5: bring void version here from layouts_alpha *) + +let f _ = `Mk (assert false : t_float64) + +[%%expect{| +Line 1, characters 14-40: +1 | let f _ = `Mk (assert false : t_float64) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type t_float64 + but an expression was expected of type ('a : value) + t_float64 has layout float64, which is not a sublayout of value. +|}] (******************************************************) (* Test 33: Externals must have representable types *) diff --git a/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml b/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml index d3d3a696376..47db6f8470e 100644 --- a/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/datatypes_beta.ml @@ -30,10 +30,10 @@ Line 1, characters 14-18: Error: Layout void is used here, but the appropriate layouts extension is not enabled |}];; -(***************************************************) -(* Test 1: constructor arguments may have any sort *) +(********************************************************) +(* Test 1: constructor arguments may be values or voids *) -(* CR layouts v2.5: Needs non-value layout - moved to [datatypes_alpha.ml] *) +(* CR layouts v5: Needs void - moved to [datatypes_alpha.ml] *) (************************************) (* Test 2: but not the "any" layout *) @@ -85,9 +85,12 @@ Error: This expression has type float but an expression was expected of type (*****************************************************) (* Test 7: Recursive propagation of immediacy checks *) -(* CR layouts: copy test from datatypes_alpha with float64 when available *) +(* CR layouts v5: copy test from datatypes_alpha when non-values can go in + general datatype declarations. *) (***********************************************************************) (* Test 8: Type parameters in the presence of recursive concrete usage *) -(* CR layouts: copy test from datatypes_alpha with float64 when available *) +(* CR layouts v5: copy test from datatypes_alpha when non-values can go in + general datatype declarations. *) + diff --git a/ocaml/testsuite/tests/typing-layouts/modules_beta.ml b/ocaml/testsuite/tests/typing-layouts/modules_beta.ml index f0c5319fa42..df8f196d181 100644 --- a/ocaml/testsuite/tests/typing-layouts/modules_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/modules_beta.ml @@ -5,11 +5,13 @@ type t_value : value type t_imm : immediate -type t_imm64 : immediate64;; +type t_imm64 : immediate64 +type t_float64 : float64;; [%%expect {| type t_value : value type t_imm : immediate type t_imm64 : immediate64 +type t_float64 : float64 |}];; type t_any : any;; @@ -31,8 +33,8 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (*********************************************************) (* Test 1: Simple with type constraints respect layouts. *) -(* CR layouts v2.5: parts of this test moved to [modules_alpha.ml] because they - need a non-value layout. Bring back here when we have one. *) +(* CR layouts v5: parts of this test moved to [modules_alpha.ml] because they + need void. Bring back here when we have it. *) module type S1 = sig type ('a : void) t type s @@ -45,6 +47,41 @@ Error: Layout void is more experimental than allowed by -extension layouts_beta. You must enable -extension layouts_alpha to use this feature. |}];; +module type S1f = sig + type ('a : float64) t + type s +end;; + +type ('a : float64) t1;; + +module type S1f' = S1f with type 'a t = t_float64 t1 and type s = t_float64 t1;; + +[%%expect {| +module type S1f = sig type ('a : float64) t type s end +type ('a : float64) t1 +module type S1f' = + sig type ('a : float64) t = t_float64 t1 type s = t_float64 t1 end +|}];; + +module type S1f'' = S1f with type 'a t = 'a list;; +[%%expect {| +Line 1, characters 34-36: +1 | module type S1f'' = S1f with type 'a t = 'a list;; + ^^ +Error: The type constraints are not consistent. + Type ('a : value) is not compatible with type ('b : float64) + 'a has layout float64, which does not overlap with value. +|}];; + +module type S1f'' = S1f with type s = t_float64;; + +[%%expect{| +Line 1, characters 29-47: +1 | module type S1f'' = S1f with type s = t_float64;; + ^^^^^^^^^^^^^^^^^^ +Error: Type t_float64 has layout float64, which is not a sublayout of value. +|}] + module type S1_2 = sig type ('a : immediate) t end @@ -150,6 +187,9 @@ Error: This expression has type string but an expression was expected of type (******************************************************************) (* Test 3: Recursive modules, with and without layout annotations *) + +(* CR layouts v5: Some parts of this test need void. *) + module rec Foo3 : sig val create : Bar3.t -> unit end = struct @@ -166,8 +206,6 @@ module rec Foo3 : sig val create : Bar3.t -> unit end and Bar3 : sig type t end |}];; -(* CR layouts v2.5: parts of this test moved to [modules_alpha.ml] because they - need a non-value layout. Bring back here when we have one. *) module rec Foo3 : sig val create : Bar3.t -> unit end = struct @@ -186,6 +224,22 @@ Line 8, characters 11-15: Error: Layout void is used here, but the appropriate layouts extension is not enabled |}];; +module rec Foo3f : sig + val create : Bar3f.t -> unit +end = struct + let create _ = () +end + +and Bar3f : sig + type t : float64 +end = struct + type t : float64 +end;; +[%%expect {| +module rec Foo3f : sig val create : Bar3f.t -> unit end +and Bar3f : sig type t : float64 end +|}];; + module rec Foo3 : sig type t : immediate = Bar3.t end = struct @@ -220,15 +274,75 @@ module rec Foo3 : sig type t = Bar3.t end and Bar3 : sig type t : immediate end |}];; -(* CR layouts v2.5: more bits moved to [modules_alpha.ml] from down here. *) +module rec Foo3f : sig + type 'a t = 'a Bar3f.t * 'a list +end = struct + type t = 'a Bar3f.t * 'a list +end + +and Bar3f : sig + type ('a : float64) t +end = struct + type 'a t +end;; +[%%expect {| +Line 2, characters 27-29: +2 | type 'a t = 'a Bar3f.t * 'a list + ^^ +Error: This type ('a : float64) should be an instance of type ('b : value) + 'a has layout float64, which does not overlap with value. +|}];; + +type t3f : float64 + +module rec Foo3f : sig + type t = t3f +end = struct + type t = t3f +end + +and Bar3f : sig + type ('a : float64) t + + type s = Foo3f.t t +end = struct + type ('a : float64) t + type s = Foo3f.t t +end;; +[%%expect {| +type t3f : float64 +Line 12, characters 11-18: +12 | type s = Foo3f.t t + ^^^^^^^ +Error: This type Foo3f.t should be an instance of type ('a : float64) + Foo3f.t has layout value, which is not a sublayout of float64. +|}];; + +(* Previous example works with annotation *) +module rec Foo3f : sig + type t : float64 = t3f +end = struct + type t = t3f +end + +and Bar3 : sig + type ('a : float64) t + + type s = Foo3f.t t +end = struct + type ('a : float64) t + type s = Foo3f.t t +end;; +[%%expect {| +module rec Foo3f : sig type t = t3f end +and Bar3 : sig type ('a : float64) t type s = Foo3f.t t end +|}];; (*************************************************************************) (* Test 4: Nondep typedecl layout approximation in the Nondep_cannot_erase case. *) -(* CR layouts v2.5: The interesting parts of this test need a non-value layout and - have been moved to modules_alpha.ml. Bring back those parts once we have a - non-value layout. I've just commented them out below. *) +(* CR layouts v5: Bring back the void part of this test. *) module F4(X : sig type t end) = struct type s = Foo of X.t end @@ -236,7 +350,6 @@ end module M4 = F4(struct type t = T end) type ('a : value) t4_val -(* type ('a : void) t4_void *) type t4 = M4.s t4_val;; [%%expect {| @@ -246,16 +359,17 @@ type 'a t4_val type t4 = M4.s t4_val |}] -(* -type t4' = M4.s t4_void;; +type ('a : float64) t4_float64 +type t4f' = M4.s t4_float64;; [%%expect {| -Line 1, characters 11-15: -1 | type t4' = M4.s t4_void;; - ^^^^ -Error: This type M4.s should be an instance of type ('a : void) - M4.s has layout value, which is not a sublayout of void. +type ('a : float64) t4_float64 +Line 2, characters 12-16: +2 | type t4f' = M4.s t4_float64;; + ^^^^ +Error: This type M4.s should be an instance of type ('a : float64) + M4.s has layout value, which is not a sublayout of float64. |}] -*) + module F4'(X : sig type t : immediate end) = struct type s : immediate = Foo of X.t [@@unboxed] end @@ -274,16 +388,15 @@ type ('a : immediate) t4_imm type t4 = M4'.s t4_imm |}];; -(* -type t4 = M4'.s t4_void;; +type t4 = M4'.s t4_float64;; [%%expect{| Line 1, characters 10-15: -1 | type t4 = M4'.s t4_void;; +1 | type t4 = M4'.s t4_float64;; ^^^^^ -Error: This type M4'.s should be an instance of type ('a : void) - M4'.s has layout immediate, which is not a sublayout of void. +Error: This type M4'.s should be an instance of type ('a : float64) + M4'.s has layout immediate, which is not a sublayout of float64. |}];; -*) + (************************************) (* Test 5: Destructive substitution *) @@ -331,9 +444,7 @@ Error: Type string has layout value, which is not a sublayout of immediate. (*****************************************) (* Test 6: With constraints on packages. *) -(* CR layouts v2.5: The first part of this test needs a non-value layout and has - been moved to modules_alpha.ml. Bring it back once we have a non-value - layout. *) +(* CR layouts v5: Bring over void versions of these tests from modules_alpha *) module type S6_1 = sig type t : void end @@ -344,6 +455,43 @@ Line 2, characters 11-15: Error: Layout void is used here, but the appropriate layouts extension is not enabled |}] +module type S6_1f = sig + type t : float64 +end + +module type S6_2f = sig + val m : (module S6_1f with type t = int) +end;; +[%%expect{| +module type S6_1f = sig type t : float64 end +Line 6, characters 10-42: +6 | val m : (module S6_1f with type t = int) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this `with' constraint, the new definition of t + does not match its original definition in the constrained signature: + Type declarations do not match: + type t + is not included in + type t : float64 + the first has layout value, which is not a sublayout of float64. +|}];; + +module type S6_3 = sig + type t : value +end + +module type S6_4f = sig + val m : (module S6_3 with type t = t_float64) +end;; +[%%expect{| +module type S6_3 = sig type t : value end +Line 6, characters 33-34: +6 | val m : (module S6_3 with type t = t_float64) + ^ +Error: Signature package constraint types must have layout value. + t_float64 has layout float64, which is not a sublayout of value. +|}];; + module type S6_5 = sig type t : immediate end @@ -412,4 +560,5 @@ module F : sig end -> sig end (****************************************) (* Test 8: [val]s must be representable *) -(* CR layouts: Bring this test back from modules_alpha *) +(* CR layouts v2.5: Bring a float64 version of this test over when we allow + [t_any] in beta *) diff --git a/ocaml/testsuite/tests/typing-layouts/parsing.compilers.reference b/ocaml/testsuite/tests/typing-layouts/parsing.compilers.reference index dba6a57c62f..7ef77c54cee 100644 --- a/ocaml/testsuite/tests/typing-layouts/parsing.compilers.reference +++ b/ocaml/testsuite/tests/typing-layouts/parsing.compilers.reference @@ -16,7 +16,7 @@ Error: Syntax error: layout expected. Line 2, characters 9-15: 2 | type t = float#;; ^^^^^^ -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used Line 2, characters 9-13: 2 | type t = int#;; ^^^^ diff --git a/ocaml/testsuite/tests/typing-layouts/parsing_beta.compilers.reference b/ocaml/testsuite/tests/typing-layouts/parsing_beta.compilers.reference index fbc80531717..de52ef5a8a0 100644 --- a/ocaml/testsuite/tests/typing-layouts/parsing_beta.compilers.reference +++ b/ocaml/testsuite/tests/typing-layouts/parsing_beta.compilers.reference @@ -9,10 +9,7 @@ Line 2, characters 11-15: 2 | type ('a : valu) t0 = 'a list;; ^^^^ Error: Syntax error: layout expected. -Line 2, characters 9-15: -2 | type t = float#;; - ^^^^^^ -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +type t = float# Line 2, characters 9-13: 2 | type t = int#;; ^^^^ diff --git a/ocaml/typing/layouts.ml b/ocaml/typing/layouts.ml index f2ff2583778..3bbb3059a85 100644 --- a/ocaml/typing/layouts.ml +++ b/ocaml/typing/layouts.ml @@ -443,8 +443,8 @@ module Layout = struct Language_extension.maturity = match context, layout with | _, Value -> Stable - | _, (Immediate | Immediate64 | Any) -> Beta - | _, (Void | Float64) -> Alpha + | _, (Immediate | Immediate64 | Any | Float64) -> Beta + | _, Void -> Alpha (******************************) (* construction *) diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index cf4d9343938..8983405062b 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -556,7 +556,7 @@ let value_kind env loc ty = let layout env loc sort ty = match Layouts.Sort.get_default_value sort with | Value -> Lambda.Pvalue (value_kind env loc ty) - | Float64 when Language_extension.(is_at_least Layouts Alpha) -> + | Float64 when Language_extension.(is_at_least Layouts Beta) -> Lambda.Punboxed_float | Float64 -> raise (Error (loc, Non_value_sort (Sort.float64,ty))) | Void -> raise (Error (loc, Non_value_sort (Sort.void,ty))) @@ -564,7 +564,7 @@ let layout env loc sort ty = let layout_of_sort loc sort = match Layouts.Sort.get_default_value sort with | Value -> Lambda.Pvalue Pgenval - | Float64 when Language_extension.(is_at_least Layouts Alpha) -> + | Float64 when Language_extension.(is_at_least Layouts Beta) -> Lambda.Punboxed_float | Float64 -> raise (Error (loc, Non_value_sort_unknown_ty Sort.float64)) | Void -> raise (Error (loc, Non_value_sort_unknown_ty Sort.void)) @@ -572,7 +572,7 @@ let layout_of_sort loc sort = let layout_of_const_sort (s : Layouts.Sort.const) = match s with | Value -> Lambda.Pvalue Pgenval - | Float64 when Language_extension.(is_at_least Layouts Alpha) -> + | Float64 when Language_extension.(is_at_least Layouts Beta) -> Lambda.Punboxed_float | Float64 -> Misc.fatal_error "layout_of_const_sort: float64 encountered" | Void -> Misc.fatal_error "layout_of_const_sort: void encountered" diff --git a/ocaml/typing/typetexp.ml b/ocaml/typing/typetexp.ml index e8419b7e14b..1c3d1eea9f9 100644 --- a/ocaml/typing/typetexp.ml +++ b/ocaml/typing/typetexp.ml @@ -1369,7 +1369,7 @@ let report_error env ppf = function let s = match vloc with | Tuple -> "Tuple element" - | Poly_variant -> "Polymorpic variant constructor argument" + | Poly_variant -> "Polymorphic variant constructor argument" | Package_constraint -> "Signature package constraint" | Object_field -> "Object field" in