Merge pull request ocaml#80 from mshinwell/fb-backport-pr10205

Backport PR#10205 from upstream

ocaml/stdlib/.depend

@@ -181,6 +181,7 @@ camlinternalMod.cmo : \
     stdlib__Nativeint.cmi \
     camlinternalOO.cmi \
     stdlib__Array.cmi \
+    stdlib__Lazy.cmi \
     camlinternalMod.cmi
 camlinternalMod.cmx : \
     stdlib__Sys.cmx \
@@ -189,6 +190,7 @@ camlinternalMod.cmx : \
     stdlib__Nativeint.cmx \
     camlinternalOO.cmx \
     stdlib__Array.cmx \
+    stdlib__Lazy.cmx \
     camlinternalMod.cmi
 camlinternalMod.cmi : \
     stdlib.cmi \

ocaml/stdlib/camlinternalMod.ml

@@ -18,103 +18,78 @@ open! Stdlib
 
 [@@@ocaml.flambda_o3]
 
-external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward"
-
 type shape =
   | Function
   | Lazy
   | Class
   | Module of shape array
   | Value of Obj.t
 
-let overwrite o n =
-  assert (Obj.size o >= Obj.size n);
-  for i = 0 to Obj.size n - 1 do
-    Obj.set_field o i (Obj.field n i)
-  done
+let rec init_mod_field modu i loc shape =
+  let init =
+    match shape with
+    | Function ->
+       let rec fn (x : 'a) =
+         let fn' : 'a -> 'b = Obj.obj (Obj.field modu i) in
+         if fn == fn' then
+           raise (Undefined_recursive_module loc)
+         else
+           fn' x in
+       Obj.repr fn
+    | Lazy ->
+       let rec l =
+         lazy (
+           let l' = Obj.obj (Obj.field modu i) in
+           if l == l' then
+             raise (Undefined_recursive_module loc)
+           else
+             Lazy.force l') in
+       Obj.repr l
+    | Class ->
+       Obj.repr (CamlinternalOO.dummy_class loc)
+    | Module comps ->
+       Obj.repr (init_mod_block loc comps)
+    | Value v -> v
+  in
+  Obj.set_field modu i init
 
-let overwrite_closure o n =
-  (* We need to use the [raw_field] functions at least on the code
-     pointer, which is not a valid value in -no-naked-pointers
-     mode. *)
-  assert (Obj.tag n = Obj.closure_tag);
-  assert (Obj.size o >= Obj.size n);
-  let n_start_env = Obj.Closure.((info n).start_env) in
-  let o_start_env = Obj.Closure.((info o).start_env) in
-  (* if the environment of n starts before the one of o,
-     clear the raw fields in between. *)
-  for i = n_start_env to o_start_env - 1 do
-    Obj.set_raw_field o i Nativeint.one
-  done;
-  (* if the environment of o starts before the one of n,
-     clear the environment fields in between. *)
-  for i = o_start_env to n_start_env - 1 do
-    Obj.set_field o i (Obj.repr ())
-  done;
-  for i = 0 to n_start_env - 1 do
-    (* code pointers, closure info fields, infix headers *)
-    Obj.set_raw_field o i (Obj.raw_field n i)
-  done;
-  for i = n_start_env to Obj.size n - 1 do
-    (* environment fields *)
-    Obj.set_field o i (Obj.field n i)
-  done;
-  for i = Obj.size n to Obj.size o - 1 do
-    (* clear the leftover space *)
-    Obj.set_field o i (Obj.repr ())
+and init_mod_block loc comps =
+  let length = Array.length comps in
+  let modu = Obj.new_block 0 length in
+  for i = 0 to length - 1 do
+    init_mod_field modu i loc comps.(i)
   done;
-  ()
+  modu
 
-let rec init_mod loc shape =
+let init_mod loc shape =
   match shape with
-  | Function ->
-      (* Two code pointer words (curried and full application), arity
-         and eight environment entries makes 11 words. *)
-      let closure = Obj.new_block Obj.closure_tag 11 in
-      let template =
-        Obj.repr (fun _ -> raise (Undefined_recursive_module loc))
-      in
-      overwrite_closure closure template;
-      closure
-  | Lazy ->
-      Obj.repr (lazy (raise (Undefined_recursive_module loc)))
-  | Class ->
-      Obj.repr (CamlinternalOO.dummy_class loc)
   | Module comps ->
-      Obj.repr (Array.map (init_mod loc) comps)
-  | Value v ->
-      v
+     Obj.repr (init_mod_block loc comps)
+  | _ -> failwith "CamlinternalMod.init_mod: not a module"
 
-let rec update_mod shape o n =
+let rec update_mod_field modu i shape n =
   match shape with
-  | Function ->
-      (* 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_closure o n end
-      else overwrite_closure o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
-  | Lazy ->
-      if Obj.tag n = Obj.lazy_tag then
-        Obj.set_field o 0 (Obj.field n 0)
-      else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
-        make_forward o (Obj.field n 0)
-      end else begin
-        (* forwarding pointer was shortcut by GC *)
-        make_forward o n
-      end
+  | Function | Lazy ->
+     Obj.set_field modu i n
+  | Value _ ->
+     () (* the value is already there *)
   | Class ->
-      assert (Obj.tag n = 0 && Obj.size n = 4);
-      overwrite o n
+     assert (Obj.tag n = 0 && Obj.size n = 4);
+     let cl = Obj.field modu i in
+     for j = 0 to 3 do
+       Obj.set_field cl j (Obj.field n j)
+     done
+  | Module comps ->
+     update_mod_block comps (Obj.field modu i) n
+
+and update_mod_block comps o n =
+  assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
+  for i = 0 to Array.length comps - 1 do
+    update_mod_field o i comps.(i) (Obj.field n i)
+  done
+
+let update_mod shape o n =
+  match shape with
   | Module comps ->
-      assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
-      for i = 0 to Array.length comps - 1 do
-        update_mod comps.(i) (Obj.field o i) (Obj.field n i)
-      done
-  | Value _ -> () (* the value is already there *)
+     update_mod_block comps o n
+  | _ -> failwith "CamlinternalMod.update_mod: not a module"

ocaml/testsuite/tests/basic-modules/recursive_module_init.ml

@@ -0,0 +1,68 @@
+(* TEST *)
+
+let check ~stub txt f =
+  let run mode f =
+    match f mode with
+    | n -> string_of_int n
+    | exception Undefined_recursive_module _ -> "__" in
+  Printf.printf "%5s[%s]: nonrec => %s, self => %s, mod => %s\n%!"
+    txt
+    (if f == stub then "stub" else "real")
+    (run `Nonrec f)
+    (run `Self f)
+    (run `Mod f)
+
+module rec M : sig
+  val f1 : [`Nonrec|`Self|`Mod] -> int
+  val f2 : [`Nonrec|`Self|`Mod] -> int
+  val f3 : [`Nonrec|`Self|`Mod] -> int
+  val f4 : unit -> [`Nonrec|`Self|`Mod] -> int
+  val f5 : unit -> [`Nonrec|`Self|`Mod] -> int
+end = struct
+  let rec f1 mode =
+    match mode with
+    | `Nonrec -> 42
+    | `Self -> f1 `Nonrec
+    | `Mod -> M.f1 `Nonrec
+  let f2 = f1
+  let f3 = M.f1
+  let f4 () = f1
+  let f5 () = M.f1
+
+  let () =
+    check ~stub:f3 "f1" f1;
+    check ~stub:f3 "f2" f2;
+    check ~stub:f3 "f3" f3;
+    check ~stub:f3 "f4" (f4 ());
+    check ~stub:f3 "f5" (f5 ())
+end
+
+let () =
+  check ~stub:M.f3 "M.f1" M.f1;
+  check ~stub:M.f3 "M.f2" M.f2;
+  check ~stub:M.f3 "M.f3" M.f3;
+  check ~stub:M.f3 "M.f4" (M.f4 ());
+  check ~stub:M.f3 "M.f5" (M.f5 ())
+
+
+module rec Foo : sig
+  class cls : object
+    method go : unit
+  end
+  module M : sig
+    val foo : unit -> cls
+    val bar : cls Lazy.t
+  end
+end = struct
+  class cls = object
+    method go = print_endline "go"
+  end
+  module M = struct
+    let foo () = new Foo.cls
+    let bar = lazy (foo ())
+  end
+end
+
+let () =
+  List.iter (fun x -> x#go)
+    [new Foo.cls; Foo.M.foo(); Lazy.force Foo.M.bar]

ocaml/testsuite/tests/basic-modules/recursive_module_init.reference

@@ -0,0 +1,13 @@
+   f1[real]: nonrec => 42, self => 42, mod => __
+   f2[real]: nonrec => 42, self => 42, mod => __
+   f3[stub]: nonrec => __, self => __, mod => __
+   f4[real]: nonrec => 42, self => 42, mod => __
+   f5[stub]: nonrec => __, self => __, mod => __
+ M.f1[real]: nonrec => 42, self => 42, mod => 42
+ M.f2[real]: nonrec => 42, self => 42, mod => 42
+ M.f3[stub]: nonrec => 42, self => 42, mod => 42
+ M.f4[real]: nonrec => 42, self => 42, mod => 42
+ M.f5[real]: nonrec => 42, self => 42, mod => 42
+go
+go
+go