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