Skip to content

Fix camlinternalOO at -O3 with Flambda 2 #132

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Aug 4, 2021
Merged

Fix camlinternalOO at -O3 with Flambda 2 #132

Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
f3e4e93
Fix camlinternalOO at -O3 with Flambda 2
mshinwell Jul 30, 2021
acd722c
Take two
mshinwell Aug 4, 2021
a2a1b5c
Remove redundant opaque_identity
mshinwell Aug 4, 2021
7dedfa8
Rename obj -> of_repr for the Obj function
mshinwell Aug 4, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
87 changes: 49 additions & 38 deletions ocaml/stdlib/camlinternalOO.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,12 +16,22 @@

open! Stdlib

[@@@ocaml.flambda_o3]

[@@@ocaml.inline 0]
[@@@ocaml.afl_inst_ratio 0]

open Obj
let magic x = Sys.opaque_identity (Obj.magic x)
let of_repr x = Sys.opaque_identity (Obj.obj x)

let repr = Obj.repr
let dup = Obj.dup
let new_block = Obj.new_block
let set_field = Obj.set_field

let set_object_field (arr : _ array) field new_value =
Array.unsafe_set (Sys.opaque_identity arr) field new_value

let get_object_field (arr : _ array) field =
Array.unsafe_get (Sys.opaque_identity arr) field

(**** Object representation ****)

Expand All @@ -30,7 +40,7 @@ external set_id: 'a -> 'a = "caml_set_oo_id" [@@noalloc]
(**** Object copy ****)

let copy o =
let o = (Obj.obj (Obj.dup (Obj.repr o))) in
let o = (of_repr (dup (repr o))) in
set_id o

(**** Compression options ****)
Expand Down Expand Up @@ -126,7 +136,7 @@ let dummy_table =
let table_count = ref 0

(* dummy_met should be a pointer, so use an atom *)
let dummy_met : item = obj (Obj.new_block 0 0)
let dummy_met : item = of_repr (new_block 0 0)
(* if debugging is needed, this could be a good idea: *)
(* let dummy_met () = failwith "Undefined method" *)

Expand Down Expand Up @@ -271,7 +281,7 @@ let new_variable table name =
index

let to_array arr =
if arr = Obj.magic 0 then [||] else arr
if arr = magic 0 then [||] else arr

