2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
|
|
(* *)
|
|
|
|
(* Copyright 2004 Institut National de Recherche en Informatique et *)
|
|
|
|
(* en Automatique. *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
2004-08-12 05:57:00 -07:00
|
|
|
|
2019-02-12 03:12:59 -08:00
|
|
|
external make_forward : Obj.t -> Obj.t -> unit = "caml_obj_make_forward"
|
|
|
|
|
2004-08-12 05:57:00 -07:00
|
|
|
type shape =
|
|
|
|
| Function
|
|
|
|
| Lazy
|
|
|
|
| Class
|
|
|
|
| Module of shape array
|
2014-03-09 19:54:02 -07:00
|
|
|
| Value of Obj.t
|
2004-08-12 05:57:00 -07:00
|
|
|
|
2015-08-21 07:37:11 -07:00
|
|
|
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
|
|
|
|
|
2004-08-12 05:57:00 -07:00
|
|
|
let rec init_mod loc shape =
|
|
|
|
match shape with
|
|
|
|
| Function ->
|
2015-08-21 07:37:11 -07:00
|
|
|
(* 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 template;
|
|
|
|
closure
|
2004-08-12 05:57:00 -07:00
|
|
|
| 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)
|
2014-03-09 19:54:02 -07:00
|
|
|
| Value v ->
|
|
|
|
v
|
2004-08-12 05:57:00 -07:00
|
|
|
|
|
|
|
let rec update_mod shape o n =
|
|
|
|
match shape with
|
|
|
|
| Function ->
|
2020-04-24 08:49:03 -07:00
|
|
|
(* 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))
|
2019-03-01 09:29:29 -08:00
|
|
|
then begin overwrite o n end
|
2005-01-04 07:39:10 -08:00
|
|
|
else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
|
2004-08-12 05:57:00 -07:00
|
|
|
| Lazy ->
|
2008-01-11 08:13:18 -08:00
|
|
|
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 *)
|
2019-02-12 03:12:59 -08:00
|
|
|
make_forward o (Obj.field n 0)
|
2008-01-11 08:13:18 -08:00
|
|
|
end else begin
|
|
|
|
(* forwarding pointer was shortcut by GC *)
|
2019-02-12 03:12:59 -08:00
|
|
|
make_forward o n
|
2008-01-11 08:13:18 -08:00
|
|
|
end
|
2004-08-12 05:57:00 -07:00
|
|
|
| Class ->
|
|
|
|
assert (Obj.tag n = 0 && Obj.size n = 4);
|
|
|
|
overwrite o n
|
|
|
|
| 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)
|
2005-10-25 11:34:07 -07:00
|
|
|
done
|
2016-03-09 14:20:22 -08:00
|
|
|
| Value _ -> () (* the value is already there *)
|