flambda-backend: Allow more function argument / returns to be non-value (#1422)

goldfirere · web-flow · commit 8bc3fd758a85 · 2023-05-29T10:31:13.000-04:00
* Polymorphic arguments might not be values

* Copy tests to basics and basics_beta

* Correct layout of optional arguments

* Allow non-value layouts when inferring an app

* Allow non-value arguments in approx_type

* Allow exotic sorts in letop

* Exotic layouts in andops

* Comments from review

* Foreshadow type_cases in comment
diff --git a/testsuite/tests/typing-layouts/basics.ml b/testsuite/tests/typing-layouts/basics.ml
@@ -251,3 +251,39 @@ Error: Layout void is used here, but the appropriate layouts extension is not en
 (* CR layouts v2: Once we allow non-value top-level module definitions, add
    tests showing that things get defaulted to value.
 *)
+
+(********************************************************************)
+(* Test 23: checking the error message from impossible GADT matches *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
+
+(*****************************************************)
+(* Test 24: Polymorphic parameter with exotic layout *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
+
+(**************************************************)
+(* Test 25: Optional parameter with exotic layout *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
+
+(*********************************************************)
+(* Test 26: Inferring an application to an exotic layout *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
+
+(******************************************)
+(* Test 27: Exotic layouts in approx_type *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
+
+(************************************)
+(* Test 28: Exotic layouts in letop *)
+
+(* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)
diff --git a/testsuite/tests/typing-layouts/basics_alpha.ml b/testsuite/tests/typing-layouts/basics_alpha.ml
@@ -727,12 +727,12 @@ module M11_3 = struct
   let foo o (A x) = o # usevoid x
 end;;
 [%%expect{|
-Line 4, characters 32-33:
+Line 4, characters 12-33:
 4 |   let foo o (A x) = o # usevoid x
-                                    ^
-Error: This expression has type ('a : void)
-       but an expression was expected of type ('b : value)
-       'a has layout value, which does not overlap with void.
+                ^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       'a has layout void, which is not a sublayout of value.
 |}];;
 
 module M11_4 = struct
@@ -1196,3 +1196,202 @@ Error: This pattern matches values of type (M.t_void, M.t_void) eq
 (* CR layouts v2: error message is OK, but it could probably be better.
    But a similar case without layouts is already pretty bad, so try
    that before spending too much time here. *)
+
+(*****************************************************)
+(* Test 24: Polymorphic parameter with exotic layout *)
+
+type 'a t2_void [@@void]
+
+let f (x : 'a. 'a t2_void) = x
+
+[%%expect{|
+type 'a t2_void [@@void]
+Line 3, characters 6-30:
+3 | let f (x : 'a. 'a t2_void) = x
+          ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       'a. 'a t2_void has layout void, which is not a sublayout of value.
+|}]
+
+(**************************************************)
+(* Test 25: Optional parameter with exotic layout *)
+
+let f (x : t_void) =
+  let g ?(x2 = x) () = () in
+  ()
+
+[%%expect{|
+Line 2, characters 15-16:
+2 |   let g ?(x2 = x) () = () in
+                   ^
+Error: This expression has type t_void but an expression was expected of type
+         ('a : value)
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+(*********************************************************)
+(* Test 26: Inferring an application to an exotic layout *)
+
+let g f (x : t_void) : t_void = f x
+
+[%%expect{|
+Line 1, characters 8-35:
+1 | let g f (x : t_void) : t_void = f x
+            ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+(******************************************)
+(* Test 27: Exotic layouts in approx_type *)
+
+let rec f : _ -> _ = fun (x : t_void) -> x
+
+[%%expect{|
+Line 1, characters 21-42:
+1 | let rec f : _ -> _ = fun (x : t_void) -> x
+                         ^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+(**********************************************)
+(* Test 28: Exotic layouts in letop and andop *)
+
+(* CR layouts: this must be [let rec] and [and] so that we can test the
+   type-checker, as opposed to the value-kind check. After we have proper
+   support for a non-value argument type, remove the [rec], throughout
+   this test.
+*)
+let rec ( let* ) (x : t_void) f = ()
+
+and q () =
+  let* x = assert false in
+  ()
+
+[%%expect{|
+Line 1, characters 17-36:
+1 | let rec ( let* ) (x : t_void) f = ()
+                     ^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x (f : t_void -> _) = ()
+
+and q () =
+  let* x = assert false in
+  ()
+
+[%%expect{|
+Lines 4-5, characters 2-4:
+4 | ..let* x = assert false in
+5 |   ()
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x (f : _ -> t_void) = ()
+
+and q () =
+  let* x = assert false in
+  assert false
+
+[%%expect{|
+Line 5, characters 2-14:
+5 |   assert false
+      ^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x f : t_void = assert false
+
+and q () =
+  let* x = 5 in
+  ()
+
+[%%expect{|
+Line 1, characters 19-44:
+1 | let rec ( let* ) x f : t_void = assert false
+                       ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x f = ()
+and ( and* ) x1 (x2 : t_void) = ()
+and q () =
+    let* x = 5
+    and* y = assert false
+    in
+    ()
+
+[%%expect{|
+Line 2, characters 16-34:
+2 | and ( and* ) x1 (x2 : t_void) = ()
+                    ^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x f = ()
+and ( and* ) (x1 : t_void) x2 = ()
+and q () =
+    let* x = assert false
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+Line 2, characters 13-34:
+2 | and ( and* ) (x1 : t_void) x2 = ()
+                 ^^^^^^^^^^^^^^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+let rec ( let* ) x f = ()
+and ( and* ) x1 x2 : t_void = assert false
+and q () =
+    let* x = 5
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+Line 1, characters 17-25:
+1 | let rec ( let* ) x f = ()
+                     ^^^^^^^^
+Error: Non-value detected in [value_kind].
+       Please report this error to the Jane Street compilers team.
+       t_void has layout void, which is not a sublayout of value.
+|}]
+
+(* CR layouts v5: when we allow non-values in tuples, this next one should
+   type-check *)
+let rec ( let* ) x f = ()
+and ( and* ) x1 x2 = assert false
+and q () =
+    let* x : t_void = assert false
+    and* y = 5
+    in
+    ()
+
+[%%expect{|
+Line 4, characters 9-19:
+4 |     let* x : t_void = assert false
+             ^^^^^^^^^^
+Error: This pattern matches values of type t_void
+       but a pattern was expected which matches values of type ('a : value)
+       t_void has layout void, which is not a sublayout of value.
+|}]
diff --git a/testsuite/tests/typing-layouts/basics_beta.ml b/testsuite/tests/typing-layouts/basics_beta.ml
@@ -457,3 +457,39 @@ Line 1, characters 12-20:
                 ^^^^^^^^
 Error: Layout void is used here, but the appropriate layouts extension is not enabled
 |}];;
+
+(********************************************************************)
+(* Test 23: checking the error message from impossible GADT matches *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
+
+(*****************************************************)
+(* Test 24: Polymorphic parameter with exotic layout *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
+
+(**************************************************)
+(* Test 25: Optional parameter with exotic layout *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
+
+(*********************************************************)
+(* Test 26: Inferring an application to an exotic layout *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
+
+(******************************************)
+(* Test 27: Exotic layouts in approx_type *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
+
+(************************************)
+(* Test 28: Exotic layouts in letop *)
+
+(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)
diff --git a/typing/ctype.ml b/typing/ctype.ml
@@ -3755,12 +3755,15 @@ let filter_arrow env t l ~force_tpoly =
     let t1 =
       if not force_tpoly then begin
         assert (not (is_optional l));
-        newvar2 level Layout.value
+        newvar2 level l1
       end else begin
         let t1 =
           if is_optional l then
             newty2 ~level
-              (Tconstr(Predef.path_option,[newvar2 level l1], ref Mnil))
+              (* CR layouts v5: Change the Layout.value when option can
+                 hold non-values. *)
+              (Tconstr(Predef.path_option,[newvar2 level Layout.value],
+                       ref Mnil))
           else
             newvar2 level l1
         in
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -3040,10 +3040,9 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar
           let ty_fun = expand_head env ty_fun in
           match get_desc ty_fun with
           | Tvar _ ->
-              (* CR layouts v2: value requirement to be relaxed *)
-              let ty_arg_mono = newvar Layout.value in
+              let ty_arg_mono = newvar (Layout.of_new_sort_var ()) in
               let ty_arg = newmono ty_arg_mono in
-              let ty_res = newvar Layout.value in
+              let ty_res = newvar (Layout.of_new_sort_var ()) in
               if ret_tvar &&
                  not (is_prim ~name:"%identity" funct) &&
                  not (is_prim ~name:"%obj_magic" funct)
@@ -3482,9 +3481,10 @@ let rec approx_type env sty =
       end
   | Ptyp_arrow (p, arg_sty, sty) ->
       let arg_mode = Typetexp.get_alloc_mode arg_sty in
-      let var = newvar Layout.value in
       let arg =
-        if is_optional p then type_option var else var
+        if is_optional p
+        then type_option (newvar Layout.value)
+        else newvar (Layout.of_new_sort_var ())
       in
       let ret = approx_type env sty in
       let marg = Alloc_mode.of_const arg_mode in
@@ -5414,18 +5414,24 @@ and type_expect_
       let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
       let op_type = instance op_desc.val_type in
       let spat_params, ty_params =
-        (* CR layouts v5: eliminate value requirement *)
-        loop slet.pbop_pat (newvar Layout.value) sands
-      in
-      (* CR layouts v2: eliminate value requirement *)
-      let ty_func_result = newvar Layout.value in
+        (* The use of a sort var here instead of a value is a little suspect,
+           because this can be the component of a tuple if there are several
+           [and] operators. In practice, all will be OK, though, because this
+           type will get unified with a tuple type (in the [type_cases] below)
+           and the sort var will get set to [value]. However, we still use a
+           sort var here to allow for a non-[value] type when there are no
+           [and]s. *)
+        (* CR layouts v5: Remove above comment when we support tuples of
+           non-[value] types. *)
+        loop slet.pbop_pat (newvar (Layout.of_new_sort_var ())) sands
+      in
+      let ty_func_result = newvar (Layout.of_new_sort_var ()) in
       let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in
       let ty_func =
         newty (Tarrow(arrow_desc, newmono ty_params, ty_func_result, commu_ok))
       in
-      (* CR layouts v2: eliminate value requirement *)
-      let ty_result = newvar Layout.value in
-      let ty_andops = newvar Layout.value in
+      let ty_result = newvar (Layout.of_new_sort_var ()) in
+      let ty_andops = newvar (Layout.of_new_sort_var ()) in
       let ty_op =
         newty (Tarrow(arrow_desc, newmono ty_andops,
           newty (Tarrow(arrow_desc, newmono ty_func,
@@ -7155,10 +7161,9 @@ and type_andops env sarg sands expected_ty =
         if !Clflags.principal then begin_def ();
         let op_path, op_desc = type_binding_op_ident env sop in
         let op_type = op_desc.val_type in
-        (* CR layouts v2: relax value requirements *)
-        let ty_arg = newvar Layout.value in
-        let ty_rest = newvar Layout.value in
-        let ty_result = newvar Layout.value in
+        let ty_arg = newvar (Layout.of_new_sort_var ()) in
+        let ty_rest = newvar (Layout.of_new_sort_var ()) in
+        let ty_result = newvar (Layout.of_new_sort_var ()) in
         let arrow_desc = (Nolabel,Alloc_mode.global,Alloc_mode.global) in
         let ty_rest_fun =
           newty (Tarrow(arrow_desc, newmono ty_arg, ty_result, commu_ok))
