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