flambda-backend: Handle empty cases (fixes bug from #1899) (#1955)

Author: goldfirere

testsuite/tests/ppx-empty-cases/ppx_empty_cases.ml

@@ -0,0 +1,15 @@
+open Ast_mapper
+
+(* PPXes could have empty cases. *)
+
+let () =
+  register "empty_cases" (fun _ ->
+    { default_mapper with cases = fun _ cases ->
+      match cases with
+      | [ { pc_lhs = { ppat_desc = Ppat_extension ({ txt = "empty" }, _) };
+            pc_rhs = { pexp_desc = Pexp_unreachable };
+          }
+        ] -> []
+      | _ -> cases
+    }
+  )

testsuite/tests/ppx-empty-cases/test.compilers.reference

@@ -0,0 +1,40 @@
+(setglobal Test!
+  (let
+    (empty_cases_returning_string/268 =
+       (function {nlocal = 0} param/270
+         (raise
+           (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 28 50])))
+     empty_cases_returning_float64/271 =
+       (function {nlocal = 0} param/273 : unboxed_float
+         (raise
+           (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 29 50])))
+     empty_cases_accepting_string/274 =
+       (function {nlocal = 0} param/276
+         (raise
+           (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 30 50])))
+     empty_cases_accepting_float64/277 =
+       (function {nlocal = 0} param/279[unboxed_float]
+         (raise
+           (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 31 50])))
+     non_empty_cases_returning_string/280 =
+       (function {nlocal = 0} param/282
+         (raise
+           (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 32 68])))
+     non_empty_cases_returning_float64/283 =
+       (function {nlocal = 0} param/285 : unboxed_float
+         (raise
+           (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 33 68])))
+     non_empty_cases_accepting_string/286 =
+       (function {nlocal = 0} param/288
+         (raise
+           (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 34 68])))
+     non_empty_cases_accepting_float64/289 =
+       (function {nlocal = 0} param/291[unboxed_float]
+         (raise
+           (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 35 68]))))
+    (makeblock 0 empty_cases_returning_string/268
+      empty_cases_returning_float64/271 empty_cases_accepting_string/274
+      empty_cases_accepting_float64/277 non_empty_cases_returning_string/280
+      non_empty_cases_returning_float64/283
+      non_empty_cases_accepting_string/286
+      non_empty_cases_accepting_float64/289)))

testsuite/tests/ppx-empty-cases/test.ml

@@ -0,0 +1,36 @@
+(* TEST
+readonly_files = "ppx_empty_cases.ml"
+include ocamlcommon
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+program = "${test_build_directory}/ppx_empty_cases.exe"
+all_modules = "ppx_empty_cases.ml"
+*** ocamlc.byte
+module = "test.ml"
+flags = "-I ${test_build_directory} \
+         -ppx ${program} \
+         -extension layouts_alpha \
+         -dlambda"
+**** check-ocamlc.byte-output
+*)
+
+(* It's possible for ppx code to generate empty function cases. This is
+   compiled as a function that always raises [Match_failure].
+
+   In this test, we confirm that (i) we can handle these cases, and (ii) the
+   layout information in lambda is correct.
+ *)
+
+type t
+
+(* "function [%empty] -> ." is rewritten by a ppx in this directory to
+   a zero-case function. *)
+let empty_cases_returning_string  : t -> string = function [%empty] -> .
+let empty_cases_returning_float64 : t -> float# = function [%empty] -> .
+let empty_cases_accepting_string  : string -> t = function [%empty] -> .
+let empty_cases_accepting_float64 : float# -> t = function [%empty] -> .
+let non_empty_cases_returning_string  : t -> string = function _ -> assert false
+let non_empty_cases_returning_float64 : t -> float# = function _ -> assert false
+let non_empty_cases_accepting_string  : string -> t = function _ -> assert false
+let non_empty_cases_accepting_float64 : float# -> t = function _ -> assert false
+

typing/typecore.ml

@@ -3658,7 +3658,6 @@ end = struct
     | Local of Location.t  (* location of a local return *)
     | Not of Location.t  (* location of a non-local return *)
     | Either
-      [@@warning "-unused-constructor"]
 
   let combine flag1 flag2 =
     match flag1, flag2 with
@@ -3738,7 +3737,7 @@ end = struct
   let function_ cases =
     let rec loop_cases cases =
       match cases with
-      | [] -> Misc.fatal_error "empty cases in function_"
+      | [] -> Either
       | [{pc_lhs = _; pc_guard = None; pc_rhs = e}] ->
           loop_body e
       | case :: cases ->