Skip to content

Commit d9017ae

Browse files
stedolanstedolan
authored
flambda-backend: Merge pull request oxcaml#80 from mshinwell/fb-backport-pr10205
Backport PR#10205 from upstream
2 parents f31890e + 3a4824e commit d9017ae

4 files changed

Lines changed: 142 additions & 84 deletions

File tree

‎stdlib/.depend‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -181,6 +181,7 @@ camlinternalMod.cmo : \
181181
stdlib__Nativeint.cmi \
182182
camlinternalOO.cmi \
183183
stdlib__Array.cmi \
184+
stdlib__Lazy.cmi \
184185
camlinternalMod.cmi
185186
camlinternalMod.cmx : \
186187
stdlib__Sys.cmx \
@@ -189,6 +190,7 @@ camlinternalMod.cmx : \
189190
stdlib__Nativeint.cmx \
190191
camlinternalOO.cmx \
191192
stdlib__Array.cmx \
193+
stdlib__Lazy.cmx \
192194
camlinternalMod.cmi
193195
camlinternalMod.cmi : \
194196
stdlib.cmi \

‎stdlib/camlinternalMod.ml‎

Lines changed: 59 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -18,103 +18,78 @@ open! Stdlib
1818

1919
[@@@ocaml.flambda_o3]
2020

21-
external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward"
22-
2321
type shape =
2422
| Function
2523
| Lazy
2624
| Class
2725
| Module of shape array
2826
| Value of Obj.t
2927

