Fix recursive module initialisation that does not terminate (#9497)

This fixes the bug reported in issue 9494 and adds a test case.

Closes: #9494 
(cherry picked from commit ff98901d11fb01ba224772c402763df20d246635)

Changes

@@ -124,6 +124,11 @@ OCaml 4.11
 - #9282: Make Cconst_symbol have typ_int to fix no-naked-pointers mode.
   (Stephen Dolan, review by Mark Shinwell, Xavier Leroy and Vincent Laviron)
 
+- #9497: Harmonise behaviour between bytecode and native code for
+  recursive module initialisation in one particular case (fixes #9494).
+  (Mark Shinwell, David Allsopp, Vincent Laviron, Xavier Leroy,
+  Geoff Reedy, original bug report by Arlen Cox)
+
 ### Code generation and optimizations:
 
 - #8637, #8805, #9247, #9296: Record debug info for each allocation.

stdlib/camlinternalMod.ml

@@ -51,12 +51,16 @@ let rec init_mod loc shape =
 let rec update_mod shape o n =
   match shape with
   | Function ->
-      (* The optimisation below is invalid on bytecode since
-         the RESTART instruction checks the length of closures.
-         See PR#4008 *)
-      if Sys.backend_type = Sys.Native
-      && Obj.tag n = Obj.closure_tag
-      && Obj.size n <= Obj.size o
+      (* In bytecode, the RESTART instruction checks the size of closures.
+         Hence, the optimized case [overwrite o n] is valid only if [o] and
+         [n] have the same size.  (See PR#4008.)
+         In native code, the size of closures does not matter, so overwriting
+         is possible so long as the size of [n] is no greater than that of [o].
+      *)
+      if Obj.tag n = Obj.closure_tag
+      && (Obj.size n = Obj.size o
+          || (Sys.backend_type = Sys.Native
+              && Obj.size n <= Obj.size o))
       then begin overwrite o n end
       else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
   | Lazy ->

testsuite/tests/typing-recmod/pr9494.ml

@@ -0,0 +1,38 @@
+(* TEST
+*)
+
+(* PR#9494 *)
+
+(* Additional test cases from Vincent Laviron: *)
+
+(* Looping version *)
+module rec M1 : sig
+  val f : unit -> unit
+  val g : unit -> unit
+end = struct
+  let f = M1.g
+  let g () = M1.f ()
+end
+
+(* Alias chain *)
+module rec M2 : sig
+  val f : unit -> unit
+  val g : unit -> unit
+end = struct
+  let f = M2.g
+  let g = M2.f
+end
+
+(* Original test case from the issue: *)
+
+module rec Id : sig
+  type t = {id : int}
+  val compare : t -> t -> int
+end = Id (* error here: undefined compare function *)
+
+module IdSet = Set.Make(Id)
+
+let _ = try
+  let basic_set = IdSet.singleton {id = 0} in
+  IdSet.mem {id = 1} basic_set (* diverge here *)
+with e -> print_endline @@ Printexc.to_string e; false

testsuite/tests/typing-recmod/pr9494.reference

@@ -0,0 +1 @@
+File "pr9494.ml", line 31, characters 6-12: Undefined recursive module