Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 430 lines (386 sloc) 15.013 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 #<Debugvar:CLOSURE_DEBUG>
19
20 (*-----------------------------*)
21 (*--- a few datastructures ---*)
22 (*-----------------------------*)
23
24 type 'a tuple1 = {tuple1 : 'a}
25 (* the fake type that i use to replace the missing 1-uple
26 * in the syntax *)
27
28 (* this module is meant to allow heteregeneous arrays
29 * and carefully avoids troubles with ocaml optimization
30 * of float arrays *)
31 module AnyArray : sig
32 (* beware : values of this type are created
33 * with Obj.magic in the generated code *)
34 type t = Obj.t array
35 val create : int -> t
36 val set : t -> int -> 'a -> unit
37 val get : t -> int -> 'a
38 val length : t -> int
39 val append_sub : t -> int -> t -> t
40 val sub : t -> int -> t
41 val sub2 : t -> int -> int -> t
42 val append : t -> t -> t
43 end =
44 struct
45 type t = Obj.t array
46 let create n = Array.make n (Obj.repr 0)
47 let set a i x = a.(i) <- Obj.repr x
48 let get a i = Obj.obj a.(i)
49 let length = Array.length
50 let append_sub a i b =
51 let n = Array.length a
52 and m = Array.length b in
53 let c = create (n+m-i) in
54 Array.blit a 0 c 0 n;
55 Array.blit b i c n (m-i);
56 c
57 let sub a n =
58 let b = create n in
59 Array.blit a 0 b 0 n;
60 b
61 let append a b = append_sub a 0 b
62 let sub2 a i j =
63 let b = create (j-i) in
64 Array.blit a i b 0 (j-i);
65 b
66 end
67
68 (* FIXME: could we avoid the overhead of transforming lists in arrays ? *)
69 (* heterogenous lists *)
70 module AnyList : sig
71 type t
72 val empty : t
73 val is_empty : t -> bool
74 val push : t -> 'a -> t (* add at the end of the list *)
75 val length : t -> int
76 val to_anyarray : t -> AnyArray.t
77 end =
78 struct
79 (* perhaps it is less efficient to keep the length rather than computing it in to_any_array *)
80 type t = Obj.t list * int (* the list is reversed *)
81 let empty = ([],0)
82 let is_empty = function
83 | (_,0) -> true
84 | _ -> false
85 let push (l,n) elt = (Obj.repr elt :: l, n+1)
86 let length = snd
87 let to_anyarray (l,n) =
88 let array = AnyArray.create n in
89 Base.List.iteri (fun x i -> AnyArray.set array (n-1-i) x) l;
90 array
91 end
92
93 #<Ifstatic:CPS_WITH_ML_CLOSURE .*>
94
95 (*------------------------*)
96 (*----- fake implem ------*)
97 (*------------------------*)
98 (* this is meant to allow to run cps without the performance penalty of mixing
99 * qml closures and ml closures *)
100 type t = Obj.t
101 let is_closure _f =
102 let tag = Obj.tag (Obj.repr _f) in tag = Obj.closure_tag || tag = Obj.infix_tag
103
104 let check _ = assert false
105 let assert_ _ = assert false
106 let show _ = assert false
107 let apply _f _ = assert false
108 let apply1 f x =
109 assert( if not(is_closure f) then (
110 Printf.printf "RT:qmlClosureRuntime:FakeApply1: expected a closure but TAG=%d" (Obj.tag (Obj.repr f)); false
111 ) else true);
112 (Obj.obj f : _ -> _) x
113 let apply2 f x y =
114 assert( if not(is_closure f) then (
115 Printf.printf "RT:qmlClosureRuntime:FakeApply2: expected a closure but TAG=%d" (Obj.tag (Obj.repr f));false
116 ) else true);
117 (Obj.obj f : _ -> _ -> _) x y
118 let create _ _ _ = assert false
119 let create_no_ident _ _ = assert false
120 let create_no_ident1 = Obj.repr
121 let create_no_ident2 = Obj.repr
122 let create_no_function _ _ = assert false
123 let define_function _ _ = assert false
124 let is_empty _ = assert false
125 let get_identifier _ = assert false
126 let applied _ = assert false
127 let unapplied _ = assert false
128 let import _ _ = assert false
129 let export _ = assert false
130
131 #<Else>
132
133 (*-----------------------*)
134 (*----- typedefs --------*)
135 (*-----------------------*)
136
137 type t = { (* the type of closure must be monomorphic
138 * or else generalization problem will be really troublesome *)
139 arity : int;
140 mutable identifier : Obj.t option; (* the name of the function (a backend record) if any *)
141 args: AnyArray.t; (* the previously applied arguments *)
142 mutable func: Obj.t; (* the 'code pointer', it is mutable because we sometimes create the closure
143 * without the code pointer, and then we fill it
144 * this field will be set either once,
145 * or one time with a dummy value and the second time with the real value *)
146 }
147
148 (*--------------------------------------*)
149 (*------- printing/runtime check -------*)
150 (*--------------------------------------*)
151
152 (* check that a given object has a runtime representation compatible with a closure *)
153 let check_closure_arity t =
154 Obj.is_int (Obj.field t 0) && (Obj.obj t : int) > 0
155 let check_closure_identifier t =
156 let option = (Obj.field t 1) in
157 if Obj.is_block option then (
158 Obj.size option = 1 &&
159 let obj_t = (Obj.field option 0) in
160 (* QMLFLAT SPECIFIC BEGIN *)
161 Obj.is_block obj_t &&
162 Obj.tag obj_t = 0 &&
163 (let ss = Obj.size obj_t in ss = 3 || ss = 4) &&
164 Obj.tag (Obj.field obj_t 0) = 245 && (* vtable -> array *)
165 (let ss = Obj.size (Obj.field obj_t 0) in ss = 1 || ss = 2) && (* vtable -> array of size 1 or 2 *)
166 DebugPrint.option (Obj.field obj_t 1) &&
167 Obj.tag (Obj.field obj_t 2) = Obj.string_tag
168 (* QMLFLAT SPECIFIC END *)
169 ) else
170 option = Obj.repr None
171 let check_closure_args t =
172 Obj.is_block (Obj.field t 2) && (Obj.tag (Obj.field t 2) = 0 || Obj.tag (Obj.field t 2) = 245)
173 let check_closure_func t =
174 let tag = Obj.tag (Obj.field t 3) in
175 tag = Obj.closure_tag || tag = Obj.infix_tag (* infix happens in recursive functions *)
176
177 let check : 'a -> bool =
178 fun t' ->
179 let t = Obj.repr t' in
180 Obj.is_block t &&
181 Obj.tag t = 0 &&
182 Obj.size t = 5 &&
183 check_closure_arity t &&
184 check_closure_identifier t &&
185 check_closure_args t &&
186 check_closure_func t
187 let assert_ : 'a -> t = fun t -> assert (check t); (Obj.magic t : t)
188
189 let show_gen ?(rec_=false) closure =
190 if check closure then
191 (* checking that we really have a closure before pattern matching it *)
192 let { identifier=identifier
193 ; arity=arity
194 ; args=args
195 ; func=_func } = assert_ closure in
196 let string =
197 Printf.sprintf "{identifier=%s; arity=%d; args=#%d[|%s|]; func=_}"
198 (match identifier with
199 | None -> "None"
200 | Some id -> DebugPrint.print id)
201 arity
202 (Array.length args)
203 (if rec_ then
204 (Base.String.concat_map ";" DebugPrint.print (Array.to_list args))
205 else
206 "...") in
207 Some string
208 else
209 None
210 let () = DebugPrint.register {DebugPrint.f = (fun closure -> show_gen ~rec_:true closure)}
211
212 let show closure =
213 match show_gen ~rec_:true closure with
214 | None -> Base.failwithf "Expected a closure but got %s" (DebugPrint.print closure)
215 | Some s -> s
216
217 let show_ml_closure_field f =
218 let f' = Obj.repr f in
219 assert (Obj.tag f' = Obj.closure_tag);
220 for i = 0 to Obj.size f' - 1 do
221 Printf.printf "field %d: %s
222 " i (Base.Obj.dump (Obj.field f' i));
223 done
224
225 (*------------------------------------*)
226 (*-------- allocation of closures ----*)
227 (*------------------------------------*)
228
229 (* this function will be used to fill the field 'func' for closures defined in two steps *)
230 let dummy_function _ = assert false
231
232 let create_raw f n identifier =
233 let closure =
234 { func = Obj.repr f;
235 arity = n;
236 args = AnyArray.create 0;
237 identifier = identifier;
238 } in
239 #<If> assert_ closure (* this checks that the checking
240 * function is up to date
241 * (and that the identifier is valid) *)
242 #<Else> closure
243 #<End>
244
245 let create f n identifier = create_raw f n (Some (Obj.repr identifier))
246
247
248 (* convert a function that expects a single argument that is an anyarray
249 * into a function that expects the arguments one by one *)
250 let anyarray_fun_to_fun arity fun_ =
251 let remaining = arity in
252 if remaining = 0 then
253 fun () -> (Obj.magic fun_ : _ -> _) [||]
254 else
255 let rec aux left acc =
256 if left = 1 then
257 acc
258 else
259 let acc = fun prev arg -> acc (AnyList.push prev arg) in
260 aux (left - 1) (Obj.magic acc) in
261 let acc =
262 fun prev arg ->
263 let anylist = AnyList.push prev arg in
264 (Obj.magic fun_ : _ -> _) (AnyList.to_anyarray anylist) in
265 let acc = aux remaining acc in
266 acc AnyList.empty
267
268 let create_anyarray f n identifier =
269 (* closures created by that functions are assumed not to take environments *)
270 let f = anyarray_fun_to_fun n f in
271 create_raw f n (Some (Obj.repr identifier))
272
273 let create_no_ident f n = create_raw f n None
274 let create_no_ident1 f = create_no_ident f 1
275 let create_no_ident2 f = create_no_ident f 2
276
277 let create_no_function n identifier = create dummy_function n identifier
278 let define_function closure fun_ =
279 assert (closure.func == Obj.repr dummy_function); (* making sure that we can't update the closure twice *)
280 closure.func <- Obj.repr fun_
281
282
283 (*-----------------------------*)
284 (*-- application of closures --*)
285 (*-----------------------------*)
286
287 let env_apply clos args =
288 #<If>
289 assert (check clos);
290 assert (Array.length clos.args = 0);
291 assert (clos.arity >= Array.length args);
292 #<End>;
293 {clos with args = args}
294
295 let env_apply1 clos arg1 =
296 #<If>
297 assert (check clos);
298 assert (Array.length clos.args = 0);
299 assert (clos.arity >= 1);
300 #<End>;
301 env_apply clos (Obj.magic {tuple1 = arg1} : Obj.t array)
302 let env_apply2 clos arg1 arg2 =
303 #<If>
304 assert (check clos);
305 assert (Array.length clos.args = 0);
306 assert (clos.arity >= 2);
307 #<End>;
308 env_apply clos (Obj.magic (arg1, arg2) : Obj.t array)
309
310 let args_apply clos args =
311 #<If>
312 assert (check clos);
313 if not (clos.arity = Array.length clos.args + Array.length args) then (
314 Printf.printf "CLOSURE: %s\nARGS: %s\n%!" (DebugPrint.print clos) (DebugPrint.print args);
315 assert false
316 )
317 #<End>;
318 let f = ref (Obj.obj clos.func) in
319 let env = clos.args in
320 if Array.length args = 0 then (
321 if Array.length env = 0 then
322 !f ()
323 else (
324 let n = Array.length env in
325 for k = 0 to n - 2 do
326 f := Obj.magic (!f (AnyArray.get env k))
327 done;
328 (Obj.magic !f : _ -> _) (AnyArray.get env (n-1)) (* tail call *)
329 )
330 ) else (
331 for k = 0 to Array.length env - 1 do
332 f := Obj.magic (!f (AnyArray.get env k))
333 done;
334 let n = Array.length args in
335 for k = 0 to n - 2 do
336 f := Obj.magic (!f (AnyArray.get args k))
337 done;
338 (Obj.magic !f : _ -> _) (AnyArray.get args (n-1)) (* tail call *)
339 )
340
341 (* specialized, more efficient version of the function above
342 * these functions are generated by qmlClosure, but some of these are hard written here
343 * so that we can call them (for efficiency) *)
344 let args_apply1 closure a0 =
345 #<If>
346 assert (check closure);
347 if not (closure.arity = Array.length closure.args + 1) then (
348 Printf.printf "CLOSURE: %s\nARG: %s\n%!" (DebugPrint.print closure) (DebugPrint.print a0);
349 assert false
350 )
351 #<End>;
352 match closure.args with
353 | [||] -> (Obj.magic closure.func : _ -> _) a0
354 | [|e0|] -> (Obj.magic closure.func : _ -> _ -> _) e0 a0
355 | [|e0; e1|] -> (Obj.magic closure.func : _ -> _ -> _ -> _) e0 e1 a0
356 | [|e0; e1; e2|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _) e0 e1 e2 a0
357 | [|e0; e1; e2; e3|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 a0
358 | [|e0; e1; e2; e3; e4|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 a0
359 | [|e0; e1; e2; e3; e4; e5|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 e5 a0
360 | [|e0; e1; e2; e3; e4; e5; e6|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 e5 e6 a0
361 | [|e0; e1; e2; e3; e4; e5; e6; e7|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 e5 e6 e7 a0
362 | [|e0; e1; e2; e3; e4; e5; e6; e7; e8|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 e5 e6 e7 e8 a0
363 | [|e0; e1; e2; e3; e4; e5; e6; e7; e8; e9|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 a0
364 | _env ->
365 #<If>Printf.printf "QmlClosureRuntime: falling through apply1: env:%d arity:%d\n%!" (Array.length _env) closure.arity#<End>;
366 args_apply closure (Obj.magic {tuple1=a0})
367
368 let args_apply2 closure a0 a1 =
369 #<If>
370 assert (check closure);
371 assert (closure.arity = Array.length closure.args + 2);
372 #<End>;
373 match closure.args with
374 | [||] -> (Obj.magic closure.func : _ -> _ -> _) a0 a1
375 | [|e0|] -> (Obj.magic closure.func : _ -> _ -> _ -> _) e0 a0 a1
376 | [|e0; e1|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _) e0 e1 a0 a1
377 | [|e0; e1; e2|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 a0 a1
378 | [|e0; e1; e2; e3|] -> (Obj.magic closure.func : _ -> _ -> _ -> _ -> _ -> _ -> _) e0 e1 e2 e3 a0 a1
379 | _env ->
380 #<If>Printf.printf "QmlClosureRuntime: falling through apply2: env:%d arity:%d\n%!" (Array.length _env) closure.arity#<End>;
381 args_apply closure (Obj.magic (a0,a1))
382
383 (*---------------------------*)
384 (*-- api for serialization --*)
385 (*---------------------------*)
386
387 (*
388 * A closure is empty when it has not been applied any arguments
389 *(which includes environment 'arguments')
390 * Same remark as for get_identifier: you need to provide a closure,
391 * but it can't be enforced in the type
392 *)
393 let is_empty obj =
394 let closure = #<If>assert_ obj#<Else>(Obj.magic obj : t)#<End> in
395 Array.length closure.args = 0
396
397 (*
398 * [get_identifier closure] really takes a closure in spite of its type
399 * but at the point where you insert the bypass, the function is not yet
400 * a closure and so the bypass would be unusable
401 * Saying (_ -> _) -> _ option wouldn't work since closures would end up projecting the function
402 *)
403 let get_identifier obj =
404 let closure = #<If>assert_ obj#<Else>(Obj.magic obj : t)#<End> in
405 Obj.magic closure.identifier
406
407 let set_identifier closure value =
408 closure.identifier <- Some (Obj.repr value)
409
410 (*--------------------------*)
411 (*------- bsl proj ---------*)
412 (*--------------------------*)
413
414 let import : 'a -> int -> t = create_no_ident
415 let export : t -> 'a = fun closure ->
416 let env = closure.args in
417 let env_size = Array.length env in
418 if closure.arity = env_size then
419 (* exporting a [-> 'a] *)
420 Obj.magic (fun () -> args_apply closure [||])
421 else (
422 let f = ref (Obj.magic closure.func) in
423 for i = 0 to env_size - 1 do
424 f := (Obj.magic !f : _ -> _) (AnyArray.get env i)
425 done;
426 !f
427 )
428
429 #<End>
Something went wrong with that request. Please try again.