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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id: translobj.ml 10506 2010-06-04 19:16:52Z maranget $ *)
open Misc
open Primitive
open Asttypes
open Longident
open Lambda
(* Get oo primitives identifiers *)
let oo_prim name =
try
transl_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 string s = Lconst (Const_base (Const_string s))
let int n = Lconst (Const_base (Const_int n))
let prim_makearray =
{ prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false }
let transl_label_init expr =
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
reset_labels ();
expr
let transl_store_label_init glob size f arg =
method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
let expr = f arg in
let (size, expr) =
if !method_count = 0 then (size, expr) else
(size+1,
Lsequence(
Lprim(Psetfield(size, false),
[Lprim(Pgetglobal glob, []);
Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
expr))
in
(size, transl_label_init expr)
(* 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, id,
Lprim(Pmakeblock(0, Mutable),
[lambda_unit; lambda_unit; lambda_unit]),
lambda))
lambda !classes
in
wrapping := false;
top_env := Env.empty;
lambda
with exn ->
wrapping := false;
top_env := Env.empty;
raise exn
|
