Permalink
Browse files

[feature] closure serialisation: adding the runtime to implement clos…

…ure serialisation
  • Loading branch information...
OpaOnWindowsNow committed Aug 12, 2011
1 parent 936d60a commit 91768108fc2ad118d3db23be22829939f9603779
View
@@ -795,12 +795,11 @@ type doctype_access_directive =
add information around an apply or a lifted lambda
*)
type lambda_lifting_directive = [
- | `partial_apply of int option * bool (* original arity of the function, guaranteed to be filled by lambda lifting,
- None means 'undisclosed information' :)
- the boolean indicates that this is a creation of serializable closure
- (so the partial apply may have extra type arguments) *)
+ | `partial_apply of int option * bool (* original arity of the function, guaranteed to be filled by lambda lifting, None means 'undisclosed information' :)
+ the boolean indicates that this partial apply has extra type arguments *)
| `full_apply of int (* size of the env *)
- | `lifted_lambda of int * Ident.t option (* size of the env and the toplevel name of the declaration from where it was lifted
+ | `lifted_lambda of int * Ident.t list (* size of the env and the toplevel name of the hierarchy of functions
+ from which it was lifted (innermost function first)the toplevel name of the declaration from where it was lifted
* (meaningful between lambda lifting and explicit instantiation, because
* ei adds @lifted_lambda on declarations that are not really lifted, so
* what would the value be?) *)
View
@@ -80,7 +80,9 @@ function get_local_unsafe(str) {
##register create_anyarray : 'impl, int, 'ident -> Closure.t
##args(f,n,identifier)
{
- return function() { return f.call(null,arguments) }
+ var new_closure = function() { return f.call(null,arguments) };
+ new_closure.identifier = identifier;
+ return new_closure;
}
##register [cps-bypass] create_anyarray_cps \ `create_anyarray_cps` : 'impl, int, 'ident, continuation(Closure.t) -> void
@@ -115,13 +117,14 @@ function args_apply(closure,args) {
}
function get_closure_name(closure) {
- return closure.toString().match(/function *([^(]*)/)[1]
+ if ('identifier' in closure) return closure.identifier; // opa
+ if ('name' in closure) return closure.name; // chrome
+ return closure.toString().match(/function *([^(]*)/)[1]; // all
}
##register get_identifier : 'c -> option('a)
##args(closure)
{
- if ('identifier' in closure) return closure.identifier;
var name = get_closure_name(closure);
return (global[name] == closure) ? js_some(make_onefield_record(static_field_of_name("closure_name"),name)) : js_none;
}
@@ -130,6 +133,41 @@ function get_closure_name(closure) {
{
closure.identifier = js_some(identifier);
}
+/**
+ * Part of JsInterface (funaction)
+**/
+function _env_apply_with_ty(closure,args,ty_args)
+{
+ // if env is empty, we should not apply, since it would triger the function computation
+ // we only want to apply env, not to do any computation
+ // in zero arity no extra lambda is waiting this empty env
+ if( args.length ==0 ){
+ // closure.opa_args = [];
+ // closure.opa_ty_args = [];
+ return closure;
+ } else {
+ var new_closure = closure.apply(null,args); // breaks tail-rec (I know it is not optimised in streets browsers but it will be some day)
+ new_closure.identifier = get_closure_name(closure);
+ new_closure.opa_args = args;
+ new_closure.opa_ty_args = ty_args;
+ return new_closure;
+ }
+}
+##register env_apply_with_ty \ `_env_apply_with_ty` : Closure.t, Closure.args,Closure.args -> Closure.t
+
+##register get_args : Closure.t -> Closure.args
+##args(closure)
+{
+ var res = closure.opa_args;
+ return (res?res:[]);
+}
+
+##register get_ty_args : Closure.t -> Closure.args
+##args(closure)
+{
+ var res = closure.opa_ty_args;
+ return (res?res:[]);
+}
##register is_empty : 'b -> bool
##args(closure)
@@ -30,9 +30,13 @@
##register create_no_function \ `QmlClosureRuntime.create_no_function` : int, 'ident -> Closure.t
##register [opacapi] define_function \ `QmlClosureRuntime.define_function` : Closure.t, 'impl -> void
##register apply \ `QmlClosureRuntime.args_apply` : Closure.t, Closure.args -> 'a
+##register env_apply_with_ty \ `QmlClosureRuntime.env_apply_with_ty` : Closure.t, Closure.args,Closure.args -> Closure.t
+
##register is_empty \ `QmlClosureRuntime.is_empty` : 'closure -> bool
##register get_identifier \ `QmlClosureRuntime.get_identifier` : 'closure -> option('a)
##register set_identifier \ `QmlClosureRuntime.set_identifier` : Closure.t, 'a -> void
+##register get_args \ `QmlClosureRuntime.get_args` : Closure.t -> Closure.args
+##register get_ty_args \ `QmlClosureRuntime.get_tyargs` : Closure.t -> Closure.args
##register export \ `QmlClosureRuntime.export` : Closure.t -> 'a
##register import \ `QmlClosureRuntime.import` : 'a, int -> Closure.t
@@ -32,6 +32,7 @@ module AnyArray : sig
(* beware : values of this type are created
* with Obj.magic in the generated code *)
type t = Obj.t array
+ val empty : t
val create : int -> t
val set : t -> int -> 'a -> unit
val get : t -> int -> 'a
@@ -43,6 +44,7 @@ module AnyArray : sig
end =
struct
type t = Obj.t array
+ let empty = [||]
let create n = Array.make n (Obj.repr 0)
let set a i x = a.(i) <- Obj.repr x
let get a i = Obj.obj a.(i)
@@ -127,13 +129,17 @@ let applied _ = assert false
let unapplied _ = assert false
let import _ _ = assert false
let export _ = assert false
+let get_args _ = assert (Printf.printf "RT:qmlClosureRuntime:Fake.get_args: use opa closures !!");false
+let get_tyargs _ = assert (Printf.printf "RT:qmlClosureRuntime:Fake.get_tyargs: use opa closures !!");false
#<Else>
(*-----------------------*)
(*----- typedefs --------*)
(*-----------------------*)
-
+type t_extra = {
+ ty_args : AnyArray.t; (* a type for each arg *)
+}
type t = { (* the type of closure must be monomorphic
* or else generalization problem will be really troublesome *)
arity : int;
@@ -143,6 +149,7 @@ type t = { (* the type of closure must be monomorphic
* without the code pointer, and then we fill it
* this field will be set either once,
* or one time with a dummy value and the second time with the real value *)
+ extra : t_extra (* all basic closure extension are regroupped here to keep a small standard record for t *)
}
(*--------------------------------------*)
@@ -192,16 +199,22 @@ let show_gen ?(rec_=false) closure =
let { identifier=identifier
; arity=arity
; args=args
- ; func=_func } = assert_ closure in
+ ; func=_func
+ ; extra=extra } = assert_ closure in
let string =
- Printf.sprintf "{identifier=%s; arity=%d; args=#%d[|%s|]; func=_}"
+ Printf.sprintf "{identifier=%s; arity=%d; args=#%d[|%s|]; t_extra=#%d[|%s|]; func=_}"
(match identifier with
| None -> "None"
| Some id -> DebugPrint.print id)
arity
(Array.length args)
(if rec_ then
(Base.String.concat_map ";" DebugPrint.print (Array.to_list args))
+ else
+ "...")
+ (Array.length extra.ty_args)
+ (if rec_ then
+ (Base.String.concat_map ";" DebugPrint.print (Array.to_list extra.ty_args))
else
"...") in
Some string
@@ -228,13 +241,15 @@ let show_ml_closure_field f =
(* this function will be used to fill the field 'func' for closures defined in two steps *)
let dummy_function _ = assert false
+let empty_t_extra = { ty_args= AnyArray.empty }
let create_raw f n identifier =
let closure =
{ func = Obj.repr f;
arity = n;
args = AnyArray.create 0;
identifier = identifier;
+ extra = empty_t_extra
} in
#<If> assert_ closure (* this checks that the checking
* function is up to date
@@ -283,29 +298,32 @@ let define_function closure fun_ =
(*-----------------------------*)
(*-- application of closures --*)
(*-----------------------------*)
+let array1 v = (Obj.magic {tuple1 = v} : Obj.t array)
+let array2 v1 v2 = (Obj.magic (v1, v2) : Obj.t array)
+
+let check_env_apply clos args =
+ assert (check clos);
+ assert (Array.length clos.args = 0);
+ assert (clos.arity >= Array.length args)
let env_apply clos args =
#<If>
- assert (check clos);
- assert (Array.length clos.args = 0);
- assert (clos.arity >= Array.length args);
+ check_env_apply clos args
#<End>;
{clos with args = args}
-let env_apply1 clos arg1 =
+let env_apply_with_ty clos args ty_args =
#<If>
- assert (check clos);
- assert (Array.length clos.args = 0);
- assert (clos.arity >= 1);
+ check_env_apply clos args
#<End>;
- env_apply clos (Obj.magic {tuple1 = arg1} : Obj.t array)
-let env_apply2 clos arg1 arg2 =
- #<If>
- assert (check clos);
- assert (Array.length clos.args = 0);
- assert (clos.arity >= 2);
- #<End>;
- env_apply clos (Obj.magic (arg1, arg2) : Obj.t array)
+ {clos with args = args; extra = {(*clos.extra with *)ty_args = ty_args} }
+
+
+let env_apply1 clos arg1 = env_apply clos (array1 arg1)
+let env_apply2 clos arg1 arg2 = env_apply clos (array2 arg1 arg2)
+
+let env_apply1_with_ty clos arg1 ty_arg1= env_apply_with_ty clos (array1 arg1) (array1 ty_arg1)
+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)
let args_apply clos args =
#<If>
@@ -407,6 +425,9 @@ let get_identifier obj =
let set_identifier closure value =
closure.identifier <- Some (Obj.repr value)
+let get_args t = t.args
+let get_tyargs t = t.extra.ty_args
+
(*--------------------------*)
(*------- bsl proj ---------*)
(*--------------------------*)
@@ -36,6 +36,7 @@ module AnyArray : sig
end
(**/**)
+type t_extra
#<Ifstatic:CPS_WITH_ML_CLOSURE .*>
type t
#<Else>
@@ -45,6 +46,7 @@ type t = {
mutable identifier : Obj.t option;
args: AnyArray.t;
mutable func: Obj.t;
+ extra : t_extra;
}
#<End>
(**/**)
@@ -77,11 +79,19 @@ val env_apply : t -> AnyArray.t -> t
val env_apply1 : t -> 'arg1 -> t
val env_apply2 : t -> 'arg1 -> 'arg2 -> t
+(** partial application of a closure with type information about pushed args *)
+val env_apply_with_ty : t -> AnyArray.t -> AnyArray.t -> t
+val env_apply1_with_ty : t -> 'arg1 -> 'ty_arg1 -> t
+val env_apply2_with_ty : t -> 'arg1 -> 'arg2 -> 'ty_arg1 -> 'ty_arg1 -> t
+
+
(** {6 Interface for serialization} *)
val is_empty : 'closure -> bool
val get_identifier : 'closure -> 'ident option
val set_identifier : t -> 'ident -> unit
+val get_args : t -> AnyArray.t
+val get_tyargs : t -> AnyArray.t
(** {6 Interface for bsl projections} *)
@@ -203,6 +203,8 @@ let expr env expr =
env_expr_error env expr
"Internal error: At this stage, all first-class paths should have been compiled."
+ | Q.Directive (_, `unsafe_cast, [e], _) -> aux e
+
| Q.Directive (_, #assume_traverse, [e], _) ->
aux e
View
@@ -286,7 +286,12 @@ let compile_expr_to_expr env private_env expr =
| Q.Apply (_, f, args) ->
aux_apply ~pure:false private_env f args
- | Q.Directive (_, `partial_apply (Some _, true), e :: _, _) (* TODO *)
+ | Q.Directive (_, `partial_apply (Some _, true), e :: ty_args, _) ->
+ begin match e with
+ | Q.Apply (_, f, args) ->
+ aux_partial_apply_with_ty ~pure:true private_env f args ty_args
+ | _ -> assert false
+ end
| Q.Directive (_, `partial_apply ((Some _ | None), false), [e], _) ->
begin match e with
@@ -518,10 +523,17 @@ let compile_expr_to_expr env private_env expr =
and aux_apply private_env ~pure f args =
let private_env, f = aux private_env f in
let private_env, args = List.fold_left_map aux private_env args in
- private_env, JsCons.Expr.call ~pure f args in
+ private_env, JsCons.Expr.call ~pure f args
- aux private_env (simplify expr)
+ and aux_partial_apply_with_ty private_env ~pure f args ty_args =
+ let private_env, f = aux private_env f in
+ let private_env, args = List.fold_left_map aux private_env args in
+ let private_env, ty_args = List.fold_left_map aux private_env ty_args in
+ private_env, JsCons.Expr.call ~pure Imp_Common.ClientLib.
+ env_apply_with_ty [f;(JsCons.Expr.array args);(JsCons.Expr.array ty_args)]
+ in
+ aux private_env (simplify expr)
let add_bindings_statement bindings statement =
match bindings with
View
@@ -52,6 +52,8 @@ struct
let dot_false = !! "dot_false"
let dot_bool b = if b then dot_true else dot_false
+ let env_apply_with_ty = !! "_env_apply_with_ty"
+
let error = !! "error"
let extend_record = !! "extend_record"
View
@@ -37,6 +37,8 @@ sig
val dot_false : JsAst.expr
val dot_true : JsAst.expr
+ val env_apply_with_ty : JsAst.expr
+
val error : JsAst.expr
val extend_record : JsAst.expr
Oops, something went wrong.

0 comments on commit 9176810

Please sign in to comment.