Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 269 lines (214 sloc) 8.479 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module Array = Base.Array
20 module Lazy = Base.Lazy
21 module List = Base.List
22
23 (* alias *)
24 module Complex = Flat_Runtime.Complex
25 module Field = Flat_Runtime.Field
26 module Simple = Flat_Runtime.Simple
27 module VTable = Flat_Runtime.VTable
28
29 exception RuntimeError of string
30 (* -- *)
31
32 let rec compare_cpx c1 c2 =
33 let c1 = ( Obj.magic c1 : Complex.t ) in
34 let c2 = ( Obj.magic c2 : Complex.t ) in
35 let v1 = VTable.export (Complex.get_vtable c1) in
36 let v2 = VTable.export (Complex.get_vtable c2) in
37 let r = Array.compare Field.compare v1 v2 in
38 if r <> 0 then r else
39 let len = Array.length v1 in
40 let rec aux i =
41 if i >= len then 0 else
42 let r = compare
43 (Complex.get_value i c1)
44 (Complex.get_value i c2)
45 in
46 if r <> 0 then r else aux (succ i)
47 in aux 0
48
49 and compare r1 r2 =
50 let is_r1_cpx = Flat_Runtime.is_record (Obj.repr r1) in
51 if is_r1_cpx
52 then
53 let is_r2_cpx = Flat_Runtime.is_record (Obj.repr r2) in
54 if is_r2_cpx then compare_cpx r1 r2
55 else
56 Pervasives.compare r1 r2
57 else
58 Pervasives.compare r1 r2
59
60 type ty_record = Flat_Runtime.record
61
62 (* we can't write [type 'a ty_info = 'a info] otherwise we get
63 "inconsistent assumption blah blah blah i'm stupid" from ocaml. So let's
64 define the /exact same/ type as it is waiting for and use some magic *)
65 type 'a ty_info = 'a constraint 'a = [> ]
66
67 let empty_record = Flat_Runtime.empty
68
69 let has_lazy_data r =
70 Obj.obj (Complex.get_info r) <> None
71
72 let get_lazy_data_opt r = Obj.magic (Flat_Runtime.get_record_info r)
73
74 let embed_lazy_data r o =
75 Complex.update_info r (Obj.repr o)
76
77 let inject_lazy_data r o =
78 (* check with Louis: we may corrupt shared representation *)
79 if Flat_Runtime.is_simple r then () else
80 Complex.inject_info r (Obj.repr o)
81
82 let at_exit, do_exit, get_exit =
83 let at_exit_fun = ref (fun () -> ()) in
84 let once f = (* Because we don't want to execute twice with our do_exit and ocaml's at_exit *)
85 let don = ref false in fun x -> if !don then () else (don := true; f x) in
86 let at_exit_first = (* Because our at_exit keeps only one function (overriding previous ones) *)
87 let don = ref false in fun f ->
88 Pervasives.at_exit (fun () -> if !don then () else (don := true; f ()))
89 in
90 (fun f -> let f = once f in at_exit_fun := f; at_exit_first f),
91 (fun i -> !at_exit_fun (); exit i),
92 (fun () -> !at_exit_fun)
93
94 type field = Field.t
95
96 let compare_field = Field.compare
97
98 type field_index = int
99 type fields_indexes = VTable.t
100 type patterns_indexes = fields_indexes array
101 type 'a rt_record = 'a
102
103 external rt_to_ty_record : 'a rt_record -> ty_record = "%identity"
104 external ty_to_rt_record : ty_record -> 'a rt_record = "%identity"
105
106
107 let fields_indexes (x:field array) =
108 let x = Array.map Field.name x in
109 Array.fast_sort (Obj.magic Field.compare) x;
110 (VTable.register x: fields_indexes)
111
112 let field_index (x:fields_indexes) (f:field) =
113 let x = VTable.export x in
114 let rec aux i =
115 if x.(i) == f then (i:field_index)
116 else aux (i+1)
117 in aux 0
118
119 let dot_with_field_index rt_record (field_index:field_index) = Complex.get_value field_index (rt_to_ty_record rt_record)
120
121 (* rely on shared vtable hypothesis *)
122 let patterns_indexes (x:fields_indexes array) = x
123
124 let gt = -1
125 let lt = -2
126
127 let compare_structure pattern_index r1 r2 =
128 let r1 = rt_to_ty_record r1 in
129 let r2 = rt_to_ty_record r2 in
130 (* keep synchronised with opatop version until the comment in opatop indicate otherwise *)
131 (* rely on shared vtable hypothesis *)
132 let rec common_search v1 i=
133 if pattern_index.(i) == v1 then i
134 else if i!=0 then common_search v1 (i-1)
135 else
136 raise (RuntimeError "serverLib.compare_structure.common : pattern_index is not compatible with record")
137 in
138 let rec diff_search v1 v2 i=
139 let fields = pattern_index.(i) in
140 if fields == v1 then gt
141 else if fields == v2 then lt
142 else if i != 0 then
143 diff_search v1 v2 (i-1)
144 else
145 raise (RuntimeError "serverLib.compare_structure.diff : pattern_index is not compatible with record")
146 in
147 let v1 = Flat_Runtime.Complex.get_vtable r1 in
148 let v2 = Flat_Runtime.Complex.get_vtable r2 in
149 let n = Array.length pattern_index in
150 if v1 == v2 then common_search v1 (n-1)
151 else diff_search v1 v2 (n-1)
152
153 let fold_record folder record acc =
154 let record = (( Obj.magic record ) : ty_record) in
155 if Flat_Runtime.is_empty record then
156 acc
157 else
158 let vtable = VTable.export (Complex.get_vtable record) in
159 Array.fold_left_i
160 (fun acc field index ->
161 folder field (Complex.get_value index record) acc
162 ) acc vtable
163
164 let fold_2_record folder record1 record2 acc =
165 let record1 = (( Obj.magic record1 ) : ty_record) in
166 let record2 = (( Obj.magic record2 ) : ty_record) in
167 if Flat_Runtime.is_empty record1 then
168 acc
169 else
170 let vtable = VTable.export (Complex.get_vtable record1) in
171 Array.fold_left_i
172 (fun acc field index ->
173 folder field
174 (Complex.get_value index record1)
175 (Complex.get_value index record2)
176 acc
177 ) acc vtable
178
179 type record_constructor = (Field.t * Obj.t) list
180
181 let empty_record_constructor = []
182
183 let add_field rc field value = (field, Obj.repr(value))::rc
184
185 let make_record rc =
186 let cmp (f1,_) (f2,_) = Field.compare f1 f2 in
187 let sorted = List.sort cmp rc in
188 let sorted = List.uniq ~cmp sorted in
189 Obj.magic (Flat_Runtime.init_from_list sorted)
190
191 (* TODO: check who does use it *)
192 let make_simple_record s = Obj.magic (Simple.register (Obj.magic s))
193
194 let name_of_field = Field.name_of_field
195 let field_of_name = Field.field_of_name
196
197 let static_name_of_field = Field.name
198 let static_field_of_name = Field.register
199
200 (* Extension for explicit projection *)
201
202 let unsafe_dot record field = Flat_Runtime.dot field record
203 let dot record field = Flat_Runtime.dot_opt field record
204 let is_present record field = Option.is_some (Flat_Runtime.dot_opt field record)
205
206 (* Projections on constants *)
207
208 type ty_char = char
209 type ty_float = float (* youpi *)
210 type ty_int = int
211 type ty_null = unit
212 type ty_string = string
213
214 external wrap_char : char -> ty_char = "%identity"
215 external unwrap_char : ty_char -> char = "%identity"
216
217 external wrap_float : float -> ty_float = "%identity"
218 external unwrap_float : ty_float -> float = "%identity"
219
220 external wrap_int : int -> ty_int = "%identity"
221 external unwrap_int : ty_int -> int = "%identity"
222
223 external wrap_string : string -> ty_string = "%identity"
224 external unwrap_string : ty_string -> string = "%identity"
225
226 let void = empty_record
227
228 let null = ()
229
230 type ty_void = ty_record
231 type ty_bool = ty_record
232 type 'a ty_option = ty_record
233
234 let wrap_bool = Flat_Runtime.wrap_bool
235 let unwrap_bool = Flat_Runtime.unwrap_bool
236
237 let true_ = Flat_Runtime.true_
238 let false_ = Flat_Runtime.false_
239
240 let wrap_option = Flat_Runtime.wrap_option
241 let unwrap_option = Flat_Runtime.unwrap_option
242
243 let none = Flat_Runtime.none
244 let some = Flat_Runtime.some
245
246 (* support for marshaling *)
247
248 let deep_force_eval a = Obj.obj (Lazy.deep_force (Obj.repr a))
249
250 let rec sharing_refresh alpha =
251 if Flat_Runtime.is_record (Obj.repr alpha)
252 then (
253 let ma = (Obj.magic alpha : Flat_Runtime.flat_record) in
254 let contents_len = (Array.length ma) - Flat_Runtime.val_shift in
255 if contents_len = 0 then Obj.magic empty_record
256 else (
257 for i = Flat_Runtime.val_shift to pred (Array.length ma) do
258 Array.set ma i (Obj.magic (sharing_refresh (Obj.magic (Array.get ma i)))) ;
259 done ;
260 if contents_len = 1 && Array.get ma Flat_Runtime.val_shift == Flat_Runtime.shared_void
261 then Obj.magic (Simple.register (Array.get (Obj.magic (Array.get ma 0)) 0))
262 else
263 let () = Array.set ma 0 (Obj.repr (VTable.register (Obj.magic (Array.get ma 0)))) in
264 Obj.magic (Complex.init_from_evaluated ma)
265 )
266 )
267 else
268 alpha
Something went wrong with that request. Please try again.