flambda-backend: Fix uncaught exception for non-representable type st…

…atements (#1928)

* fix other test and add the failing one

* implement fix

testsuite/tests/typing-layouts/basics.ml

@@ -327,3 +327,15 @@ Error: Layout void is used here, but the appropriate layouts extension is not en
 
 (* CR layouts: This test moved to [basics_beta.ml] as it needs an immediate
    type parameter.  Bring back here when we have one enabled by default. *)
+
+(****************************************************)
+(* Test 35: check bad layout error in filter_arrow *)
+
+(* CR layouts: This test moved to [basics_beta.ml] as it needs an immediate
+   type parameter.  Bring back here when we have one enabled by default. *)
+
+(**************************************************)
+(* Test 36: Disallow non-representable statements *)
+
+(* CR layouts: This test moved to [basics_beta.ml]. Bring here when we have
+   non-representable layouts enabled by default. *)

testsuite/tests/typing-layouts/basics_alpha.ml

@@ -1599,3 +1599,66 @@ Error: This type signature for foo33 is not a value type.
 (* Test 34: Layout clash in polymorphic record type *)
 
 (* tested elsewhere *)
+
+(****************************************************)
+(* Test 35: check bad layout error in filter_arrow *)
+
+type ('a : immediate) t35 = 'a
+let f35 : 'a t35 = fun () -> ()
+
+[%%expect {|
+type ('a : immediate) t35 = 'a
+Line 2, characters 19-31:
+2 | let f35 : 'a t35 = fun () -> ()
+                       ^^^^^^^^^^^^
+Error:
+       'a -> 'b has layout value, which is not a sublayout of immediate.
+|}]
+
+(**************************************************)
+(* Test 36: Disallow non-representable statements *)
+
+let () = (assert false : t_any); ()
+[%%expect{|
+Line 1, characters 9-31:
+1 | let () = (assert false : t_any); ()
+             ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 10-22:
+1 | let () = (assert false : t_any); ()
+              ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_5)
+       because it is in the left-hand side of a sequence
+       t_any has layout any, which is not representable.
+|}]
+
+let () = while false do (assert false : t_any); done
+[%%expect{|
+Line 1, characters 24-46:
+1 | let () = while false do (assert false : t_any); done
+                            ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 25-37:
+1 | let () = while false do (assert false : t_any); done
+                             ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_6)
+       because it is in the body of a while-loop
+       t_any has layout any, which is not representable.
+|}]
+
+let () = for i = 0 to 0 do (assert false : t_any); done
+[%%expect{|
+Line 1, characters 27-49:
+1 | let () = for i = 0 to 0 do (assert false : t_any); done
+                               ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 28-40:
+1 | let () = for i = 0 to 0 do (assert false : t_any); done
+                                ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_7)
+       because it is in the body of a for-loop
+       t_any has layout any, which is not representable.
+|}]

testsuite/tests/typing-layouts/basics_beta.ml

@@ -1404,3 +1404,51 @@ Line 2, characters 19-31:
 Error:
        'a -> 'b has layout value, which is not a sublayout of immediate.
 |}]
+
+(**************************************************)
+(* Test 36: Disallow non-representable statements *)
+
+let () = (assert false : t_any); ()
+[%%expect{|
+Line 1, characters 9-31:
+1 | let () = (assert false : t_any); ()
+             ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 10-22:
+1 | let () = (assert false : t_any); ()
+              ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_5)
+       because it is in the left-hand side of a sequence
+       t_any has layout any, which is not representable.
+|}]
+
+let () = while false do (assert false : t_any); done
+[%%expect{|
+Line 1, characters 24-46:
+1 | let () = while false do (assert false : t_any); done
+                            ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 25-37:
+1 | let () = while false do (assert false : t_any); done
+                             ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_6)
+       because it is in the body of a while-loop
+       t_any has layout any, which is not representable.
+|}]
+
+let () = for i = 0 to 0 do (assert false : t_any); done
+[%%expect{|
+Line 1, characters 27-49:
+1 | let () = for i = 0 to 0 do (assert false : t_any); done
+                               ^^^^^^^^^^^^^^^^^^^^^^
+Warning 10 [non-unit-statement]: this expression should have type unit.
+Line 1, characters 28-40:
+1 | let () = for i = 0 to 0 do (assert false : t_any); done
+                                ^^^^^^^^^^^^
+Error: This expression has type t_any but an expression was expected of type
+         ('a : '_representable_layout_7)
+       because it is in the body of a for-loop
+       t_any has layout any, which is not representable.
+|}]

typing/typecore.ml

@@ -7069,7 +7069,10 @@ and type_statement ?explanation ?(position=RNontail) env sexp =
     exp, Jkind.Sort.value
   else begin
     check_partial_application ~statement:true exp;
-    unify_var env tv ty;
+    with_explanation explanation (fun () ->
+      try unify_var env ty tv
+      with Unify err ->
+        raise(Error(exp.exp_loc, env, Expr_type_clash(err, None, Some exp.exp_desc))));
     exp, sort
   end