flambda-backend: Fix camlinternalOO at -O3 with Flambda 2 (#132)

Author: mshinwell

stdlib/camlinternalOO.ml

@@ -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 ****)
 
@@ -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 ****)
@@ -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" *)
 
@@ -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
@@ -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 |];
@@ -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 }
 
@@ -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 =
@@ -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
@@ -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}
@@ -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 =