1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 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. *)
(* *)
(**************************************************************************)
open Misc
open Asttypes
open Longident
open Lambda
(* Get oo primitives identifiers *)
let oo_prim name =
try
transl_normal_path
(fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
with Not_found ->
fatal_error ("Primitive " ^ name ^ " not found.")
(* Share blocks *)
let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
let share c =
match c with
Const_block (_n, l) when l <> [] ->
begin try
Lvar (Hashtbl.find consts c)
with Not_found ->
let id = Ident.create "shared" in
Hashtbl.add consts c id;
Lvar id
end
| _ -> Lconst c
(* Collect labels *)
let cache_required = ref false
let method_cache = ref lambda_unit
let method_count = ref 0
let method_table = ref []
let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
let next_cache tag =
let n = !method_count in
incr method_count;
(tag, [!method_cache; Lconst(Const_base(Const_int n))])
let rec is_path = function
Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true
| Lprim (Pfield _, [lam], _) -> is_path lam
| Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) ->
is_path lam1 && is_path lam2
| _ -> false
let meth obj lab =
let tag = meth_tag lab in
if not (!cache_required && !Clflags.native_code) then (tag, []) else
if not (is_path obj) then next_cache tag else
try
let r = List.assoc obj !method_table in
try
(tag, List.assoc tag !r)
with Not_found ->
let p = next_cache tag in
r := p :: !r;
p
with Not_found ->
let p = next_cache tag in
method_table := (obj, ref [p]) :: !method_table;
p
let reset_labels () =
Hashtbl.clear consts;
method_count := 0;
method_table := []
(* Insert labels *)
let int n = Lconst (Const_base (Const_int n))
let prim_makearray =
Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true
(* Also use it for required globals *)
let transl_label_init_general f =
let expr, size = f () in
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr))
consts expr
in
(*let expr =
List.fold_right
(fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr))
(Env.get_required_globals ()) expr
in
Env.reset_required_globals ();*)
reset_labels ();
expr, size
let transl_label_init_flambda f =
assert(Config.flambda);
let method_cache_id = Ident.create "method_cache" in
method_cache := Lvar method_cache_id;
(* Calling f (usualy Translmod.transl_struct) requires the
method_cache variable to be initialised to be able to generate
method accesses. *)
let expr, size = f () in
let expr =
if !method_count = 0 then expr
else
Llet (Strict, Pgenval, method_cache_id,
Lprim (Pccall prim_makearray,
[int !method_count; int 0],
Location.none),
expr)
in
transl_label_init_general (fun () -> expr, size)
let transl_store_label_init glob size f arg =
assert(not Config.flambda);
assert(!Clflags.native_code);
method_cache := Lprim(Pfield size,
[Lprim(Pgetglobal glob, [], Location.none)],
Location.none);
let expr = f arg in
let (size, expr) =
if !method_count = 0 then (size, expr) else
(size+1,
Lsequence(
Lprim(Psetfield(size, Pointer, Root_initialization),
[Lprim(Pgetglobal glob, [], Location.none);
Lprim (Pccall prim_makearray,
[int !method_count; int 0],
Location.none)],
Location.none),
expr))
in
let lam, size = transl_label_init_general (fun () -> (expr, size)) in
size, lam
let transl_label_init f =
if !Clflags.native_code then
transl_label_init_flambda f
else
transl_label_init_general f
(* Share classes *)
let wrapping = ref false
let top_env = ref Env.empty
let classes = ref []
let method_ids = ref IdentSet.empty
let oo_add_class id =
classes := id :: !classes;
(!top_env, !cache_required)
let oo_wrap env req f x =
if !wrapping then
if !cache_required then f x else
try cache_required := true; let lam = f x in cache_required := false; lam
with exn -> cache_required := false; raise exn
else try
wrapping := true;
cache_required := req;
top_env := env;
classes := [];
method_ids := IdentSet.empty;
let lambda = f x in
let lambda =
List.fold_left
(fun lambda id ->
Llet(StrictOpt, Pgenval, id,
Lprim(Pmakeblock(0, Mutable, None),
[lambda_unit; lambda_unit; lambda_unit],
Location.none),
lambda))
lambda !classes
in
wrapping := false;
top_env := Env.empty;
lambda
with exn ->
wrapping := false;
top_env := Env.empty;
raise exn
let reset () =
Hashtbl.clear consts;
cache_required := false;
method_cache := lambda_unit;
method_count := 0;
method_table := [];
wrapping := false;
top_env := Env.empty;
classes := [];
method_ids := IdentSet.empty
|