flambda-backend: Quick temporary fix for rec mod layouts segfault (#2104)

Author: ccasin

lambda/translmod.ml

@@ -31,6 +31,7 @@ type unsafe_component =
   | Unsafe_functor
   | Unsafe_non_function
   | Unsafe_typext
+  | Unsafe_non_value_arg
 
 type unsafe_info =
   | Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }
@@ -322,8 +323,17 @@ let init_shape id modl =
     | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem ->
         let init_v =
           match get_desc (Ctype.expand_head env ty) with
-            Tarrow(_,_,_,_) ->
-              const_int 0 (* camlinternalMod.Function *)
+            Tarrow(_,ty_arg,_,_) -> begin
+              (* CR layouts: We should allow any representable layout here. It
+                 will require reworking [camlinternalMod.init_mod]. *)
+              let jkind = Jkind.value ~why:Recmod_fun_arg in
+              let ty_arg = Ctype.correct_levels ty_arg in
+              match Ctype.check_type_jkind env ty_arg jkind with
+              | Ok _ -> const_int 0 (* camlinternalMod.Function *)
+              | Error _ ->
+                let unsafe = Unsafe {reason=Unsafe_non_value_arg; loc; subid} in
+                raise (Initialization_failure unsafe)
+            end
           | Tconstr(p, _, _) when Path.same p Predef.path_lazy_t ->
               const_int 1 (* camlinternalMod.Lazy *)
           | _ ->
@@ -1890,6 +1900,9 @@ let explanation_submsg (id, unsafe_info) =
       | Unsafe_typext ->
           print "Module %s defines an unsafe extension constructor, %s ."
       | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ."
+      | Unsafe_non_value_arg ->
+        print "Module %s defines a function whose first argument \
+               is not a value, %s ."
 
 let report_error loc = function
   | Circular_dependency cycle ->

lambda/translmod.mli

@@ -45,6 +45,7 @@ type unsafe_component =
   | Unsafe_functor
   | Unsafe_non_function
   | Unsafe_typext
+  | Unsafe_non_value_arg
 
 type unsafe_info =
   | Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }

testsuite/tests/typing-layouts/modules.ml

@@ -572,3 +572,25 @@ Line 1, characters 28-33:
 Error: This type signature for x is not a value type.
        x has layout any, which is not a sublayout of value.
 |}]
+
+(****************************************************************)
+(* Test 9: Non-values temporarily banned in recmod safety check *)
+module type S = sig
+  val f : ('a : float64). 'a -> 'a
+end
+
+module rec M : S = M
+
+[%%expect{|
+module type S = sig val f : ('a : float64). 'a -> 'a end
+Line 5, characters 19-20:
+5 | module rec M : S = M
+                       ^
+Error: Cannot safely evaluate the definition of the following cycle
+       of recursively-defined modules: M -> M.
+       There are no safe modules in this cycle (see manual section 12.2).
+Line 2, characters 2-34:
+2 |   val f : ('a : float64). 'a -> 'a
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Module M defines a function whose first argument is not a value, f .
+|}]

testsuite/tests/typing-layouts/modules_alpha.ml

@@ -488,3 +488,25 @@ Line 1, characters 28-33:
 Error: This type signature for x is not a value type.
        x has layout any, which is not a sublayout of value.
 |}]
+
+(****************************************************************)
+(* Test 9: Non-values temporarily banned in recmod safety check *)
+module type S = sig
+  val f : ('a : float64). 'a -> 'a
+end
+
+module rec M : S = M
+
+[%%expect{|
+module type S = sig val f : ('a : float64). 'a -> 'a end
+Line 5, characters 19-20:
+5 | module rec M : S = M
+                       ^
+Error: Cannot safely evaluate the definition of the following cycle
+       of recursively-defined modules: M -> M.
+       There are no safe modules in this cycle (see manual section 12.2).
+Line 2, characters 2-34:
+2 |   val f : ('a : float64). 'a -> 'a
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Module M defines a function whose first argument is not a value, f .
+|}]

typing/jkind.ml

@@ -604,6 +604,7 @@ type value_creation_reason =
   | Debug_printer_argument
   | V1_safety_check
   | Captured_in_object
+  | Recmod_fun_arg
   | Unknown of string
 
 type immediate_creation_reason =
@@ -1051,6 +1052,9 @@ end = struct
       fprintf ppf "used as the argument to a debugger printer function"
     | V1_safety_check -> fprintf ppf "to be value for the V1 safety check"
     | Captured_in_object -> fprintf ppf "captured in an object"
+    | Recmod_fun_arg ->
+      fprintf ppf
+        "used as the first argument to a function in a recursive module"
     | Unknown s ->
       fprintf ppf
         "unknown @[(please alert the Jane Street@;\
@@ -1405,6 +1409,7 @@ module Debug_printers = struct
     | Debug_printer_argument -> fprintf ppf "Debug_printer_argument"
     | V1_safety_check -> fprintf ppf "V1_safety_check"
     | Captured_in_object -> fprintf ppf "Captured_in_object"
+    | Recmod_fun_arg -> fprintf ppf "Recmod_fun_arg"
     | Unknown s -> fprintf ppf "Unknown %s" s
 
   let void_creation_reason ppf : void_creation_reason -> _ = function

typing/jkind.mli

@@ -228,6 +228,7 @@ type value_creation_reason =
   | Debug_printer_argument
   | V1_safety_check
   | Captured_in_object
+  | Recmod_fun_arg
   | Unknown of string (* CR layouts: get rid of these *)
 
 type immediate_creation_reason =