diff --git a/ocaml/stdlib/.depend b/ocaml/stdlib/.depend index bb668863c0a..31a783caa3d 100644 --- a/ocaml/stdlib/.depend +++ b/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 \ diff --git a/ocaml/stdlib/camlinternalMod.ml b/ocaml/stdlib/camlinternalMod.ml index 8304eef2e30..740a156228b 100644 --- a/ocaml/stdlib/camlinternalMod.ml +++ b/ocaml/stdlib/camlinternalMod.ml @@ -18,8 +18,6 @@ open! Stdlib [@@@ocaml.flambda_o3] -external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward" - type shape = | Function | Lazy @@ -27,94 +25,71 @@ type shape = | 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" diff --git a/ocaml/testsuite/tests/basic-modules/recursive_module_init.ml b/ocaml/testsuite/tests/basic-modules/recursive_module_init.ml new file mode 100644 index 00000000000..cfe98fe138d --- /dev/null +++ b/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] diff --git a/ocaml/testsuite/tests/basic-modules/recursive_module_init.reference b/ocaml/testsuite/tests/basic-modules/recursive_module_init.reference new file mode 100644 index 00000000000..604a016f585 --- /dev/null +++ b/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