30-
let overwrite o n =
31-
assert (Obj.size o >= Obj.size n);
32-
for i = 0 to Obj.size n - 1 do
33-
Obj.set_field o i (Obj.field n i)
34-
done
28+
let rec init_mod_field modu i loc shape =
29+
let init =
30+
match shape with
31+
| Function ->
32+
let rec fn (x : 'a) =
33+
let fn' : 'a -> 'b = Obj.obj (Obj.field modu i) in
34+
if fn == fn' then
35+
raise (Undefined_recursive_module loc)
36+
else
37+
fn' x in
38+
Obj.repr fn
39+
| Lazy ->
40+
let rec l =
41+
lazy (
42+
let l' = Obj.obj (Obj.field modu i) in
43+
if l == l' then
44+
raise (Undefined_recursive_module loc)
45+
else
46+
Lazy.force l') in
47+
Obj.repr l
48+
| Class ->
49+
Obj.repr (CamlinternalOO.dummy_class loc)
50+
| Module comps ->
51+
Obj.repr (init_mod_block loc comps)
52+
| Value v -> v
53+
in
54+
Obj.set_field modu i init
3555

36-
let overwrite_closure o n =
37-
(* We need to use the [raw_field] functions at least on the code
38-
pointer, which is not a valid value in -no-naked-pointers
39-
mode. *)
40-
assert (Obj.tag n = Obj.closure_tag);
41-
assert (Obj.size o >= Obj.size n);
42-
let n_start_env = Obj.Closure.((info n).start_env) in
43-
let o_start_env = Obj.Closure.((info o).start_env) in
44-
(* if the environment of n starts before the one of o,
45-
clear the raw fields in between. *)
46-
for i = n_start_env to o_start_env - 1 do
47-
Obj.set_raw_field o i Nativeint.one
48-
done;
49-
(* if the environment of o starts before the one of n,
50-
clear the environment fields in between. *)
51-
for i = o_start_env to n_start_env - 1 do
52-
Obj.set_field o i (Obj.repr ())
53-
done;
54-
for i = 0 to n_start_env - 1 do
55-
(* code pointers, closure info fields, infix headers *)
56-
Obj.set_raw_field o i (Obj.raw_field n i)
57-
done;
58-
for i = n_start_env to Obj.size n - 1 do
59-
(* environment fields *)
60-
Obj.set_field o i (Obj.field n i)
61-
done;
62-
for i = Obj.size n to Obj.size o - 1 do
63-
(* clear the leftover space *)
64-
Obj.set_field o i (Obj.repr ())
56+
and init_mod_block loc comps =
57+
let length = Array.length comps in
58+
let modu = Obj.new_block 0 length in
59+
for i = 0 to length - 1 do
60+
init_mod_field modu i loc comps.(i)
6561
done;
66-
()
62+
modu
6763

68-
let rec init_mod loc shape =
64+
let init_mod loc shape =
6965
match shape with
70-
| Function ->
71-
(* Two code pointer words (curried and full application), arity
72-
and eight environment entries makes 11 words. *)
73-
let closure = Obj.new_block Obj.closure_tag 11 in
74-
let template =
75-
Obj.repr (fun _ -> raise (Undefined_recursive_module loc))
76-
in
77-
overwrite_closure closure template;
78-
closure
79-
| Lazy ->
80-
Obj.repr (lazy (raise (Undefined_recursive_module loc)))
81-
| Class ->
82-
Obj.repr (CamlinternalOO.dummy_class loc)
8366
| Module comps ->
84-
Obj.repr (Array.map (init_mod loc) comps)
85-
| Value v ->
86-
v
67+
Obj.repr (init_mod_block loc comps)
68+
| _ -> failwith "CamlinternalMod.init_mod: not a module"
8769

88-
let rec update_mod shape o n =
70+
let rec update_mod_field modu i shape n =
8971
match shape with
90-
| Function ->
91-
(* In bytecode, the RESTART instruction checks the size of closures.
92-
Hence, the optimized case [overwrite o n] is valid only if [o] and
93-
[n] have the same size. (See PR#4008.)
94-
In native code, the size of closures does not matter, so overwriting
95-
is possible so long as the size of [n] is no greater than that of [o].
96-
*)
97-
if Obj.tag n = Obj.closure_tag
98-
&& (Obj.size n = Obj.size o
99-
|| (Sys.backend_type = Sys.Native
100-
&& Obj.size n <= Obj.size o))
101-
then begin overwrite_closure o n end
102-
else overwrite_closure o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
103-
| Lazy ->
104-
if Obj.tag n = Obj.lazy_tag then
105-
Obj.set_field o 0 (Obj.field n 0)
106-
else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
107-
make_forward o (Obj.field n 0)
108-
end else begin
109-
(* forwarding pointer was shortcut by GC *)
110-
make_forward o n
111-
end
72+
| Function | Lazy ->
73+
Obj.set_field modu i n
74+
| Value _ ->
75+
() (* the value is already there *)
11276
| Class ->
113-
assert (Obj.tag n = 0 && Obj.size n = 4);
114-
overwrite o n
77+
assert (Obj.tag n = 0 && Obj.size n = 4);
78+
let cl = Obj.field modu i in
79+
for j = 0 to 3 do
80+
Obj.set_field cl j (Obj.field n j)
81+
done
82+
| Module comps ->
83+
update_mod_block comps (Obj.field modu i) n
84+
85+
and update_mod_block comps o n =
86+
assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
87+
for i = 0 to Array.length comps - 1 do
88+
update_mod_field o i comps.(i) (Obj.field n i)
89+
done
90+
91+
let update_mod shape o n =
92+
match shape with
11593
| Module comps ->
116-
assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
117-
for i = 0 to Array.length comps - 1 do
118-
update_mod comps.(i) (Obj.field o i) (Obj.field n i)
119-
done
120-
| Value _ -> () (* the value is already there *)
94+
update_mod_block comps o n
95+
| _ -> failwith "CamlinternalMod.update_mod: not a module"

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

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
(* TEST *)
2+
3+
let check ~stub txt f =
4+
let run mode f =
5+
match f mode with
6+
| n -> string_of_int n
7+
| exception Undefined_recursive_module _ -> "__" in
8+
Printf.printf "%5s[%s]: nonrec => %s, self => %s, mod => %s\n%!"
9+
txt
10+
(if f == stub then "stub" else "real")
11+
(run `Nonrec f)
12+
(run `Self f)
13+
(run `Mod f)
14+
15+
module rec M : sig
16+
val f1 : [`Nonrec|`Self|`Mod] -> int
17+
val f2 : [`Nonrec|`Self|`Mod] -> int
18+
val f3 : [`Nonrec|`Self|`Mod] -> int
19+
val f4 : unit -> [`Nonrec|`Self|`Mod] -> int
20+
val f5 : unit -> [`Nonrec|`Self|`Mod] -> int
21+
end = struct
22+
let rec f1 mode =
23+
match mode with
24+
| `Nonrec -> 42
25+
| `Self -> f1 `Nonrec
26+
| `Mod -> M.f1 `Nonrec
27+
let f2 = f1
28+
let f3 = M.f1
29+
let f4 () = f1
30+
let f5 () = M.f1
31+
32+
let () =
33+
check ~stub:f3 "f1" f1;
34+
check ~stub:f3 "f2" f2;
35+
check ~stub:f3 "f3" f3;
36+
check ~stub:f3 "f4" (f4 ());
37+
check ~stub:f3 "f5" (f5 ())
38+
end
39+
40+
let () =
41+
check ~stub:M.f3 "M.f1" M.f1;
42+
check ~stub:M.f3 "M.f2" M.f2;
43+
check ~stub:M.f3 "M.f3" M.f3;
44+
check ~stub:M.f3 "M.f4" (M.f4 ());
45+
check ~stub:M.f3 "M.f5" (M.f5 ())
46+
47+
48+
module rec Foo : sig
49+
class cls : object
50+
method go : unit
51+
end
52+
module M : sig
53+
val foo : unit -> cls
54+
val bar : cls Lazy.t
55+
end
56+
end = struct
57+
class cls = object
58+
method go = print_endline "go"
59+
end
60+
module M = struct
61+
let foo () = new Foo.cls
62+
let bar = lazy (foo ())
63+
end
64+
end
65+
66+
let () =
67+
List.iter (fun x -> x#go)
68+
[new Foo.cls; Foo.M.foo(); Lazy.force Foo.M.bar]

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

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
f1[real]: nonrec => 42, self => 42, mod => __
2+
f2[real]: nonrec => 42, self => 42, mod => __
3+
f3[stub]: nonrec => __, self => __, mod => __
4+
f4[real]: nonrec => 42, self => 42, mod => __
5+
f5[stub]: nonrec => __, self => __, mod => __
6+
M.f1[real]: nonrec => 42, self => 42, mod => 42
7+
M.f2[real]: nonrec => 42, self => 42, mod => 42
8+
M.f3[stub]: nonrec => 42, self => 42, mod => 42
9+
M.f4[real]: nonrec => 42, self => 42, mod => 42
10+
M.f5[real]: nonrec => 42, self => 42, mod => 42
11+
go
12+
go
13+
go

0 commit comments

Comments
 (0)