let new_methods_variables table meths vals =
let meths = to_array meths in
Expand Down Expand Up @@ -326,7 +336,7 @@ let init_class table =
let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
narrow cla vals virt_meths concr_meths;
let init =
if top then super cla env else Obj.repr (super cla) in
if top then super cla env else repr (super cla) in
widen cla;
Array.concat
[[| repr init |];
Expand All @@ -339,7 +349,7 @@ let make_class pub_meths class_init =
let table = create_table pub_meths in
let env_init = class_init table in
init_class table;
(env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
(env_init (repr 0), class_init, env_init, repr 0)

type init_table = { mutable env_init: t; mutable class_init: table -> t }

Expand All @@ -352,24 +362,24 @@ let make_class_store pub_meths class_init init_table =

let dummy_class loc =
let undef = fun _ -> raise (Undefined_recursive_module loc) in
(Obj.magic undef, undef, undef, Obj.repr 0)
(magic undef, undef, undef, repr 0)

(**** Objects ****)

let create_object table =
(* XXX Appel de [obj_block] | Call to [obj_block] *)
let obj = Obj.new_block Obj.object_tag table.size in
let obj = new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] | Call to [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
Obj.obj (set_id obj)
set_field obj 0 (repr table.methods);
of_repr (set_id obj)

let create_object_opt obj_0 table =
if (Obj.magic obj_0 : bool) then obj_0 else begin
if (magic obj_0 : bool) then obj_0 else begin
(* XXX Appel de [obj_block] | Call to [obj_block] *)
let obj = Obj.new_block Obj.object_tag table.size in
let obj = new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] | Call to [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
Obj.obj (set_id obj)
set_field obj 0 (repr table.methods);
of_repr (set_id obj)
end

let rec iter_f obj =
Expand All @@ -383,14 +393,14 @@ let run_initializers obj table =
iter_f obj inits

let run_initializers_opt obj_0 obj table =
if (Obj.magic obj_0 : bool) then obj else begin
if (magic obj_0 : bool) then obj else begin
let inits = table.initializers in
if inits <> [] then iter_f obj inits;
obj
end

let create_object_and_run_initializers obj_0 table =
if (Obj.magic obj_0 : bool) then obj_0 else begin
if (magic obj_0 : bool) then obj_0 else begin
let obj = create_object table in
run_initializers obj table;
obj
Expand Down Expand Up @@ -429,7 +439,8 @@ let get_next = function
| Cons tables -> tables.next

let build_path n keys tables =
let res = Cons {key = Obj.magic 0; data = Empty; next = Empty} in
let obj_zero = magic 0 in
let res = Cons {key = obj_zero; data = Empty; next = Empty} in
let r = ref res in
for i = 0 to n do
r := Cons {key = keys.(i); data = !r; next = Empty}
Expand Down Expand Up @@ -466,59 +477,59 @@ let lookup_tables root keys =
(**** builtin methods ****)

let get_const x = ret (fun _obj -> x)
let get_var n = ret (fun obj -> Array.unsafe_get obj n)
let get_var n = ret (fun obj -> get_object_field obj n)
let get_env e n =
ret (fun obj ->
Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
get_object_field (magic (get_object_field obj e) : obj) n)
let get_meth n = ret (fun obj -> sendself obj n)
let set_var n = ret (fun obj x -> Array.unsafe_set obj n x)
let set_var n = ret (fun obj x -> set_object_field obj n x)
let app_const f x = ret (fun _obj -> f x)
let app_var f n = ret (fun obj -> f (Array.unsafe_get obj n))
let app_var f n = ret (fun obj -> f (get_object_field obj n))
let app_env f e n =
ret (fun obj ->
f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
f (get_object_field (magic (get_object_field obj e) : obj) n))
let app_meth f n = ret (fun obj -> f (sendself obj n))
let app_const_const f x y = ret (fun _obj -> f x y)
let app_const_var f x n = ret (fun obj -> f x (Array.unsafe_get obj n))
let app_const_var f x n = ret (fun obj -> f x (get_object_field obj n))
let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)
let app_var_const f n x = ret (fun obj -> f (get_object_field obj n) x)
let app_meth_const f n x = ret (fun obj -> f (sendself obj n) x)
let app_const_env f x e n =
ret (fun obj ->
f x (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
f x (get_object_field (magic (get_object_field obj e) : obj) n))
let app_env_const f e n x =
ret (fun obj ->
f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x)
f (get_object_field (magic (get_object_field obj e) : obj) n) x)
let meth_app_const n x = ret (fun obj -> (sendself obj n : _ -> _) x)
let meth_app_var n m =
ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get obj m))
ret (fun obj -> (sendself obj n : _ -> _) (get_object_field obj m))
let meth_app_env n e m =
ret (fun obj -> (sendself obj n : _ -> _)
(Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m))
(get_object_field (magic (get_object_field obj e) : obj) m))
let meth_app_meth n m =
ret (fun obj -> (sendself obj n : _ -> _) (sendself obj m))
let send_const m x c =
ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c)
ret (fun obj -> sendcache x m (get_object_field obj 0) c)
let send_var m n c =
ret (fun obj ->
sendcache (Obj.magic (Array.unsafe_get obj n) : obj) m
(Array.unsafe_get obj 0) c)
sendcache (magic (get_object_field obj n) : obj) m
(get_object_field obj 0) c)
let send_env m e n c =
ret (fun obj ->
sendcache
(Obj.magic (Array.unsafe_get
(Obj.magic (Array.unsafe_get obj e) : obj) n) : obj)
m (Array.unsafe_get obj 0) c)
(magic (get_object_field
(magic (get_object_field obj e) : obj) n) : obj)
m (get_object_field obj 0) c)
let send_meth m n c =
ret (fun obj ->
sendcache (sendself obj n) m (Array.unsafe_get obj 0) c)
sendcache (sendself obj n) m (get_object_field obj 0) c)
let new_cache table =
let n = new_method table in
let n =
if n mod 2 = 0 || n > 2 + magic table.methods.(1) * 16 / Sys.word_size
then n else new_method table
in
table.methods.(n) <- Obj.magic 0;
table.methods.(n) <- magic 0;
n

type impl =
Expand Down