Skip to content

HTTPS clone URL

Subversion checkout URL

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