|
|
@@ -46,1082 +46,1082 @@ let name = "closures_to_class"
|
|
|
let priority = solve_deps name [ DAfter DynamicFieldAccess.priority ]
|
|
|
|
|
|
type closures_ctx = {
|
|
|
- func_class : tclass;
|
|
|
-
|
|
|
- (*
|
|
|
- this is what will actually turn the function into class field.
|
|
|
- The standard implementation by default will already take care of creating the class, and setting the captured variables.
|
|
|
-
|
|
|
- It will also return the super arguments to be called
|
|
|
- *)
|
|
|
- closure_to_classfield : tfunc->t->pos->tclass_field * (texpr list);
|
|
|
-
|
|
|
- (*
|
|
|
- when a dynamic function call is made, we need to convert it as if it were calling the dynamic function interface.
|
|
|
-
|
|
|
- TCall expr -> new TCall expr
|
|
|
- *)
|
|
|
- dynamic_fun_call : texpr->texpr;
|
|
|
-
|
|
|
- (*
|
|
|
- Provide a toolchain so we can easily create classes that extend Function and add more functionality on top of it.
|
|
|
-
|
|
|
- arguments:
|
|
|
- tclass -> subject (so we know the type of this)
|
|
|
- ( int -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) )
|
|
|
- int -> current arity of the function whose member will be mapped; -1 for dynamic function. It is guaranteed that dynamic function will be called last
|
|
|
- t -> the return type of the function
|
|
|
- (int->t->tconstant option->texpr) -> api to get exprs that unwrap arguments correctly
|
|
|
- int -> argument wanted to unwrap
|
|
|
- t -> solicited type
|
|
|
- tconstant option -> map to this default value if null
|
|
|
- returns a texpr that tells how the default
|
|
|
- should return a list with additional arguments (only works if is_function_base = true)
|
|
|
- and the underlying function expression
|
|
|
- *)
|
|
|
- map_base_classfields : tclass->( int -> t -> (tvar list) -> (int->t->tconstant option->texpr) -> texpr )->tclass_field list;
|
|
|
+ func_class : tclass;
|
|
|
+
|
|
|
+ (*
|
|
|
+ this is what will actually turn the function into class field.
|
|
|
+ The standard implementation by default will already take care of creating the class, and setting the captured variables.
|
|
|
+
|
|
|
+ It will also return the super arguments to be called
|
|
|
+ *)
|
|
|
+ closure_to_classfield : tfunc->t->pos->tclass_field * (texpr list);
|
|
|
+
|
|
|
+ (*
|
|
|
+ when a dynamic function call is made, we need to convert it as if it were calling the dynamic function interface.
|
|
|
+
|
|
|
+ TCall expr -> new TCall expr
|
|
|
+ *)
|
|
|
+ dynamic_fun_call : texpr->texpr;
|
|
|
+
|
|
|
+ (*
|
|
|
+ Provide a toolchain so we can easily create classes that extend Function and add more functionality on top of it.
|
|
|
+
|
|
|
+ arguments:
|
|
|
+ tclass -> subject (so we know the type of this)
|
|
|
+ ( int -> (int->t->tconstant option->texpr) -> ( (tvar * tconstant option) list * texpr) )
|
|
|
+ int -> current arity of the function whose member will be mapped; -1 for dynamic function. It is guaranteed that dynamic function will be called last
|
|
|
+ t -> the return type of the function
|
|
|
+ (int->t->tconstant option->texpr) -> api to get exprs that unwrap arguments correctly
|
|
|
+ int -> argument wanted to unwrap
|
|
|
+ t -> solicited type
|
|
|
+ tconstant option -> map to this default value if null
|
|
|
+ returns a texpr that tells how the default
|
|
|
+ should return a list with additional arguments (only works if is_function_base = true)
|
|
|
+ and the underlying function expression
|
|
|
+ *)
|
|
|
+ map_base_classfields : tclass->( int -> t -> (tvar list) -> (int->t->tconstant option->texpr) -> texpr )->tclass_field list;
|
|
|
}
|
|
|
|
|
|
type map_info = {
|
|
|
- in_unsafe : bool;
|
|
|
- in_unused : bool;
|
|
|
+ in_unsafe : bool;
|
|
|
+ in_unused : bool;
|
|
|
}
|
|
|
|
|
|
let null_map_info = { in_unsafe = false; in_unused = false; }
|
|
|
|
|
|
(*
|
|
|
- the default implementation will take 3 transformation functions:
|
|
|
- * one that will transform closures that are not called immediately (instance.myFunc).
|
|
|
- normally on this case it's best to have a runtime handler that will take the instance, the function and call its invokeField when invoked
|
|
|
- * one that will actually handle the anonymous functions themselves.
|
|
|
- * one that will transform calling a dynamic function. So for example, dynFunc(arg1, arg2) might turn into dynFunc.apply2(arg1, arg2);
|
|
|
- ( suspended ) * an option to match papplied functions
|
|
|
- * handling parameterized anonymous function declaration (optional - tparam_anon_decl and tparam_anon_acc)
|
|
|
+ the default implementation will take 3 transformation functions:
|
|
|
+ * one that will transform closures that are not called immediately (instance.myFunc).
|
|
|
+ normally on this case it's best to have a runtime handler that will take the instance, the function and call its invokeField when invoked
|
|
|
+ * one that will actually handle the anonymous functions themselves.
|
|
|
+ * one that will transform calling a dynamic function. So for example, dynFunc(arg1, arg2) might turn into dynFunc.apply2(arg1, arg2);
|
|
|
+ ( suspended ) * an option to match papplied functions
|
|
|
+ * handling parameterized anonymous function declaration (optional - tparam_anon_decl and tparam_anon_acc)
|
|
|
*)
|
|
|
|
|
|
let rec cleanup_delegate e = match e.eexpr with
|
|
|
- | TParenthesis e | TMeta(_,e)
|
|
|
- | TCast(e,_) -> cleanup_delegate e
|
|
|
- | _ -> e
|
|
|
+ | TParenthesis e | TMeta(_,e)
|
|
|
+ | TCast(e,_) -> cleanup_delegate e
|
|
|
+ | _ -> e
|
|
|
|
|
|
let funct gen t = match follow (run_follow gen t) with
|
|
|
- | TFun(args,ret) -> args,ret
|
|
|
- | _ -> raise Not_found
|
|
|
+ | TFun(args,ret) -> args,ret
|
|
|
+ | _ -> raise Not_found
|
|
|
|
|
|
let mk_conversion_fun gen e =
|
|
|
- let args, ret = funct gen e.etype in
|
|
|
- let tf_args = List.map (fun (n,o,t) -> alloc_var n t,None) args in
|
|
|
- let block, local = match e.eexpr with
|
|
|
- | TLocal v ->
|
|
|
- v.v_capture <- true;
|
|
|
- [],e
|
|
|
- | _ ->
|
|
|
- let tmp = mk_temp gen "delegate_conv" e.etype in
|
|
|
- tmp.v_capture <- true;
|
|
|
- [{ eexpr = TVar(tmp,Some e); etype = gen.gcon.basic.tvoid; epos = e.epos }], mk_local tmp e.epos
|
|
|
- in
|
|
|
- let body = {
|
|
|
- eexpr = TCall(local, List.map (fun (v,_) -> mk_local v e.epos) tf_args);
|
|
|
- etype = ret;
|
|
|
- epos = e.epos;
|
|
|
- } in
|
|
|
- let body = if not (ExtType.is_void ret) then
|
|
|
- { body with eexpr = TReturn( Some body ) }
|
|
|
- else
|
|
|
- body
|
|
|
- in
|
|
|
- let body = {
|
|
|
- eexpr = TBlock([body]);
|
|
|
- etype = body.etype;
|
|
|
- epos = body.epos;
|
|
|
- } in
|
|
|
- block, {
|
|
|
- tf_args = tf_args;
|
|
|
- tf_expr = body;
|
|
|
- tf_type = ret;
|
|
|
- }
|
|
|
+ let args, ret = funct gen e.etype in
|
|
|
+ let tf_args = List.map (fun (n,o,t) -> alloc_var n t,None) args in
|
|
|
+ let block, local = match e.eexpr with
|
|
|
+ | TLocal v ->
|
|
|
+ v.v_capture <- true;
|
|
|
+ [],e
|
|
|
+ | _ ->
|
|
|
+ let tmp = mk_temp gen "delegate_conv" e.etype in
|
|
|
+ tmp.v_capture <- true;
|
|
|
+ [{ eexpr = TVar(tmp,Some e); etype = gen.gcon.basic.tvoid; epos = e.epos }], mk_local tmp e.epos
|
|
|
+ in
|
|
|
+ let body = {
|
|
|
+ eexpr = TCall(local, List.map (fun (v,_) -> mk_local v e.epos) tf_args);
|
|
|
+ etype = ret;
|
|
|
+ epos = e.epos;
|
|
|
+ } in
|
|
|
+ let body = if not (ExtType.is_void ret) then
|
|
|
+ { body with eexpr = TReturn( Some body ) }
|
|
|
+ else
|
|
|
+ body
|
|
|
+ in
|
|
|
+ let body = {
|
|
|
+ eexpr = TBlock([body]);
|
|
|
+ etype = body.etype;
|
|
|
+ epos = body.epos;
|
|
|
+ } in
|
|
|
+ block, {
|
|
|
+ tf_args = tf_args;
|
|
|
+ tf_expr = body;
|
|
|
+ tf_type = ret;
|
|
|
+ }
|
|
|
|
|
|
let traverse gen ?tparam_anon_decl ?tparam_anon_acc (handle_anon_func:texpr->tfunc->map_info->t option->texpr) (dynamic_func_call:texpr->texpr) e =
|
|
|
- let info = ref null_map_info in
|
|
|
- let rec run e =
|
|
|
- match e.eexpr with
|
|
|
- | TCast({ eexpr = TCall({ eexpr = TLocal{ v_name = "__delegate__" } } as local, [del] ) } as e2, _) ->
|
|
|
- let e2 = { e2 with etype = e.etype } in
|
|
|
- let replace_delegate ex =
|
|
|
- { e with eexpr = TCast({ e2 with eexpr = TCall(local, [ex]) }, None) }
|
|
|
- in
|
|
|
- (* found a delegate; let's see if it's a closure or not *)
|
|
|
- let clean = cleanup_delegate del in
|
|
|
- (match clean.eexpr with
|
|
|
- | TField( ef, (FClosure _ as f)) | TField( ef, (FStatic _ as f)) ->
|
|
|
- (* a closure; let's leave this unchanged for FilterClosures to handle it *)
|
|
|
- replace_delegate { clean with eexpr = TField( run ef, f ) }
|
|
|
- | TFunction tf ->
|
|
|
- (* handle like we'd handle a normal function, but create an unchanged closure field for it *)
|
|
|
- let ret = handle_anon_func clean { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
|
|
|
- replace_delegate ret
|
|
|
- | _ -> try
|
|
|
- let block, tf = mk_conversion_fun gen del in
|
|
|
- let block = List.map run block in
|
|
|
- let tf = { tf with tf_expr = run tf.tf_expr } in
|
|
|
- let ret = handle_anon_func { clean with eexpr = TFunction(tf) } { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
|
|
|
- let ret = replace_delegate ret in
|
|
|
- if block = [] then
|
|
|
- ret
|
|
|
- else
|
|
|
- { ret with eexpr = TBlock(block @ [ret]) }
|
|
|
- with Not_found ->
|
|
|
- gen.gcon.error "This delegate construct is unsupported" e.epos;
|
|
|
- replace_delegate (run clean))
|
|
|
-
|
|
|
- | TCall(({ eexpr = TLocal{ v_name = "__unsafe__" } } as local), [arg]) ->
|
|
|
- let old = !info in
|
|
|
- info := { !info with in_unsafe = true };
|
|
|
- let arg2 = run arg in
|
|
|
- info := old;
|
|
|
- { e with eexpr = TCall(local,[arg2]) }
|
|
|
- (* parameterized functions handling *)
|
|
|
- | TVar(vv, ve) -> (match tparam_anon_decl with
|
|
|
- | None -> Type.map_expr run e
|
|
|
- | Some tparam_anon_decl ->
|
|
|
- (match (vv, ve) with
|
|
|
- | ({ v_extra = Some( _ :: _, _) } as v), Some ({ eexpr = TFunction tf } as f)
|
|
|
- | ({ v_extra = Some( _ :: _, _) } as v), Some { eexpr = TArrayDecl([{ eexpr = TFunction tf } as f]) | TCall({ eexpr = TLocal { v_name = "__array__" } }, [{ eexpr = TFunction tf } as f]) } -> (* captured transformation *)
|
|
|
- ignore(tparam_anon_decl v f { tf with tf_expr = run tf.tf_expr });
|
|
|
- { e with eexpr = TBlock([]) }
|
|
|
- | _ ->
|
|
|
- Type.map_expr run { e with eexpr = TVar(vv, ve) })
|
|
|
- )
|
|
|
- | TLocal ({ v_extra = Some( _ :: _, _) } as v)
|
|
|
- | TArray ({ eexpr = TLocal ({ v_extra = Some( _ :: _, _) } as v) }, _) -> (* captured transformation *)
|
|
|
- (match tparam_anon_acc with
|
|
|
- | None -> Type.map_expr run e
|
|
|
- | Some tparam_anon_acc -> tparam_anon_acc v e)
|
|
|
- | TCall( { eexpr = TField(_, FEnum _) }, _ ) ->
|
|
|
- Type.map_expr run e
|
|
|
- (* if a TClosure is being call immediately, there's no need to convert it to a TClosure *)
|
|
|
- | TCall(( { eexpr = TField(ecl,f) } as e1), params) ->
|
|
|
- (* check to see if called field is known and if it is a MethNormal (only MethNormal fields can be called directly) *)
|
|
|
- (* let name = field_name f in *)
|
|
|
- (match field_access_esp gen (gen.greal_type ecl.etype) f with
|
|
|
- | FClassField(_,_,_,cf,_,_,_) ->
|
|
|
- (match cf.cf_kind with
|
|
|
- | Method MethNormal
|
|
|
- | Method MethInline ->
|
|
|
- { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
|
|
|
- | _ ->
|
|
|
- match gen.gfollow#run_f e1.etype with
|
|
|
- | TFun _ ->
|
|
|
- dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
|
|
|
- | _ ->
|
|
|
- let i = ref 0 in
|
|
|
- let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
|
|
|
- dynamic_func_call { e with eexpr = TCall( mk_castfast t (run e1), List.map run params ) }
|
|
|
- )
|
|
|
- (* | FNotFound ->
|
|
|
- { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
|
|
|
- (* expressions by now may have generated invalid expressions *) *)
|
|
|
- | _ ->
|
|
|
- match gen.gfollow#run_f e1.etype with
|
|
|
- | TFun _ ->
|
|
|
- dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
|
|
|
- | _ ->
|
|
|
- let i = ref 0 in
|
|
|
- let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
|
|
|
- dynamic_func_call { e with eexpr = TCall( mk_castfast t (run e1), List.map run params ) }
|
|
|
- )
|
|
|
- | TFunction tf ->
|
|
|
- handle_anon_func e { tf with tf_expr = run tf.tf_expr } !info None
|
|
|
- | TCall({ eexpr = TConst(TSuper) }, _) ->
|
|
|
- Type.map_expr run e
|
|
|
- | TCall({ eexpr = TLocal(v) }, args) when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name ->
|
|
|
- Type.map_expr run e
|
|
|
- | TCall(tc,params) ->
|
|
|
- let i = ref 0 in
|
|
|
- let may_cast = match gen.gfollow#run_f tc.etype with
|
|
|
- | TFun _ -> fun e -> e
|
|
|
- | _ ->
|
|
|
- let t = TFun(List.map (fun e ->
|
|
|
- incr i;
|
|
|
- ("p" ^ (string_of_int !i), false, e.etype)
|
|
|
- ) params, e.etype)
|
|
|
- in
|
|
|
- fun e -> mk_castfast t e
|
|
|
- in
|
|
|
- dynamic_func_call { e with eexpr = TCall(run (may_cast tc), List.map run params) }
|
|
|
- | _ -> Type.map_expr run e
|
|
|
- in
|
|
|
-
|
|
|
- (match e.eexpr with
|
|
|
- | TFunction(tf) -> Type.map_expr run e
|
|
|
- | _ -> run e)
|
|
|
+ let info = ref null_map_info in
|
|
|
+ let rec run e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TCast({ eexpr = TCall({ eexpr = TLocal{ v_name = "__delegate__" } } as local, [del] ) } as e2, _) ->
|
|
|
+ let e2 = { e2 with etype = e.etype } in
|
|
|
+ let replace_delegate ex =
|
|
|
+ { e with eexpr = TCast({ e2 with eexpr = TCall(local, [ex]) }, None) }
|
|
|
+ in
|
|
|
+ (* found a delegate; let's see if it's a closure or not *)
|
|
|
+ let clean = cleanup_delegate del in
|
|
|
+ (match clean.eexpr with
|
|
|
+ | TField( ef, (FClosure _ as f)) | TField( ef, (FStatic _ as f)) ->
|
|
|
+ (* a closure; let's leave this unchanged for FilterClosures to handle it *)
|
|
|
+ replace_delegate { clean with eexpr = TField( run ef, f ) }
|
|
|
+ | TFunction tf ->
|
|
|
+ (* handle like we'd handle a normal function, but create an unchanged closure field for it *)
|
|
|
+ let ret = handle_anon_func clean { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
|
|
|
+ replace_delegate ret
|
|
|
+ | _ -> try
|
|
|
+ let block, tf = mk_conversion_fun gen del in
|
|
|
+ let block = List.map run block in
|
|
|
+ let tf = { tf with tf_expr = run tf.tf_expr } in
|
|
|
+ let ret = handle_anon_func { clean with eexpr = TFunction(tf) } { tf with tf_expr = run tf.tf_expr } !info (Some e.etype) in
|
|
|
+ let ret = replace_delegate ret in
|
|
|
+ if block = [] then
|
|
|
+ ret
|
|
|
+ else
|
|
|
+ { ret with eexpr = TBlock(block @ [ret]) }
|
|
|
+ with Not_found ->
|
|
|
+ gen.gcon.error "This delegate construct is unsupported" e.epos;
|
|
|
+ replace_delegate (run clean))
|
|
|
+
|
|
|
+ | TCall(({ eexpr = TLocal{ v_name = "__unsafe__" } } as local), [arg]) ->
|
|
|
+ let old = !info in
|
|
|
+ info := { !info with in_unsafe = true };
|
|
|
+ let arg2 = run arg in
|
|
|
+ info := old;
|
|
|
+ { e with eexpr = TCall(local,[arg2]) }
|
|
|
+ (* parameterized functions handling *)
|
|
|
+ | TVar(vv, ve) -> (match tparam_anon_decl with
|
|
|
+ | None -> Type.map_expr run e
|
|
|
+ | Some tparam_anon_decl ->
|
|
|
+ (match (vv, ve) with
|
|
|
+ | ({ v_extra = Some( _ :: _, _) } as v), Some ({ eexpr = TFunction tf } as f)
|
|
|
+ | ({ v_extra = Some( _ :: _, _) } as v), Some { eexpr = TArrayDecl([{ eexpr = TFunction tf } as f]) | TCall({ eexpr = TLocal { v_name = "__array__" } }, [{ eexpr = TFunction tf } as f]) } -> (* captured transformation *)
|
|
|
+ ignore(tparam_anon_decl v f { tf with tf_expr = run tf.tf_expr });
|
|
|
+ { e with eexpr = TBlock([]) }
|
|
|
+ | _ ->
|
|
|
+ Type.map_expr run { e with eexpr = TVar(vv, ve) })
|
|
|
+ )
|
|
|
+ | TLocal ({ v_extra = Some( _ :: _, _) } as v)
|
|
|
+ | TArray ({ eexpr = TLocal ({ v_extra = Some( _ :: _, _) } as v) }, _) -> (* captured transformation *)
|
|
|
+ (match tparam_anon_acc with
|
|
|
+ | None -> Type.map_expr run e
|
|
|
+ | Some tparam_anon_acc -> tparam_anon_acc v e)
|
|
|
+ | TCall( { eexpr = TField(_, FEnum _) }, _ ) ->
|
|
|
+ Type.map_expr run e
|
|
|
+ (* if a TClosure is being call immediately, there's no need to convert it to a TClosure *)
|
|
|
+ | TCall(( { eexpr = TField(ecl,f) } as e1), params) ->
|
|
|
+ (* check to see if called field is known and if it is a MethNormal (only MethNormal fields can be called directly) *)
|
|
|
+ (* let name = field_name f in *)
|
|
|
+ (match field_access_esp gen (gen.greal_type ecl.etype) f with
|
|
|
+ | FClassField(_,_,_,cf,_,_,_) ->
|
|
|
+ (match cf.cf_kind with
|
|
|
+ | Method MethNormal
|
|
|
+ | Method MethInline ->
|
|
|
+ { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
|
|
|
+ | _ ->
|
|
|
+ match gen.gfollow#run_f e1.etype with
|
|
|
+ | TFun _ ->
|
|
|
+ dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
|
|
|
+ | _ ->
|
|
|
+ let i = ref 0 in
|
|
|
+ let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
|
|
|
+ dynamic_func_call { e with eexpr = TCall( mk_castfast t (run e1), List.map run params ) }
|
|
|
+ )
|
|
|
+ (* | FNotFound ->
|
|
|
+ { e with eexpr = TCall({ e1 with eexpr = TField(run ecl, f) }, List.map run params) }
|
|
|
+ (* expressions by now may have generated invalid expressions *) *)
|
|
|
+ | _ ->
|
|
|
+ match gen.gfollow#run_f e1.etype with
|
|
|
+ | TFun _ ->
|
|
|
+ dynamic_func_call { e with eexpr = TCall(run e1, List.map run params) }
|
|
|
+ | _ ->
|
|
|
+ let i = ref 0 in
|
|
|
+ let t = TFun(List.map (fun e -> incr i; "arg" ^ (string_of_int !i), false, e.etype) params, e.etype) in
|
|
|
+ dynamic_func_call { e with eexpr = TCall( mk_castfast t (run e1), List.map run params ) }
|
|
|
+ )
|
|
|
+ | TFunction tf ->
|
|
|
+ handle_anon_func e { tf with tf_expr = run tf.tf_expr } !info None
|
|
|
+ | TCall({ eexpr = TConst(TSuper) }, _) ->
|
|
|
+ Type.map_expr run e
|
|
|
+ | TCall({ eexpr = TLocal(v) }, args) when String.get v.v_name 0 = '_' && Hashtbl.mem gen.gspecial_vars v.v_name ->
|
|
|
+ Type.map_expr run e
|
|
|
+ | TCall(tc,params) ->
|
|
|
+ let i = ref 0 in
|
|
|
+ let may_cast = match gen.gfollow#run_f tc.etype with
|
|
|
+ | TFun _ -> fun e -> e
|
|
|
+ | _ ->
|
|
|
+ let t = TFun(List.map (fun e ->
|
|
|
+ incr i;
|
|
|
+ ("p" ^ (string_of_int !i), false, e.etype)
|
|
|
+ ) params, e.etype)
|
|
|
+ in
|
|
|
+ fun e -> mk_castfast t e
|
|
|
+ in
|
|
|
+ dynamic_func_call { e with eexpr = TCall(run (may_cast tc), List.map run params) }
|
|
|
+ | _ -> Type.map_expr run e
|
|
|
+ in
|
|
|
+
|
|
|
+ (match e.eexpr with
|
|
|
+ | TFunction(tf) -> Type.map_expr run e
|
|
|
+ | _ -> run e)
|
|
|
|
|
|
let rec get_type_params acc t =
|
|
|
- match t with
|
|
|
- | TInst(( { cl_kind = KTypeParameter _ } as cl), []) ->
|
|
|
- if List.memq cl acc then acc else cl :: acc
|
|
|
- | TFun (params,tret) ->
|
|
|
- List.fold_left get_type_params acc ( tret :: List.map (fun (_,_,t) -> t) params )
|
|
|
- | TDynamic t ->
|
|
|
- (match t with | TDynamic _ -> acc | _ -> get_type_params acc t)
|
|
|
- | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
|
|
|
- get_type_params acc ( Abstract.get_underlying_type a pl)
|
|
|
- | TAnon a ->
|
|
|
- PMap.fold (fun cf acc ->
|
|
|
- let params = List.map (fun (_,t) -> match follow t with
|
|
|
- | TInst(c,_) -> c
|
|
|
- | _ -> assert false) cf.cf_params
|
|
|
- in
|
|
|
- List.filter (fun t -> not (List.memq t params)) (get_type_params acc cf.cf_type)
|
|
|
- ) a.a_fields acc
|
|
|
- | TType(_, [])
|
|
|
- | TAbstract (_, [])
|
|
|
- | TInst(_, [])
|
|
|
- | TEnum(_, []) ->
|
|
|
- acc
|
|
|
- | TType(_, params)
|
|
|
- | TAbstract(_, params)
|
|
|
- | TEnum(_, params)
|
|
|
- | TInst(_, params) ->
|
|
|
- List.fold_left get_type_params acc params
|
|
|
- | TMono r -> (match !r with
|
|
|
- | Some t -> get_type_params acc t
|
|
|
- | None -> acc)
|
|
|
- | _ -> get_type_params acc (follow_once t)
|
|
|
+ match t with
|
|
|
+ | TInst(( { cl_kind = KTypeParameter _ } as cl), []) ->
|
|
|
+ if List.memq cl acc then acc else cl :: acc
|
|
|
+ | TFun (params,tret) ->
|
|
|
+ List.fold_left get_type_params acc ( tret :: List.map (fun (_,_,t) -> t) params )
|
|
|
+ | TDynamic t ->
|
|
|
+ (match t with | TDynamic _ -> acc | _ -> get_type_params acc t)
|
|
|
+ | TAbstract (a, pl) when not (Meta.has Meta.CoreType a.a_meta) ->
|
|
|
+ get_type_params acc ( Abstract.get_underlying_type a pl)
|
|
|
+ | TAnon a ->
|
|
|
+ PMap.fold (fun cf acc ->
|
|
|
+ let params = List.map (fun (_,t) -> match follow t with
|
|
|
+ | TInst(c,_) -> c
|
|
|
+ | _ -> assert false) cf.cf_params
|
|
|
+ in
|
|
|
+ List.filter (fun t -> not (List.memq t params)) (get_type_params acc cf.cf_type)
|
|
|
+ ) a.a_fields acc
|
|
|
+ | TType(_, [])
|
|
|
+ | TAbstract (_, [])
|
|
|
+ | TInst(_, [])
|
|
|
+ | TEnum(_, []) ->
|
|
|
+ acc
|
|
|
+ | TType(_, params)
|
|
|
+ | TAbstract(_, params)
|
|
|
+ | TEnum(_, params)
|
|
|
+ | TInst(_, params) ->
|
|
|
+ List.fold_left get_type_params acc params
|
|
|
+ | TMono r -> (match !r with
|
|
|
+ | Some t -> get_type_params acc t
|
|
|
+ | None -> acc)
|
|
|
+ | _ -> get_type_params acc (follow_once t)
|
|
|
|
|
|
let get_captured expr =
|
|
|
- let ret = Hashtbl.create 1 in
|
|
|
- let ignored = Hashtbl.create 0 in
|
|
|
-
|
|
|
- let params = ref [] in
|
|
|
- let check_params t = params := get_type_params !params t in
|
|
|
- let rec traverse expr =
|
|
|
- match expr.eexpr with
|
|
|
- | TFor (v, _, _) ->
|
|
|
- Hashtbl.add ignored v.v_id v;
|
|
|
- check_params v.v_type;
|
|
|
- Type.iter traverse expr
|
|
|
- | TFunction(tf) ->
|
|
|
- List.iter (fun (v,_) -> Hashtbl.add ignored v.v_id v) tf.tf_args;
|
|
|
- (match follow expr.etype with
|
|
|
- | TFun(args,ret) ->
|
|
|
- List.iter (fun (_,_,t) ->
|
|
|
- check_params t
|
|
|
- ) args;
|
|
|
- check_params ret
|
|
|
- | _ -> ());
|
|
|
- Type.iter traverse expr
|
|
|
- | TVar (v, opt) ->
|
|
|
- (match v.v_extra with
|
|
|
- | Some(_ :: _, _) -> ()
|
|
|
- | _ ->
|
|
|
- check_params v.v_type);
|
|
|
- Hashtbl.add ignored v.v_id v;
|
|
|
- ignore(Option.map traverse opt)
|
|
|
- | TLocal { v_extra = Some( (_ :: _ ),_) } ->
|
|
|
- ()
|
|
|
- | TLocal(( { v_capture = true } ) as v) ->
|
|
|
- (if not (Hashtbl.mem ignored v.v_id || Hashtbl.mem ret v.v_id) then begin check_params v.v_type; Hashtbl.replace ret v.v_id expr end);
|
|
|
- | _ -> Type.iter traverse expr
|
|
|
- in traverse expr;
|
|
|
- ret, !params
|
|
|
+ let ret = Hashtbl.create 1 in
|
|
|
+ let ignored = Hashtbl.create 0 in
|
|
|
+
|
|
|
+ let params = ref [] in
|
|
|
+ let check_params t = params := get_type_params !params t in
|
|
|
+ let rec traverse expr =
|
|
|
+ match expr.eexpr with
|
|
|
+ | TFor (v, _, _) ->
|
|
|
+ Hashtbl.add ignored v.v_id v;
|
|
|
+ check_params v.v_type;
|
|
|
+ Type.iter traverse expr
|
|
|
+ | TFunction(tf) ->
|
|
|
+ List.iter (fun (v,_) -> Hashtbl.add ignored v.v_id v) tf.tf_args;
|
|
|
+ (match follow expr.etype with
|
|
|
+ | TFun(args,ret) ->
|
|
|
+ List.iter (fun (_,_,t) ->
|
|
|
+ check_params t
|
|
|
+ ) args;
|
|
|
+ check_params ret
|
|
|
+ | _ -> ());
|
|
|
+ Type.iter traverse expr
|
|
|
+ | TVar (v, opt) ->
|
|
|
+ (match v.v_extra with
|
|
|
+ | Some(_ :: _, _) -> ()
|
|
|
+ | _ ->
|
|
|
+ check_params v.v_type);
|
|
|
+ Hashtbl.add ignored v.v_id v;
|
|
|
+ ignore(Option.map traverse opt)
|
|
|
+ | TLocal { v_extra = Some( (_ :: _ ),_) } ->
|
|
|
+ ()
|
|
|
+ | TLocal(( { v_capture = true } ) as v) ->
|
|
|
+ (if not (Hashtbl.mem ignored v.v_id || Hashtbl.mem ret v.v_id) then begin check_params v.v_type; Hashtbl.replace ret v.v_id expr end);
|
|
|
+ | _ -> Type.iter traverse expr
|
|
|
+ in traverse expr;
|
|
|
+ ret, !params
|
|
|
|
|
|
(*
|
|
|
- OPTIMIZEME:
|
|
|
-
|
|
|
- Take off from Codegen the code that wraps captured variables,
|
|
|
-
|
|
|
- traverse through all variables, looking for their use (just like local_usage)
|
|
|
- three possible outcomes for captured variables:
|
|
|
- - become a function member variable <- best performance.
|
|
|
- Will not work on functions that can be created more than once (functions inside a loop or functions inside functions)
|
|
|
- The function will have to be created on top of the block, so its variables can be filled in instead of being declared
|
|
|
- - single-element array - the most compatible way, though also creates a slight overhead.
|
|
|
- - we'll have some labels for captured variables:
|
|
|
- - used in loop
|
|
|
+ OPTIMIZEME:
|
|
|
+
|
|
|
+ Take off from Codegen the code that wraps captured variables,
|
|
|
+
|
|
|
+ traverse through all variables, looking for their use (just like local_usage)
|
|
|
+ three possible outcomes for captured variables:
|
|
|
+ - become a function member variable <- best performance.
|
|
|
+ Will not work on functions that can be created more than once (functions inside a loop or functions inside functions)
|
|
|
+ The function will have to be created on top of the block, so its variables can be filled in instead of being declared
|
|
|
+ - single-element array - the most compatible way, though also creates a slight overhead.
|
|
|
+ - we'll have some labels for captured variables:
|
|
|
+ - used in loop
|
|
|
*)
|
|
|
|
|
|
(*
|
|
|
- The default implementation will impose a naming convention:
|
|
|
- invoke(arity)_(o for returning object/d for returning double) when arity < max_arity
|
|
|
- invoke_dynamic_(o/d) when arity > max_arity
|
|
|
+ The default implementation will impose a naming convention:
|
|
|
+ invoke(arity)_(o for returning object/d for returning double) when arity < max_arity
|
|
|
+ invoke_dynamic_(o/d) when arity > max_arity
|
|
|
|
|
|
- This means that it also imposes that the dynamic function return types may only be Dynamic or Float, and all other basic types must be converted to/from it.
|
|
|
+ This means that it also imposes that the dynamic function return types may only be Dynamic or Float, and all other basic types must be converted to/from it.
|
|
|
*)
|
|
|
let configure gen ft =
|
|
|
|
|
|
- let handle_anon_func fexpr tfunc mapinfo delegate_type : texpr * (tclass * texpr list) =
|
|
|
- let in_unsafe = mapinfo.in_unsafe || match gen.gcurrent_class, gen.gcurrent_classfield with
|
|
|
- | Some c, _ when Meta.has Meta.Unsafe c.cl_meta -> true
|
|
|
- | _, Some cf when Meta.has Meta.Unsafe cf.cf_meta -> true
|
|
|
- | _ -> false
|
|
|
- in
|
|
|
- (* get all captured variables it uses *)
|
|
|
- let captured_ht, tparams = get_captured fexpr in
|
|
|
- let captured = Hashtbl.fold (fun _ e acc -> e :: acc) captured_ht [] in
|
|
|
- let captured = List.sort (fun e1 e2 -> match e1, e2 with
|
|
|
- | { eexpr = TLocal v1 }, { eexpr = TLocal v2 } ->
|
|
|
- compare v1.v_name v2.v_name
|
|
|
- | _ -> assert false) captured
|
|
|
- in
|
|
|
-
|
|
|
- (*let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(map_param cl, []) )) tparams in*)
|
|
|
- let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(cl, []) )) tparams in
|
|
|
-
|
|
|
- (* create a new class that extends abstract function class, with a ctor implementation that will setup all captured variables *)
|
|
|
- let cfield = match gen.gcurrent_classfield with
|
|
|
- | None -> "Anon"
|
|
|
- | Some cf -> cf.cf_name
|
|
|
- in
|
|
|
- let cur_line = Lexer.get_error_line fexpr.epos in
|
|
|
- let path = (fst gen.gcurrent_path, Printf.sprintf "%s_%s_%d__Fun" (snd gen.gcurrent_path) cfield cur_line) in
|
|
|
- let cls = mk_class (get gen.gcurrent_class).cl_module path tfunc.tf_expr.epos in
|
|
|
- if in_unsafe then cls.cl_meta <- (Meta.Unsafe,[],null_pos) :: cls.cl_meta;
|
|
|
-
|
|
|
- if Common.defined gen.gcon Define.EraseGenerics then begin
|
|
|
- cls.cl_meta <- (Meta.HaxeGeneric,[],null_pos) :: cls.cl_meta
|
|
|
- end;
|
|
|
- cls.cl_module <- (get gen.gcurrent_class).cl_module;
|
|
|
- cls.cl_params <- cltypes;
|
|
|
-
|
|
|
- let mk_this v pos =
|
|
|
- {
|
|
|
- (mk_field_access gen { eexpr = TConst TThis; etype = TInst(cls, List.map snd cls.cl_params); epos = pos } v.v_name pos)
|
|
|
- with etype = v.v_type
|
|
|
- }
|
|
|
- in
|
|
|
-
|
|
|
- let mk_this_assign v pos =
|
|
|
- {
|
|
|
- eexpr = TBinop(OpAssign, mk_this v pos, { eexpr = TLocal(v); etype = v.v_type; epos = pos });
|
|
|
- etype = v.v_type;
|
|
|
- epos = pos
|
|
|
- } in
|
|
|
-
|
|
|
- (* mk_class_field name t public pos kind params *)
|
|
|
- let ctor_args, ctor_sig, ctor_exprs = List.fold_left (fun (ctor_args, ctor_sig, ctor_exprs) lexpr ->
|
|
|
- match lexpr.eexpr with
|
|
|
- | TLocal(v) ->
|
|
|
- let cf = mk_class_field v.v_name v.v_type false lexpr.epos (Var({ v_read = AccNormal; v_write = AccNormal; })) [] in
|
|
|
- cls.cl_fields <- PMap.add v.v_name cf cls.cl_fields;
|
|
|
- cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
|
|
|
-
|
|
|
- let ctor_v = alloc_var v.v_name v.v_type in
|
|
|
- ((ctor_v, None) :: ctor_args, (v.v_name, false, v.v_type) :: ctor_sig, (mk_this_assign v cls.cl_pos) :: ctor_exprs)
|
|
|
- | _ -> assert false
|
|
|
- ) ([],[],[]) captured in
|
|
|
-
|
|
|
- (* change all captured variables to this.capturedVariable *)
|
|
|
- let rec change_captured e =
|
|
|
- match e.eexpr with
|
|
|
- | TLocal( ({ v_capture = true }) as v ) when Hashtbl.mem captured_ht v.v_id ->
|
|
|
- mk_this v e.epos
|
|
|
- | _ -> Type.map_expr change_captured e
|
|
|
- in
|
|
|
- let func_expr = change_captured tfunc.tf_expr in
|
|
|
-
|
|
|
- let invokecf, invoke_field, super_args = match delegate_type with
|
|
|
- | None -> (* no delegate *)
|
|
|
- let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = func_expr } fexpr.etype fexpr.epos in
|
|
|
- ifield,ifield,sa
|
|
|
- | Some _ ->
|
|
|
- let pos = cls.cl_pos in
|
|
|
- let cf = mk_class_field "Delegate" (TFun(fun_args tfunc.tf_args, tfunc.tf_type)) true pos (Method MethNormal) [] in
|
|
|
- cf.cf_expr <- Some { fexpr with eexpr = TFunction { tfunc with tf_expr = func_expr }; };
|
|
|
- cf.cf_meta <- (Meta.Final,[],pos) :: cf.cf_meta;
|
|
|
- cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
|
|
|
- cls.cl_fields <- PMap.add cf.cf_name cf cls.cl_fields;
|
|
|
- (* invoke function body: call Delegate function *)
|
|
|
- let ibody = {
|
|
|
- eexpr = TCall({
|
|
|
- eexpr = TField({
|
|
|
- eexpr = TConst TThis;
|
|
|
- etype = TInst(cls, List.map snd cls.cl_params);
|
|
|
- epos = pos;
|
|
|
- }, FInstance(cls, List.map snd cls.cl_params, cf));
|
|
|
- etype = cf.cf_type;
|
|
|
- epos = pos;
|
|
|
- }, List.map (fun (v,_) -> mk_local v pos) tfunc.tf_args);
|
|
|
- etype = tfunc.tf_type;
|
|
|
- epos = pos
|
|
|
- } in
|
|
|
- let ibody = if not (ExtType.is_void tfunc.tf_type) then
|
|
|
- { ibody with eexpr = TReturn( Some ibody ) }
|
|
|
- else
|
|
|
- ibody
|
|
|
- in
|
|
|
- let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = ibody } fexpr.etype fexpr.epos in
|
|
|
- cf,ifield,sa
|
|
|
- in
|
|
|
-
|
|
|
- (* create the constructor *)
|
|
|
- (* todo properly abstract how type var is set *)
|
|
|
-
|
|
|
- cls.cl_super <- Some(ft.func_class, []);
|
|
|
- let pos = cls.cl_pos in
|
|
|
- let super_call =
|
|
|
- {
|
|
|
- eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(ft.func_class,[]); epos = pos }, super_args);
|
|
|
- etype = gen.gcon.basic.tvoid;
|
|
|
- epos = pos;
|
|
|
- } in
|
|
|
-
|
|
|
- let ctor_type = (TFun(ctor_sig, gen.gcon.basic.tvoid)) in
|
|
|
- let ctor = mk_class_field "new" ctor_type true cls.cl_pos (Method(MethNormal)) [] in
|
|
|
- ctor.cf_expr <- Some(
|
|
|
- {
|
|
|
- eexpr = TFunction(
|
|
|
- {
|
|
|
- tf_args = ctor_args;
|
|
|
- tf_type = gen.gcon.basic.tvoid;
|
|
|
- tf_expr = { eexpr = TBlock(super_call :: ctor_exprs); etype = gen.gcon.basic.tvoid; epos = cls.cl_pos }
|
|
|
- });
|
|
|
- etype = ctor_type;
|
|
|
- epos = cls.cl_pos;
|
|
|
- });
|
|
|
- cls.cl_constructor <- Some(ctor);
|
|
|
-
|
|
|
- (* add invoke function to the class *)
|
|
|
- cls.cl_ordered_fields <- invoke_field :: cls.cl_ordered_fields;
|
|
|
- cls.cl_fields <- PMap.add invoke_field.cf_name invoke_field cls.cl_fields;
|
|
|
- cls.cl_overrides <- invoke_field :: cls.cl_overrides;
|
|
|
-
|
|
|
- gen.gadd_to_module (TClassDecl cls) priority;
|
|
|
-
|
|
|
- (* if there are no captured variables, we can create a cache so subsequent calls don't need to create a new function *)
|
|
|
- let expr, clscapt =
|
|
|
- match captured, tparams with
|
|
|
- | [], [] ->
|
|
|
- let cache_var = gen.gmk_internal_name "hx" "current" in
|
|
|
- let cache_cf = mk_class_field cache_var (TInst(cls,[])) false func_expr.epos (Var({ v_read = AccNormal; v_write = AccNormal })) [] in
|
|
|
- cls.cl_ordered_statics <- cache_cf :: cls.cl_ordered_statics;
|
|
|
- cls.cl_statics <- PMap.add cache_var cache_cf cls.cl_statics;
|
|
|
-
|
|
|
- (* if (FuncClass.hx_current != null) FuncClass.hx_current; else (FuncClass.hx_current = new FuncClass()); *)
|
|
|
-
|
|
|
- (* let mk_static_field_access cl field fieldt pos = *)
|
|
|
- let hx_current = mk_static_field_access cls cache_var (TInst(cls,[])) func_expr.epos in
|
|
|
-
|
|
|
- let pos = func_expr.epos in
|
|
|
- { fexpr with
|
|
|
- etype = hx_current.etype;
|
|
|
- eexpr = TIf(
|
|
|
- {
|
|
|
- eexpr = TBinop(OpNotEq, hx_current, null (TInst(cls,[])) pos);
|
|
|
- etype = gen.gcon.basic.tbool;
|
|
|
- epos = pos;
|
|
|
- },
|
|
|
- hx_current,
|
|
|
- Some(
|
|
|
- {
|
|
|
- eexpr = TBinop(OpAssign, hx_current, { fexpr with eexpr = TNew(cls, [], captured) });
|
|
|
- etype = (TInst(cls,[]));
|
|
|
- epos = pos;
|
|
|
- }))
|
|
|
- }, (cls,captured)
|
|
|
- | _ ->
|
|
|
- (* change the expression so it will be a new "added class" ( captured variables arguments ) *)
|
|
|
- { fexpr with eexpr = TNew(cls, List.map (fun cl -> TInst(cl,[])) tparams, List.rev captured) }, (cls,captured)
|
|
|
- in
|
|
|
- match delegate_type with
|
|
|
- | None ->
|
|
|
- expr,clscapt
|
|
|
- | Some _ ->
|
|
|
- {
|
|
|
- eexpr = TField(expr, FClosure(Some (cls,[]),invokecf)); (* TODO: FClosure change *)
|
|
|
- etype = invokecf.cf_type;
|
|
|
- epos = cls.cl_pos
|
|
|
- }, clscapt
|
|
|
- in
|
|
|
-
|
|
|
- let tvar_to_cdecl = Hashtbl.create 0 in
|
|
|
-
|
|
|
- let run = traverse
|
|
|
- gen
|
|
|
- ~tparam_anon_decl:(fun v e fn ->
|
|
|
- let _, info = handle_anon_func e fn null_map_info None in
|
|
|
- Hashtbl.add tvar_to_cdecl v.v_id info
|
|
|
- )
|
|
|
- ~tparam_anon_acc:(fun v e -> try
|
|
|
- let cls, captured = Hashtbl.find tvar_to_cdecl v.v_id in
|
|
|
- let types = match v.v_extra with
|
|
|
- | Some(t,_) -> t
|
|
|
- | _ -> assert false
|
|
|
- in
|
|
|
- let monos = List.map (fun _ -> mk_mono()) types in
|
|
|
- let vt = match follow v.v_type with
|
|
|
- | TInst(_, [v]) -> v
|
|
|
- | v -> v
|
|
|
- in
|
|
|
- let et = match follow e.etype with
|
|
|
- | TInst(_, [v]) -> v
|
|
|
- | v -> v
|
|
|
- in
|
|
|
- let original = apply_params types monos vt in
|
|
|
- unify et original;
|
|
|
-
|
|
|
- let monos = List.map (fun t -> apply_params types (List.map (fun _ -> t_dynamic) types) t) monos in
|
|
|
-
|
|
|
- let same_cl t1 t2 = match follow t1, follow t2 with
|
|
|
- | TInst(c,_), TInst(c2,_) -> c == c2
|
|
|
- | _ -> false
|
|
|
- in
|
|
|
- let passoc = List.map2 (fun (_,t) m -> t,m) types monos in
|
|
|
- let cltparams = List.map (fun (_,t) ->
|
|
|
- try
|
|
|
- snd (List.find (fun (t2,_) -> same_cl t t2) passoc)
|
|
|
- with | Not_found -> t) cls.cl_params
|
|
|
- in
|
|
|
- { e with eexpr = TNew(cls, cltparams, captured) }
|
|
|
- with
|
|
|
- | Not_found ->
|
|
|
- gen.gcon.warning "This expression may be invalid" e.epos;
|
|
|
- e
|
|
|
- | Unify_error el ->
|
|
|
- List.iter (fun el -> gen.gcon.warning (Error.unify_error_msg (print_context()) el) e.epos) el;
|
|
|
- gen.gcon.warning "This expression may be invalid" e.epos;
|
|
|
- e
|
|
|
- )
|
|
|
- (* (handle_anon_func:texpr->tfunc->texpr) (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
|
|
|
- (fun e f info delegate_type -> fst (handle_anon_func e f info delegate_type))
|
|
|
- ft.dynamic_fun_call
|
|
|
- (* (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
|
|
|
- in
|
|
|
- let map e = Some(run e) in
|
|
|
- gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
|
|
|
+ let handle_anon_func fexpr tfunc mapinfo delegate_type : texpr * (tclass * texpr list) =
|
|
|
+ let in_unsafe = mapinfo.in_unsafe || match gen.gcurrent_class, gen.gcurrent_classfield with
|
|
|
+ | Some c, _ when Meta.has Meta.Unsafe c.cl_meta -> true
|
|
|
+ | _, Some cf when Meta.has Meta.Unsafe cf.cf_meta -> true
|
|
|
+ | _ -> false
|
|
|
+ in
|
|
|
+ (* get all captured variables it uses *)
|
|
|
+ let captured_ht, tparams = get_captured fexpr in
|
|
|
+ let captured = Hashtbl.fold (fun _ e acc -> e :: acc) captured_ht [] in
|
|
|
+ let captured = List.sort (fun e1 e2 -> match e1, e2 with
|
|
|
+ | { eexpr = TLocal v1 }, { eexpr = TLocal v2 } ->
|
|
|
+ compare v1.v_name v2.v_name
|
|
|
+ | _ -> assert false) captured
|
|
|
+ in
|
|
|
+
|
|
|
+ (*let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(map_param cl, []) )) tparams in*)
|
|
|
+ let cltypes = List.map (fun cl -> (snd cl.cl_path, TInst(cl, []) )) tparams in
|
|
|
+
|
|
|
+ (* create a new class that extends abstract function class, with a ctor implementation that will setup all captured variables *)
|
|
|
+ let cfield = match gen.gcurrent_classfield with
|
|
|
+ | None -> "Anon"
|
|
|
+ | Some cf -> cf.cf_name
|
|
|
+ in
|
|
|
+ let cur_line = Lexer.get_error_line fexpr.epos in
|
|
|
+ let path = (fst gen.gcurrent_path, Printf.sprintf "%s_%s_%d__Fun" (snd gen.gcurrent_path) cfield cur_line) in
|
|
|
+ let cls = mk_class (get gen.gcurrent_class).cl_module path tfunc.tf_expr.epos in
|
|
|
+ if in_unsafe then cls.cl_meta <- (Meta.Unsafe,[],null_pos) :: cls.cl_meta;
|
|
|
+
|
|
|
+ if Common.defined gen.gcon Define.EraseGenerics then begin
|
|
|
+ cls.cl_meta <- (Meta.HaxeGeneric,[],null_pos) :: cls.cl_meta
|
|
|
+ end;
|
|
|
+ cls.cl_module <- (get gen.gcurrent_class).cl_module;
|
|
|
+ cls.cl_params <- cltypes;
|
|
|
+
|
|
|
+ let mk_this v pos =
|
|
|
+ {
|
|
|
+ (mk_field_access gen { eexpr = TConst TThis; etype = TInst(cls, List.map snd cls.cl_params); epos = pos } v.v_name pos)
|
|
|
+ with etype = v.v_type
|
|
|
+ }
|
|
|
+ in
|
|
|
+
|
|
|
+ let mk_this_assign v pos =
|
|
|
+ {
|
|
|
+ eexpr = TBinop(OpAssign, mk_this v pos, { eexpr = TLocal(v); etype = v.v_type; epos = pos });
|
|
|
+ etype = v.v_type;
|
|
|
+ epos = pos
|
|
|
+ } in
|
|
|
+
|
|
|
+ (* mk_class_field name t public pos kind params *)
|
|
|
+ let ctor_args, ctor_sig, ctor_exprs = List.fold_left (fun (ctor_args, ctor_sig, ctor_exprs) lexpr ->
|
|
|
+ match lexpr.eexpr with
|
|
|
+ | TLocal(v) ->
|
|
|
+ let cf = mk_class_field v.v_name v.v_type false lexpr.epos (Var({ v_read = AccNormal; v_write = AccNormal; })) [] in
|
|
|
+ cls.cl_fields <- PMap.add v.v_name cf cls.cl_fields;
|
|
|
+ cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
|
|
|
+
|
|
|
+ let ctor_v = alloc_var v.v_name v.v_type in
|
|
|
+ ((ctor_v, None) :: ctor_args, (v.v_name, false, v.v_type) :: ctor_sig, (mk_this_assign v cls.cl_pos) :: ctor_exprs)
|
|
|
+ | _ -> assert false
|
|
|
+ ) ([],[],[]) captured in
|
|
|
+
|
|
|
+ (* change all captured variables to this.capturedVariable *)
|
|
|
+ let rec change_captured e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TLocal( ({ v_capture = true }) as v ) when Hashtbl.mem captured_ht v.v_id ->
|
|
|
+ mk_this v e.epos
|
|
|
+ | _ -> Type.map_expr change_captured e
|
|
|
+ in
|
|
|
+ let func_expr = change_captured tfunc.tf_expr in
|
|
|
+
|
|
|
+ let invokecf, invoke_field, super_args = match delegate_type with
|
|
|
+ | None -> (* no delegate *)
|
|
|
+ let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = func_expr } fexpr.etype fexpr.epos in
|
|
|
+ ifield,ifield,sa
|
|
|
+ | Some _ ->
|
|
|
+ let pos = cls.cl_pos in
|
|
|
+ let cf = mk_class_field "Delegate" (TFun(fun_args tfunc.tf_args, tfunc.tf_type)) true pos (Method MethNormal) [] in
|
|
|
+ cf.cf_expr <- Some { fexpr with eexpr = TFunction { tfunc with tf_expr = func_expr }; };
|
|
|
+ cf.cf_meta <- (Meta.Final,[],pos) :: cf.cf_meta;
|
|
|
+ cls.cl_ordered_fields <- cf :: cls.cl_ordered_fields;
|
|
|
+ cls.cl_fields <- PMap.add cf.cf_name cf cls.cl_fields;
|
|
|
+ (* invoke function body: call Delegate function *)
|
|
|
+ let ibody = {
|
|
|
+ eexpr = TCall({
|
|
|
+ eexpr = TField({
|
|
|
+ eexpr = TConst TThis;
|
|
|
+ etype = TInst(cls, List.map snd cls.cl_params);
|
|
|
+ epos = pos;
|
|
|
+ }, FInstance(cls, List.map snd cls.cl_params, cf));
|
|
|
+ etype = cf.cf_type;
|
|
|
+ epos = pos;
|
|
|
+ }, List.map (fun (v,_) -> mk_local v pos) tfunc.tf_args);
|
|
|
+ etype = tfunc.tf_type;
|
|
|
+ epos = pos
|
|
|
+ } in
|
|
|
+ let ibody = if not (ExtType.is_void tfunc.tf_type) then
|
|
|
+ { ibody with eexpr = TReturn( Some ibody ) }
|
|
|
+ else
|
|
|
+ ibody
|
|
|
+ in
|
|
|
+ let ifield, sa = ft.closure_to_classfield { tfunc with tf_expr = ibody } fexpr.etype fexpr.epos in
|
|
|
+ cf,ifield,sa
|
|
|
+ in
|
|
|
+
|
|
|
+ (* create the constructor *)
|
|
|
+ (* todo properly abstract how type var is set *)
|
|
|
+
|
|
|
+ cls.cl_super <- Some(ft.func_class, []);
|
|
|
+ let pos = cls.cl_pos in
|
|
|
+ let super_call =
|
|
|
+ {
|
|
|
+ eexpr = TCall({ eexpr = TConst(TSuper); etype = TInst(ft.func_class,[]); epos = pos }, super_args);
|
|
|
+ etype = gen.gcon.basic.tvoid;
|
|
|
+ epos = pos;
|
|
|
+ } in
|
|
|
+
|
|
|
+ let ctor_type = (TFun(ctor_sig, gen.gcon.basic.tvoid)) in
|
|
|
+ let ctor = mk_class_field "new" ctor_type true cls.cl_pos (Method(MethNormal)) [] in
|
|
|
+ ctor.cf_expr <- Some(
|
|
|
+ {
|
|
|
+ eexpr = TFunction(
|
|
|
+ {
|
|
|
+ tf_args = ctor_args;
|
|
|
+ tf_type = gen.gcon.basic.tvoid;
|
|
|
+ tf_expr = { eexpr = TBlock(super_call :: ctor_exprs); etype = gen.gcon.basic.tvoid; epos = cls.cl_pos }
|
|
|
+ });
|
|
|
+ etype = ctor_type;
|
|
|
+ epos = cls.cl_pos;
|
|
|
+ });
|
|
|
+ cls.cl_constructor <- Some(ctor);
|
|
|
+
|
|
|
+ (* add invoke function to the class *)
|
|
|
+ cls.cl_ordered_fields <- invoke_field :: cls.cl_ordered_fields;
|
|
|
+ cls.cl_fields <- PMap.add invoke_field.cf_name invoke_field cls.cl_fields;
|
|
|
+ cls.cl_overrides <- invoke_field :: cls.cl_overrides;
|
|
|
+
|
|
|
+ gen.gadd_to_module (TClassDecl cls) priority;
|
|
|
+
|
|
|
+ (* if there are no captured variables, we can create a cache so subsequent calls don't need to create a new function *)
|
|
|
+ let expr, clscapt =
|
|
|
+ match captured, tparams with
|
|
|
+ | [], [] ->
|
|
|
+ let cache_var = gen.gmk_internal_name "hx" "current" in
|
|
|
+ let cache_cf = mk_class_field cache_var (TInst(cls,[])) false func_expr.epos (Var({ v_read = AccNormal; v_write = AccNormal })) [] in
|
|
|
+ cls.cl_ordered_statics <- cache_cf :: cls.cl_ordered_statics;
|
|
|
+ cls.cl_statics <- PMap.add cache_var cache_cf cls.cl_statics;
|
|
|
+
|
|
|
+ (* if (FuncClass.hx_current != null) FuncClass.hx_current; else (FuncClass.hx_current = new FuncClass()); *)
|
|
|
+
|
|
|
+ (* let mk_static_field_access cl field fieldt pos = *)
|
|
|
+ let hx_current = mk_static_field_access cls cache_var (TInst(cls,[])) func_expr.epos in
|
|
|
+
|
|
|
+ let pos = func_expr.epos in
|
|
|
+ { fexpr with
|
|
|
+ etype = hx_current.etype;
|
|
|
+ eexpr = TIf(
|
|
|
+ {
|
|
|
+ eexpr = TBinop(OpNotEq, hx_current, null (TInst(cls,[])) pos);
|
|
|
+ etype = gen.gcon.basic.tbool;
|
|
|
+ epos = pos;
|
|
|
+ },
|
|
|
+ hx_current,
|
|
|
+ Some(
|
|
|
+ {
|
|
|
+ eexpr = TBinop(OpAssign, hx_current, { fexpr with eexpr = TNew(cls, [], captured) });
|
|
|
+ etype = (TInst(cls,[]));
|
|
|
+ epos = pos;
|
|
|
+ }))
|
|
|
+ }, (cls,captured)
|
|
|
+ | _ ->
|
|
|
+ (* change the expression so it will be a new "added class" ( captured variables arguments ) *)
|
|
|
+ { fexpr with eexpr = TNew(cls, List.map (fun cl -> TInst(cl,[])) tparams, List.rev captured) }, (cls,captured)
|
|
|
+ in
|
|
|
+ match delegate_type with
|
|
|
+ | None ->
|
|
|
+ expr,clscapt
|
|
|
+ | Some _ ->
|
|
|
+ {
|
|
|
+ eexpr = TField(expr, FClosure(Some (cls,[]),invokecf)); (* TODO: FClosure change *)
|
|
|
+ etype = invokecf.cf_type;
|
|
|
+ epos = cls.cl_pos
|
|
|
+ }, clscapt
|
|
|
+ in
|
|
|
+
|
|
|
+ let tvar_to_cdecl = Hashtbl.create 0 in
|
|
|
+
|
|
|
+ let run = traverse
|
|
|
+ gen
|
|
|
+ ~tparam_anon_decl:(fun v e fn ->
|
|
|
+ let _, info = handle_anon_func e fn null_map_info None in
|
|
|
+ Hashtbl.add tvar_to_cdecl v.v_id info
|
|
|
+ )
|
|
|
+ ~tparam_anon_acc:(fun v e -> try
|
|
|
+ let cls, captured = Hashtbl.find tvar_to_cdecl v.v_id in
|
|
|
+ let types = match v.v_extra with
|
|
|
+ | Some(t,_) -> t
|
|
|
+ | _ -> assert false
|
|
|
+ in
|
|
|
+ let monos = List.map (fun _ -> mk_mono()) types in
|
|
|
+ let vt = match follow v.v_type with
|
|
|
+ | TInst(_, [v]) -> v
|
|
|
+ | v -> v
|
|
|
+ in
|
|
|
+ let et = match follow e.etype with
|
|
|
+ | TInst(_, [v]) -> v
|
|
|
+ | v -> v
|
|
|
+ in
|
|
|
+ let original = apply_params types monos vt in
|
|
|
+ unify et original;
|
|
|
+
|
|
|
+ let monos = List.map (fun t -> apply_params types (List.map (fun _ -> t_dynamic) types) t) monos in
|
|
|
+
|
|
|
+ let same_cl t1 t2 = match follow t1, follow t2 with
|
|
|
+ | TInst(c,_), TInst(c2,_) -> c == c2
|
|
|
+ | _ -> false
|
|
|
+ in
|
|
|
+ let passoc = List.map2 (fun (_,t) m -> t,m) types monos in
|
|
|
+ let cltparams = List.map (fun (_,t) ->
|
|
|
+ try
|
|
|
+ snd (List.find (fun (t2,_) -> same_cl t t2) passoc)
|
|
|
+ with | Not_found -> t) cls.cl_params
|
|
|
+ in
|
|
|
+ { e with eexpr = TNew(cls, cltparams, captured) }
|
|
|
+ with
|
|
|
+ | Not_found ->
|
|
|
+ gen.gcon.warning "This expression may be invalid" e.epos;
|
|
|
+ e
|
|
|
+ | Unify_error el ->
|
|
|
+ List.iter (fun el -> gen.gcon.warning (Error.unify_error_msg (print_context()) el) e.epos) el;
|
|
|
+ gen.gcon.warning "This expression may be invalid" e.epos;
|
|
|
+ e
|
|
|
+ )
|
|
|
+ (* (handle_anon_func:texpr->tfunc->texpr) (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
|
|
|
+ (fun e f info delegate_type -> fst (handle_anon_func e f info delegate_type))
|
|
|
+ ft.dynamic_fun_call
|
|
|
+ (* (dynamic_func_call:texpr->texpr->texpr list->texpr) *)
|
|
|
+ in
|
|
|
+ let map e = Some(run e) in
|
|
|
+ gen.gexpr_filters#add ~name:name ~priority:(PCustom priority) map
|
|
|
|
|
|
|
|
|
(*
|
|
|
- this submodule will provide the default implementation for the C# and Java targets.
|
|
|
+ this submodule will provide the default implementation for the C# and Java targets.
|
|
|
|
|
|
- it will have two return types: double and dynamic, and
|
|
|
+ it will have two return types: double and dynamic, and
|
|
|
*)
|
|
|
module DoubleAndDynamicClosureImpl =
|
|
|
struct
|
|
|
- let get_ctx gen parent_func_class max_arity (* e.g. new haxe.lang.ClassClosure *) =
|
|
|
- let basic = gen.gcon.basic in
|
|
|
-
|
|
|
- let func_args_i i =
|
|
|
- let rec loop i (acc) =
|
|
|
- if i = 0 then (acc) else begin
|
|
|
- let vfloat = alloc_var (gen.gmk_internal_name "fn" ("float" ^ string_of_int i)) basic.tfloat in
|
|
|
- let vdyn = alloc_var (gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i)) t_dynamic in
|
|
|
-
|
|
|
- loop (i - 1) ((vfloat, None) :: (vdyn, None) :: acc)
|
|
|
- end
|
|
|
- in
|
|
|
- loop i []
|
|
|
- in
|
|
|
-
|
|
|
- let args_real_to_func args =
|
|
|
- let arity = List.length args in
|
|
|
- if arity >= max_arity then
|
|
|
- [ alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic), None ]
|
|
|
- else func_args_i arity
|
|
|
- in
|
|
|
-
|
|
|
- let func_sig_i i =
|
|
|
- let rec loop i acc =
|
|
|
- if i = 0 then acc else begin
|
|
|
- let vfloat = gen.gmk_internal_name "fn" ("float" ^ string_of_int i) in
|
|
|
- let vdyn = gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i) in
|
|
|
-
|
|
|
- loop (i - 1) ( (vfloat,false,basic.tfloat) :: (vdyn,false,t_dynamic) :: acc )
|
|
|
- end
|
|
|
- in
|
|
|
- loop i []
|
|
|
- in
|
|
|
-
|
|
|
- let args_real_to_func_sig args =
|
|
|
- let arity = List.length args in
|
|
|
- if arity >= max_arity then
|
|
|
- [gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic]
|
|
|
- else begin
|
|
|
- func_sig_i arity
|
|
|
- end
|
|
|
- in
|
|
|
-
|
|
|
- let rettype_real_to_func t = match run_follow gen t with
|
|
|
- | TType({ t_path = [],"Null" }, _) ->
|
|
|
- 0,t_dynamic
|
|
|
- | _ when like_float t && not (like_i64 t) ->
|
|
|
- (1, basic.tfloat)
|
|
|
- | _ ->
|
|
|
- (0, t_dynamic)
|
|
|
- in
|
|
|
-
|
|
|
- let args_real_to_func_call el (pos:pos) =
|
|
|
- if List.length el >= max_arity then
|
|
|
- [{ eexpr = TArrayDecl el; etype = basic.tarray t_dynamic; epos = pos }]
|
|
|
- else begin
|
|
|
- List.fold_left (fun acc e ->
|
|
|
- if like_float (gen.greal_type e.etype) && not (like_i64 (gen.greal_type e.etype)) then
|
|
|
- ( e :: undefined e.epos :: acc )
|
|
|
- else
|
|
|
- ( null basic.tfloat e.epos :: e :: acc )
|
|
|
- ) ([]) (List.rev el)
|
|
|
- end
|
|
|
- in
|
|
|
-
|
|
|
- let const_type c def =
|
|
|
- match c with
|
|
|
- | TString _ -> basic.tstring
|
|
|
- | TInt _ -> basic.tint
|
|
|
- | TFloat _ -> basic.tfloat
|
|
|
- | TBool _ -> basic.tbool
|
|
|
- | _ -> def
|
|
|
- in
|
|
|
-
|
|
|
- let get_args_func args changed_args pos =
|
|
|
- let arity = List.length args in
|
|
|
- let mk_const const elocal t =
|
|
|
- match const with
|
|
|
- | None ->
|
|
|
- mk_cast t elocal
|
|
|
- | Some const ->
|
|
|
- { eexpr = TIf(
|
|
|
- { elocal with eexpr = TBinop(Ast.OpEq, elocal, null elocal.etype elocal.epos); etype = basic.tbool },
|
|
|
- { elocal with eexpr = TConst(const); etype = const_type const t },
|
|
|
- Some ( mk_cast t elocal )
|
|
|
- ); etype = t; epos = elocal.epos }
|
|
|
- in
|
|
|
-
|
|
|
- if arity >= max_arity then begin
|
|
|
- let varray = match changed_args with | [v,_] -> v | _ -> assert false in
|
|
|
- let varray_local = mk_local varray pos in
|
|
|
- let mk_varray i = { eexpr = TArray(varray_local, { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }); etype = t_dynamic; epos = pos } in
|
|
|
-
|
|
|
- snd (List.fold_left (fun (count,acc) (v,const) ->
|
|
|
- (count + 1, (mk (TVar(v, Some(mk_const const (mk_varray count) v.v_type))) basic.tvoid pos) :: acc)
|
|
|
- ) (0,[]) args)
|
|
|
- end else begin
|
|
|
- let _, dyn_args, float_args = List.fold_left (fun (count,fargs, dargs) arg ->
|
|
|
- if count land 1 = 0 then
|
|
|
- (count + 1, fargs, arg :: dargs)
|
|
|
- else
|
|
|
- (count + 1, arg :: fargs, dargs)
|
|
|
- ) (1,[],[]) (List.rev changed_args) in
|
|
|
-
|
|
|
- let rec loop acc args fargs dargs =
|
|
|
- match args, fargs, dargs with
|
|
|
- | [], [], [] -> acc
|
|
|
- | (v,const) :: args, (vf,_) :: fargs, (vd,_) :: dargs ->
|
|
|
- let acc = { eexpr = TVar(v, Some(
|
|
|
- {
|
|
|
- eexpr = TIf(
|
|
|
- { eexpr = TBinop(Ast.OpEq, mk_local vd pos, undefined pos); etype = basic.tbool; epos = pos },
|
|
|
- mk_cast v.v_type (mk_local vf pos),
|
|
|
- Some ( mk_const const (mk_local vd pos) v.v_type )
|
|
|
- );
|
|
|
- etype = v.v_type;
|
|
|
- epos = pos
|
|
|
- } )); etype = basic.tvoid; epos = pos } :: acc in
|
|
|
- loop acc args fargs dargs
|
|
|
- | _ -> assert false
|
|
|
- in
|
|
|
-
|
|
|
- loop [] args float_args dyn_args
|
|
|
- end
|
|
|
- in
|
|
|
-
|
|
|
- let closure_to_classfield tfunc old_sig pos =
|
|
|
- (* change function signature *)
|
|
|
- let old_args = tfunc.tf_args in
|
|
|
- let changed_args = args_real_to_func old_args in
|
|
|
-
|
|
|
- (*
|
|
|
- FIXME properly handle int64 cases, which will break here (because of inference to int)
|
|
|
- UPDATE: the fix will be that Int64 won't be a typedef to Float/Int
|
|
|
- *)
|
|
|
- let changed_sig, arity, type_number, changed_sig_ret, is_void, is_dynamic_func = match follow old_sig with
|
|
|
- | TFun(_sig, ret) ->
|
|
|
- let type_n, ret_t = rettype_real_to_func ret in
|
|
|
- let arity = List.length _sig in
|
|
|
- let is_dynamic_func = arity >= max_arity in
|
|
|
- let ret_t = if is_dynamic_func then t_dynamic else ret_t in
|
|
|
-
|
|
|
- (TFun(args_real_to_func_sig _sig, ret_t), arity, type_n, ret_t, ExtType.is_void ret, is_dynamic_func)
|
|
|
- | _ -> (print_endline (s_type (print_context()) (follow old_sig) )); assert false
|
|
|
- in
|
|
|
-
|
|
|
- let tf_expr = if is_void then begin
|
|
|
- let rec map e =
|
|
|
- match e.eexpr with
|
|
|
- | TReturn None -> { e with eexpr = TReturn (Some (null t_dynamic e.epos)) }
|
|
|
- | _ -> Type.map_expr map e
|
|
|
- in
|
|
|
- let e = mk_block (map tfunc.tf_expr) in
|
|
|
- match e.eexpr with
|
|
|
- | TBlock(bl) ->
|
|
|
- { e with eexpr = TBlock(bl @ [{ eexpr = TReturn (Some (null t_dynamic e.epos)); etype = t_dynamic; epos = e.epos }]) }
|
|
|
- | _ -> assert false
|
|
|
- end else tfunc.tf_expr in
|
|
|
-
|
|
|
- let changed_sig_ret = if is_dynamic_func then t_dynamic else changed_sig_ret in
|
|
|
-
|
|
|
- (* get real arguments on top of function body *)
|
|
|
- let get_args = get_args_func tfunc.tf_args changed_args pos in
|
|
|
- (*
|
|
|
- FIXME HACK: in order to be able to run the filters that have already ran for this piece of code,
|
|
|
- we will cheat and run it as if it was the whole code
|
|
|
- We could just make ClosuresToClass run before TArrayTransform, but we cannot because of the
|
|
|
- dependency between ClosuresToClass (after DynamicFieldAccess, and before TArrayTransform)
|
|
|
-
|
|
|
- maybe a way to solve this would be to add an "until" field to run_from
|
|
|
- *)
|
|
|
- let real_get_args = gen.gexpr_filters#run_f { eexpr = TBlock(get_args); etype = basic.tvoid; epos = pos } in
|
|
|
-
|
|
|
- let func_expr = Type.concat real_get_args tf_expr in
|
|
|
-
|
|
|
- (* set invoke function *)
|
|
|
- (* todo properly abstract how naming for invoke is made *)
|
|
|
- let invoke_name = if is_dynamic_func then "invokeDynamic" else ("invoke" ^ (string_of_int arity) ^ (if type_number = 0 then "_o" else "_f")) in
|
|
|
- let invoke_name = gen.gmk_internal_name "hx" invoke_name in
|
|
|
- let invoke_field = mk_class_field invoke_name changed_sig false func_expr.epos (Method(MethNormal)) [] in
|
|
|
- let invoke_fun = {
|
|
|
- eexpr = TFunction {
|
|
|
- tf_args = changed_args;
|
|
|
- tf_type = changed_sig_ret;
|
|
|
- tf_expr = func_expr;
|
|
|
- };
|
|
|
- etype = changed_sig;
|
|
|
- epos = func_expr.epos;
|
|
|
- } in
|
|
|
- invoke_field.cf_expr <- Some invoke_fun;
|
|
|
-
|
|
|
- invoke_field, [
|
|
|
- ExprBuilder.make_int gen.gcon arity pos;
|
|
|
- ExprBuilder.make_int gen.gcon type_number pos;
|
|
|
- ]
|
|
|
- in
|
|
|
-
|
|
|
- let dynamic_fun_call call_expr =
|
|
|
- let tc, params = match call_expr.eexpr with
|
|
|
- | TCall(tc, params) -> tc, params
|
|
|
- | _ -> assert false
|
|
|
- in
|
|
|
- let ct = gen.greal_type call_expr.etype in
|
|
|
- let postfix, ret_t =
|
|
|
- if like_float ct && not (like_i64 ct) then
|
|
|
- "_f", gen.gcon.basic.tfloat
|
|
|
- else
|
|
|
- "_o", t_dynamic
|
|
|
- in
|
|
|
- let params_len = List.length params in
|
|
|
- let ret_t = if params_len >= max_arity then t_dynamic else ret_t in
|
|
|
-
|
|
|
- let invoke_fun = if params_len >= max_arity then "invokeDynamic" else "invoke" ^ (string_of_int params_len) ^ postfix in
|
|
|
- let invoke_fun = gen.gmk_internal_name "hx" invoke_fun in
|
|
|
- let fun_t = match follow tc.etype with
|
|
|
- | TFun(_sig, _) ->
|
|
|
- TFun(args_real_to_func_sig _sig, ret_t)
|
|
|
- | _ ->
|
|
|
- let i = ref 0 in
|
|
|
- let _sig = List.map (fun p -> let name = "arg" ^ (string_of_int !i) in incr i; (name,false,p.etype) ) params in
|
|
|
- TFun(args_real_to_func_sig _sig, ret_t)
|
|
|
- in
|
|
|
-
|
|
|
- let may_cast = match follow call_expr.etype with
|
|
|
- | TAbstract ({ a_path = ([], "Void") },[]) -> (fun e -> e)
|
|
|
- | _ -> mk_cast call_expr.etype
|
|
|
- in
|
|
|
-
|
|
|
- may_cast
|
|
|
- {
|
|
|
- eexpr = TCall(
|
|
|
- { (mk_field_access gen { tc with etype = gen.greal_type tc.etype } invoke_fun tc.epos) with etype = fun_t },
|
|
|
- args_real_to_func_call params call_expr.epos
|
|
|
- );
|
|
|
- etype = ret_t;
|
|
|
- epos = call_expr.epos
|
|
|
- }
|
|
|
- in
|
|
|
-
|
|
|
- let iname i is_float =
|
|
|
- let postfix = if is_float then "_f" else "_o" in
|
|
|
- gen.gmk_internal_name "hx" ("invoke" ^ string_of_int i) ^ postfix
|
|
|
- in
|
|
|
-
|
|
|
- let map_base_classfields cl map_fn =
|
|
|
- let pos = cl.cl_pos in
|
|
|
- let this_t = TInst(cl,List.map snd cl.cl_params) in
|
|
|
- let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
|
|
|
- let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
|
|
|
-
|
|
|
- let mk_invoke_i i is_float =
|
|
|
- let cf = mk_class_field (iname i is_float) (TFun(func_sig_i i, if is_float then basic.tfloat else t_dynamic)) false pos (Method MethNormal) [] in
|
|
|
- cf
|
|
|
- in
|
|
|
-
|
|
|
- let type_name = gen.gmk_internal_name "fn" "type" in
|
|
|
- let dynamic_arg = alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic) in
|
|
|
-
|
|
|
- let mk_invoke_complete_i i is_float =
|
|
|
-
|
|
|
- (* let arity = i in *)
|
|
|
- let args = func_args_i i in
|
|
|
-
|
|
|
- (* api fn *)
|
|
|
-
|
|
|
- (* only cast if needed *)
|
|
|
- let mk_cast tto efrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type efrom.etype) efrom in
|
|
|
- let api i t const =
|
|
|
- let vf, _ = List.nth args (i * 2) in
|
|
|
- let vo, _ = List.nth args (i * 2 + 1) in
|
|
|
-
|
|
|
- let needs_cast, is_float = match t, like_float t && not (like_i64 t) with
|
|
|
- | TAbstract({ a_path = ([], "Float") },[]), _ -> false, true
|
|
|
- | _, true -> true, true
|
|
|
- | _ -> false,false
|
|
|
- in
|
|
|
-
|
|
|
- let olocal = mk_local vo pos in
|
|
|
- let flocal = mk_local vf pos in
|
|
|
-
|
|
|
- let get_from_obj e = match const with
|
|
|
- | None -> mk_cast t e
|
|
|
- | Some tc ->
|
|
|
- {
|
|
|
- eexpr = TIf(
|
|
|
- { eexpr = TBinop(Ast.OpEq, olocal, null t_dynamic pos); etype = basic.tbool; epos = pos } ,
|
|
|
- { eexpr = TConst(tc); etype = t; epos = pos },
|
|
|
- Some (mk_cast t e)
|
|
|
- );
|
|
|
- etype = t;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- in
|
|
|
-
|
|
|
- {
|
|
|
- eexpr = TIf(
|
|
|
- { eexpr = TBinop(Ast.OpEq, olocal, undefined pos); etype = basic.tbool; epos = pos },
|
|
|
- (if needs_cast then mk_cast t flocal else flocal),
|
|
|
- Some ( get_from_obj olocal )
|
|
|
- );
|
|
|
- etype = t;
|
|
|
- epos = pos
|
|
|
- }
|
|
|
- in
|
|
|
- (* end of api fn *)
|
|
|
-
|
|
|
- let ret = if is_float then basic.tfloat else t_dynamic in
|
|
|
-
|
|
|
- let fn_expr = map_fn i ret (List.map fst args) api in
|
|
|
-
|
|
|
- let t = TFun(fun_args args, ret) in
|
|
|
-
|
|
|
- let tfunction =
|
|
|
- {
|
|
|
- eexpr = TFunction({
|
|
|
- tf_args = args;
|
|
|
- tf_type = ret;
|
|
|
- tf_expr =
|
|
|
- mk_block fn_expr
|
|
|
- });
|
|
|
- etype = t;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- in
|
|
|
-
|
|
|
- let cf = mk_invoke_i i is_float in
|
|
|
- cf.cf_expr <- Some tfunction;
|
|
|
- cf
|
|
|
- in
|
|
|
-
|
|
|
- let rec loop i cfs =
|
|
|
- if i < 0 then cfs else begin
|
|
|
- (*let mk_invoke_complete_i i is_float =*)
|
|
|
- (mk_invoke_complete_i i false) :: (mk_invoke_complete_i i true) :: (loop (i-1) cfs)
|
|
|
- end
|
|
|
- in
|
|
|
-
|
|
|
- let cfs = loop max_arity [] in
|
|
|
-
|
|
|
- let switch =
|
|
|
- let api i t const =
|
|
|
- match i with
|
|
|
- | -1 ->
|
|
|
- mk_local dynamic_arg pos
|
|
|
- | _ ->
|
|
|
- mk_cast t {
|
|
|
- eexpr = TArray(
|
|
|
- mk_local dynamic_arg pos,
|
|
|
- { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos });
|
|
|
- etype = t;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- in
|
|
|
- map_fn (-1) t_dynamic [dynamic_arg] api
|
|
|
- in
|
|
|
-
|
|
|
- let args = [dynamic_arg, None] in
|
|
|
- let dyn_t = TFun(fun_args args, t_dynamic) in
|
|
|
- let dyn_cf = mk_class_field (gen.gmk_internal_name "hx" "invokeDynamic") dyn_t false pos (Method MethNormal) [] in
|
|
|
-
|
|
|
- dyn_cf.cf_expr <- Some {
|
|
|
- eexpr = TFunction {
|
|
|
- tf_args = args;
|
|
|
- tf_type = t_dynamic;
|
|
|
- tf_expr = mk_block switch
|
|
|
- };
|
|
|
- etype = dyn_t;
|
|
|
- epos = pos;
|
|
|
- };
|
|
|
-
|
|
|
- let additional_cfs = begin
|
|
|
- let new_t = TFun(["arity", false, basic.tint; "type", false, basic.tint],basic.tvoid) in
|
|
|
- let new_cf = mk_class_field "new" (new_t) true pos (Method MethNormal) [] in
|
|
|
- let v_arity, v_type = alloc_var "arity" basic.tint, alloc_var "type" basic.tint in
|
|
|
- let mk_assign v field = mk (TBinop (OpAssign, mk_this field v.v_type, mk_local v pos)) v.v_type pos in
|
|
|
-
|
|
|
- let arity_name = gen.gmk_internal_name "hx" "arity" in
|
|
|
- new_cf.cf_expr <- Some {
|
|
|
- eexpr = TFunction({
|
|
|
- tf_args = [v_arity, None; v_type, None];
|
|
|
- tf_type = basic.tvoid;
|
|
|
- tf_expr =
|
|
|
- {
|
|
|
- eexpr = TBlock([
|
|
|
- mk_assign v_type type_name;
|
|
|
- mk_assign v_arity arity_name
|
|
|
- ]);
|
|
|
- etype = basic.tvoid;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- });
|
|
|
- etype = new_t;
|
|
|
- epos = pos;
|
|
|
- };
|
|
|
-
|
|
|
- [
|
|
|
- new_cf;
|
|
|
- mk_class_field type_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
|
|
|
- mk_class_field arity_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
|
|
|
- ]
|
|
|
- end in
|
|
|
-
|
|
|
- dyn_cf :: (additional_cfs @ cfs)
|
|
|
- in
|
|
|
-
|
|
|
- begin
|
|
|
- (*
|
|
|
- setup fields for the abstract implementation of the Function class
|
|
|
-
|
|
|
- new(arity, type)
|
|
|
- {
|
|
|
- this.arity = arity;
|
|
|
- this.type = type;
|
|
|
- }
|
|
|
-
|
|
|
- hx::invokeX_f|o (where X is from 0 to max_arity) (args)
|
|
|
- {
|
|
|
- if (this.type == 0|1) return invokeX_o|f(args); else throw "Invalid number of arguments."
|
|
|
- }
|
|
|
-
|
|
|
- hx::invokeDynamic, which will work in the same way
|
|
|
- *)
|
|
|
- let cl = parent_func_class in
|
|
|
- let pos = cl.cl_pos in
|
|
|
-
|
|
|
- let rec mk_dyn_call arity api =
|
|
|
- let zero = ExprBuilder.make_float gen.gcon "0.0" pos in
|
|
|
- let rec loop i acc =
|
|
|
- if i = 0 then
|
|
|
- acc
|
|
|
- else begin
|
|
|
- let arr = api (i - 1) t_dynamic None in
|
|
|
- loop (i - 1) (zero :: arr :: acc)
|
|
|
- end
|
|
|
- in
|
|
|
- loop arity []
|
|
|
- in
|
|
|
-
|
|
|
- let this = mk (TConst TThis) (TInst (cl, List.map snd cl.cl_params)) pos in
|
|
|
- let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
|
|
|
-
|
|
|
- let mk_invoke_switch i api =
|
|
|
- let t = TFun (func_sig_i i, t_dynamic) in
|
|
|
- (* case i: return this.invokeX_o(0, 0, 0, 0, 0, ... arg[0], args[1]....); *)
|
|
|
- [ExprBuilder.make_int gen.gcon i pos], mk_return (mk (TCall(mk_this (iname i false) t, mk_dyn_call i api)) t_dynamic pos)
|
|
|
- in
|
|
|
- let rec loop_cases api arity acc =
|
|
|
- if arity < 0 then
|
|
|
- acc
|
|
|
- else
|
|
|
- loop_cases api (arity - 1) (mk_invoke_switch arity api :: acc)
|
|
|
- in
|
|
|
-
|
|
|
- let type_name = gen.gmk_internal_name "fn" "type" in
|
|
|
- let mk_expr i is_float vars =
|
|
|
- let call_expr =
|
|
|
- let call_t = TFun(List.map (fun v -> (v.v_name, false, v.v_type)) vars, if is_float then t_dynamic else basic.tfloat) in
|
|
|
- {
|
|
|
- eexpr = TCall(mk_this (iname i (not is_float)) call_t, List.map (fun v -> mk_local v pos) vars);
|
|
|
- etype = if is_float then t_dynamic else basic.tfloat;
|
|
|
- epos = pos
|
|
|
- }
|
|
|
- in
|
|
|
- {
|
|
|
- eexpr = TIf(
|
|
|
- mk (TBinop (Ast.OpNotEq, mk_this type_name basic.tint, (ExprBuilder.make_int gen.gcon (if is_float then 0 else 1) pos))) basic.tbool pos,
|
|
|
- mk (TThrow (ExprBuilder.make_string gen.gcon "Wrong number of arguments" pos)) t_dynamic pos,
|
|
|
- Some (mk_return call_expr)
|
|
|
- );
|
|
|
- etype = t_dynamic;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- in
|
|
|
-
|
|
|
- let arities_processed = Hashtbl.create 10 in
|
|
|
- let max_arity = ref 0 in
|
|
|
-
|
|
|
- let map_fn cur_arity fun_ret_type vars (api:int->t->tconstant option->texpr) =
|
|
|
- let is_float = like_float fun_ret_type && not (like_i64 fun_ret_type) in
|
|
|
- match cur_arity with
|
|
|
- | -1 ->
|
|
|
- let dynargs = api (-1) t_dynamic None in
|
|
|
-
|
|
|
- (* (dynargs == null) ? 0 : dynargs.length *)
|
|
|
- let switch_cond = {
|
|
|
- eexpr = TIf(
|
|
|
- mk (TBinop (OpEq, dynargs, null dynargs.etype pos)) basic.tbool pos,
|
|
|
- mk (TConst (TInt Int32.zero)) basic.tint pos,
|
|
|
- Some (mk_field_access gen dynargs "length" pos));
|
|
|
- etype = basic.tint;
|
|
|
- epos = pos;
|
|
|
- } in
|
|
|
-
|
|
|
- {
|
|
|
- eexpr = TSwitch(
|
|
|
- switch_cond,
|
|
|
- loop_cases api !max_arity [],
|
|
|
- Some(mk (TThrow (ExprBuilder.make_string gen.gcon "Too many arguments" pos)) basic.tvoid pos));
|
|
|
- etype = basic.tvoid;
|
|
|
- epos = pos;
|
|
|
- }
|
|
|
- | _ ->
|
|
|
- if not (Hashtbl.mem arities_processed cur_arity) then begin
|
|
|
- Hashtbl.add arities_processed cur_arity true;
|
|
|
- if cur_arity > !max_arity then max_arity := cur_arity
|
|
|
- end;
|
|
|
-
|
|
|
- mk_expr cur_arity is_float vars
|
|
|
- in
|
|
|
-
|
|
|
- let cfs = map_base_classfields cl map_fn in
|
|
|
- List.iter (fun cf ->
|
|
|
- if cf.cf_name = "new" then
|
|
|
- parent_func_class.cl_constructor <- Some cf
|
|
|
- else
|
|
|
- parent_func_class.cl_fields <- PMap.add cf.cf_name cf parent_func_class.cl_fields
|
|
|
- ) cfs;
|
|
|
- parent_func_class.cl_ordered_fields <- (List.filter (fun cf -> cf.cf_name <> "new") cfs) @ parent_func_class.cl_ordered_fields
|
|
|
- end;
|
|
|
-
|
|
|
- {
|
|
|
- func_class = parent_func_class;
|
|
|
- closure_to_classfield = closure_to_classfield;
|
|
|
- dynamic_fun_call = dynamic_fun_call;
|
|
|
- map_base_classfields = map_base_classfields;
|
|
|
- }
|
|
|
+ let get_ctx gen parent_func_class max_arity (* e.g. new haxe.lang.ClassClosure *) =
|
|
|
+ let basic = gen.gcon.basic in
|
|
|
+
|
|
|
+ let func_args_i i =
|
|
|
+ let rec loop i (acc) =
|
|
|
+ if i = 0 then (acc) else begin
|
|
|
+ let vfloat = alloc_var (gen.gmk_internal_name "fn" ("float" ^ string_of_int i)) basic.tfloat in
|
|
|
+ let vdyn = alloc_var (gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i)) t_dynamic in
|
|
|
+
|
|
|
+ loop (i - 1) ((vfloat, None) :: (vdyn, None) :: acc)
|
|
|
+ end
|
|
|
+ in
|
|
|
+ loop i []
|
|
|
+ in
|
|
|
+
|
|
|
+ let args_real_to_func args =
|
|
|
+ let arity = List.length args in
|
|
|
+ if arity >= max_arity then
|
|
|
+ [ alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic), None ]
|
|
|
+ else func_args_i arity
|
|
|
+ in
|
|
|
+
|
|
|
+ let func_sig_i i =
|
|
|
+ let rec loop i acc =
|
|
|
+ if i = 0 then acc else begin
|
|
|
+ let vfloat = gen.gmk_internal_name "fn" ("float" ^ string_of_int i) in
|
|
|
+ let vdyn = gen.gmk_internal_name "fn" ("dyn" ^ string_of_int i) in
|
|
|
+
|
|
|
+ loop (i - 1) ( (vfloat,false,basic.tfloat) :: (vdyn,false,t_dynamic) :: acc )
|
|
|
+ end
|
|
|
+ in
|
|
|
+ loop i []
|
|
|
+ in
|
|
|
+
|
|
|
+ let args_real_to_func_sig args =
|
|
|
+ let arity = List.length args in
|
|
|
+ if arity >= max_arity then
|
|
|
+ [gen.gmk_internal_name "fn" "dynargs", false, basic.tarray t_dynamic]
|
|
|
+ else begin
|
|
|
+ func_sig_i arity
|
|
|
+ end
|
|
|
+ in
|
|
|
+
|
|
|
+ let rettype_real_to_func t = match run_follow gen t with
|
|
|
+ | TType({ t_path = [],"Null" }, _) ->
|
|
|
+ 0,t_dynamic
|
|
|
+ | _ when like_float t && not (like_i64 t) ->
|
|
|
+ (1, basic.tfloat)
|
|
|
+ | _ ->
|
|
|
+ (0, t_dynamic)
|
|
|
+ in
|
|
|
+
|
|
|
+ let args_real_to_func_call el (pos:pos) =
|
|
|
+ if List.length el >= max_arity then
|
|
|
+ [{ eexpr = TArrayDecl el; etype = basic.tarray t_dynamic; epos = pos }]
|
|
|
+ else begin
|
|
|
+ List.fold_left (fun acc e ->
|
|
|
+ if like_float (gen.greal_type e.etype) && not (like_i64 (gen.greal_type e.etype)) then
|
|
|
+ ( e :: undefined e.epos :: acc )
|
|
|
+ else
|
|
|
+ ( null basic.tfloat e.epos :: e :: acc )
|
|
|
+ ) ([]) (List.rev el)
|
|
|
+ end
|
|
|
+ in
|
|
|
+
|
|
|
+ let const_type c def =
|
|
|
+ match c with
|
|
|
+ | TString _ -> basic.tstring
|
|
|
+ | TInt _ -> basic.tint
|
|
|
+ | TFloat _ -> basic.tfloat
|
|
|
+ | TBool _ -> basic.tbool
|
|
|
+ | _ -> def
|
|
|
+ in
|
|
|
+
|
|
|
+ let get_args_func args changed_args pos =
|
|
|
+ let arity = List.length args in
|
|
|
+ let mk_const const elocal t =
|
|
|
+ match const with
|
|
|
+ | None ->
|
|
|
+ mk_cast t elocal
|
|
|
+ | Some const ->
|
|
|
+ { eexpr = TIf(
|
|
|
+ { elocal with eexpr = TBinop(Ast.OpEq, elocal, null elocal.etype elocal.epos); etype = basic.tbool },
|
|
|
+ { elocal with eexpr = TConst(const); etype = const_type const t },
|
|
|
+ Some ( mk_cast t elocal )
|
|
|
+ ); etype = t; epos = elocal.epos }
|
|
|
+ in
|
|
|
+
|
|
|
+ if arity >= max_arity then begin
|
|
|
+ let varray = match changed_args with | [v,_] -> v | _ -> assert false in
|
|
|
+ let varray_local = mk_local varray pos in
|
|
|
+ let mk_varray i = { eexpr = TArray(varray_local, { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos }); etype = t_dynamic; epos = pos } in
|
|
|
+
|
|
|
+ snd (List.fold_left (fun (count,acc) (v,const) ->
|
|
|
+ (count + 1, (mk (TVar(v, Some(mk_const const (mk_varray count) v.v_type))) basic.tvoid pos) :: acc)
|
|
|
+ ) (0,[]) args)
|
|
|
+ end else begin
|
|
|
+ let _, dyn_args, float_args = List.fold_left (fun (count,fargs, dargs) arg ->
|
|
|
+ if count land 1 = 0 then
|
|
|
+ (count + 1, fargs, arg :: dargs)
|
|
|
+ else
|
|
|
+ (count + 1, arg :: fargs, dargs)
|
|
|
+ ) (1,[],[]) (List.rev changed_args) in
|
|
|
+
|
|
|
+ let rec loop acc args fargs dargs =
|
|
|
+ match args, fargs, dargs with
|
|
|
+ | [], [], [] -> acc
|
|
|
+ | (v,const) :: args, (vf,_) :: fargs, (vd,_) :: dargs ->
|
|
|
+ let acc = { eexpr = TVar(v, Some(
|
|
|
+ {
|
|
|
+ eexpr = TIf(
|
|
|
+ { eexpr = TBinop(Ast.OpEq, mk_local vd pos, undefined pos); etype = basic.tbool; epos = pos },
|
|
|
+ mk_cast v.v_type (mk_local vf pos),
|
|
|
+ Some ( mk_const const (mk_local vd pos) v.v_type )
|
|
|
+ );
|
|
|
+ etype = v.v_type;
|
|
|
+ epos = pos
|
|
|
+ } )); etype = basic.tvoid; epos = pos } :: acc in
|
|
|
+ loop acc args fargs dargs
|
|
|
+ | _ -> assert false
|
|
|
+ in
|
|
|
+
|
|
|
+ loop [] args float_args dyn_args
|
|
|
+ end
|
|
|
+ in
|
|
|
+
|
|
|
+ let closure_to_classfield tfunc old_sig pos =
|
|
|
+ (* change function signature *)
|
|
|
+ let old_args = tfunc.tf_args in
|
|
|
+ let changed_args = args_real_to_func old_args in
|
|
|
+
|
|
|
+ (*
|
|
|
+ FIXME properly handle int64 cases, which will break here (because of inference to int)
|
|
|
+ UPDATE: the fix will be that Int64 won't be a typedef to Float/Int
|
|
|
+ *)
|
|
|
+ let changed_sig, arity, type_number, changed_sig_ret, is_void, is_dynamic_func = match follow old_sig with
|
|
|
+ | TFun(_sig, ret) ->
|
|
|
+ let type_n, ret_t = rettype_real_to_func ret in
|
|
|
+ let arity = List.length _sig in
|
|
|
+ let is_dynamic_func = arity >= max_arity in
|
|
|
+ let ret_t = if is_dynamic_func then t_dynamic else ret_t in
|
|
|
+
|
|
|
+ (TFun(args_real_to_func_sig _sig, ret_t), arity, type_n, ret_t, ExtType.is_void ret, is_dynamic_func)
|
|
|
+ | _ -> (print_endline (s_type (print_context()) (follow old_sig) )); assert false
|
|
|
+ in
|
|
|
+
|
|
|
+ let tf_expr = if is_void then begin
|
|
|
+ let rec map e =
|
|
|
+ match e.eexpr with
|
|
|
+ | TReturn None -> { e with eexpr = TReturn (Some (null t_dynamic e.epos)) }
|
|
|
+ | _ -> Type.map_expr map e
|
|
|
+ in
|
|
|
+ let e = mk_block (map tfunc.tf_expr) in
|
|
|
+ match e.eexpr with
|
|
|
+ | TBlock(bl) ->
|
|
|
+ { e with eexpr = TBlock(bl @ [{ eexpr = TReturn (Some (null t_dynamic e.epos)); etype = t_dynamic; epos = e.epos }]) }
|
|
|
+ | _ -> assert false
|
|
|
+ end else tfunc.tf_expr in
|
|
|
+
|
|
|
+ let changed_sig_ret = if is_dynamic_func then t_dynamic else changed_sig_ret in
|
|
|
+
|
|
|
+ (* get real arguments on top of function body *)
|
|
|
+ let get_args = get_args_func tfunc.tf_args changed_args pos in
|
|
|
+ (*
|
|
|
+ FIXME HACK: in order to be able to run the filters that have already ran for this piece of code,
|
|
|
+ we will cheat and run it as if it was the whole code
|
|
|
+ We could just make ClosuresToClass run before TArrayTransform, but we cannot because of the
|
|
|
+ dependency between ClosuresToClass (after DynamicFieldAccess, and before TArrayTransform)
|
|
|
+
|
|
|
+ maybe a way to solve this would be to add an "until" field to run_from
|
|
|
+ *)
|
|
|
+ let real_get_args = gen.gexpr_filters#run_f { eexpr = TBlock(get_args); etype = basic.tvoid; epos = pos } in
|
|
|
+
|
|
|
+ let func_expr = Type.concat real_get_args tf_expr in
|
|
|
+
|
|
|
+ (* set invoke function *)
|
|
|
+ (* todo properly abstract how naming for invoke is made *)
|
|
|
+ let invoke_name = if is_dynamic_func then "invokeDynamic" else ("invoke" ^ (string_of_int arity) ^ (if type_number = 0 then "_o" else "_f")) in
|
|
|
+ let invoke_name = gen.gmk_internal_name "hx" invoke_name in
|
|
|
+ let invoke_field = mk_class_field invoke_name changed_sig false func_expr.epos (Method(MethNormal)) [] in
|
|
|
+ let invoke_fun = {
|
|
|
+ eexpr = TFunction {
|
|
|
+ tf_args = changed_args;
|
|
|
+ tf_type = changed_sig_ret;
|
|
|
+ tf_expr = func_expr;
|
|
|
+ };
|
|
|
+ etype = changed_sig;
|
|
|
+ epos = func_expr.epos;
|
|
|
+ } in
|
|
|
+ invoke_field.cf_expr <- Some invoke_fun;
|
|
|
+
|
|
|
+ invoke_field, [
|
|
|
+ ExprBuilder.make_int gen.gcon arity pos;
|
|
|
+ ExprBuilder.make_int gen.gcon type_number pos;
|
|
|
+ ]
|
|
|
+ in
|
|
|
+
|
|
|
+ let dynamic_fun_call call_expr =
|
|
|
+ let tc, params = match call_expr.eexpr with
|
|
|
+ | TCall(tc, params) -> tc, params
|
|
|
+ | _ -> assert false
|
|
|
+ in
|
|
|
+ let ct = gen.greal_type call_expr.etype in
|
|
|
+ let postfix, ret_t =
|
|
|
+ if like_float ct && not (like_i64 ct) then
|
|
|
+ "_f", gen.gcon.basic.tfloat
|
|
|
+ else
|
|
|
+ "_o", t_dynamic
|
|
|
+ in
|
|
|
+ let params_len = List.length params in
|
|
|
+ let ret_t = if params_len >= max_arity then t_dynamic else ret_t in
|
|
|
+
|
|
|
+ let invoke_fun = if params_len >= max_arity then "invokeDynamic" else "invoke" ^ (string_of_int params_len) ^ postfix in
|
|
|
+ let invoke_fun = gen.gmk_internal_name "hx" invoke_fun in
|
|
|
+ let fun_t = match follow tc.etype with
|
|
|
+ | TFun(_sig, _) ->
|
|
|
+ TFun(args_real_to_func_sig _sig, ret_t)
|
|
|
+ | _ ->
|
|
|
+ let i = ref 0 in
|
|
|
+ let _sig = List.map (fun p -> let name = "arg" ^ (string_of_int !i) in incr i; (name,false,p.etype) ) params in
|
|
|
+ TFun(args_real_to_func_sig _sig, ret_t)
|
|
|
+ in
|
|
|
+
|
|
|
+ let may_cast = match follow call_expr.etype with
|
|
|
+ | TAbstract ({ a_path = ([], "Void") },[]) -> (fun e -> e)
|
|
|
+ | _ -> mk_cast call_expr.etype
|
|
|
+ in
|
|
|
+
|
|
|
+ may_cast
|
|
|
+ {
|
|
|
+ eexpr = TCall(
|
|
|
+ { (mk_field_access gen { tc with etype = gen.greal_type tc.etype } invoke_fun tc.epos) with etype = fun_t },
|
|
|
+ args_real_to_func_call params call_expr.epos
|
|
|
+ );
|
|
|
+ etype = ret_t;
|
|
|
+ epos = call_expr.epos
|
|
|
+ }
|
|
|
+ in
|
|
|
+
|
|
|
+ let iname i is_float =
|
|
|
+ let postfix = if is_float then "_f" else "_o" in
|
|
|
+ gen.gmk_internal_name "hx" ("invoke" ^ string_of_int i) ^ postfix
|
|
|
+ in
|
|
|
+
|
|
|
+ let map_base_classfields cl map_fn =
|
|
|
+ let pos = cl.cl_pos in
|
|
|
+ let this_t = TInst(cl,List.map snd cl.cl_params) in
|
|
|
+ let this = { eexpr = TConst(TThis); etype = this_t; epos = pos } in
|
|
|
+ let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
|
|
|
+
|
|
|
+ let mk_invoke_i i is_float =
|
|
|
+ let cf = mk_class_field (iname i is_float) (TFun(func_sig_i i, if is_float then basic.tfloat else t_dynamic)) false pos (Method MethNormal) [] in
|
|
|
+ cf
|
|
|
+ in
|
|
|
+
|
|
|
+ let type_name = gen.gmk_internal_name "fn" "type" in
|
|
|
+ let dynamic_arg = alloc_var (gen.gmk_internal_name "fn" "dynargs") (basic.tarray t_dynamic) in
|
|
|
+
|
|
|
+ let mk_invoke_complete_i i is_float =
|
|
|
+
|
|
|
+ (* let arity = i in *)
|
|
|
+ let args = func_args_i i in
|
|
|
+
|
|
|
+ (* api fn *)
|
|
|
+
|
|
|
+ (* only cast if needed *)
|
|
|
+ let mk_cast tto efrom = gen.ghandle_cast (gen.greal_type tto) (gen.greal_type efrom.etype) efrom in
|
|
|
+ let api i t const =
|
|
|
+ let vf, _ = List.nth args (i * 2) in
|
|
|
+ let vo, _ = List.nth args (i * 2 + 1) in
|
|
|
+
|
|
|
+ let needs_cast, is_float = match t, like_float t && not (like_i64 t) with
|
|
|
+ | TAbstract({ a_path = ([], "Float") },[]), _ -> false, true
|
|
|
+ | _, true -> true, true
|
|
|
+ | _ -> false,false
|
|
|
+ in
|
|
|
+
|
|
|
+ let olocal = mk_local vo pos in
|
|
|
+ let flocal = mk_local vf pos in
|
|
|
+
|
|
|
+ let get_from_obj e = match const with
|
|
|
+ | None -> mk_cast t e
|
|
|
+ | Some tc ->
|
|
|
+ {
|
|
|
+ eexpr = TIf(
|
|
|
+ { eexpr = TBinop(Ast.OpEq, olocal, null t_dynamic pos); etype = basic.tbool; epos = pos } ,
|
|
|
+ { eexpr = TConst(tc); etype = t; epos = pos },
|
|
|
+ Some (mk_cast t e)
|
|
|
+ );
|
|
|
+ etype = t;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ in
|
|
|
+
|
|
|
+ {
|
|
|
+ eexpr = TIf(
|
|
|
+ { eexpr = TBinop(Ast.OpEq, olocal, undefined pos); etype = basic.tbool; epos = pos },
|
|
|
+ (if needs_cast then mk_cast t flocal else flocal),
|
|
|
+ Some ( get_from_obj olocal )
|
|
|
+ );
|
|
|
+ etype = t;
|
|
|
+ epos = pos
|
|
|
+ }
|
|
|
+ in
|
|
|
+ (* end of api fn *)
|
|
|
+
|
|
|
+ let ret = if is_float then basic.tfloat else t_dynamic in
|
|
|
+
|
|
|
+ let fn_expr = map_fn i ret (List.map fst args) api in
|
|
|
+
|
|
|
+ let t = TFun(fun_args args, ret) in
|
|
|
+
|
|
|
+ let tfunction =
|
|
|
+ {
|
|
|
+ eexpr = TFunction({
|
|
|
+ tf_args = args;
|
|
|
+ tf_type = ret;
|
|
|
+ tf_expr =
|
|
|
+ mk_block fn_expr
|
|
|
+ });
|
|
|
+ etype = t;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ in
|
|
|
+
|
|
|
+ let cf = mk_invoke_i i is_float in
|
|
|
+ cf.cf_expr <- Some tfunction;
|
|
|
+ cf
|
|
|
+ in
|
|
|
+
|
|
|
+ let rec loop i cfs =
|
|
|
+ if i < 0 then cfs else begin
|
|
|
+ (*let mk_invoke_complete_i i is_float =*)
|
|
|
+ (mk_invoke_complete_i i false) :: (mk_invoke_complete_i i true) :: (loop (i-1) cfs)
|
|
|
+ end
|
|
|
+ in
|
|
|
+
|
|
|
+ let cfs = loop max_arity [] in
|
|
|
+
|
|
|
+ let switch =
|
|
|
+ let api i t const =
|
|
|
+ match i with
|
|
|
+ | -1 ->
|
|
|
+ mk_local dynamic_arg pos
|
|
|
+ | _ ->
|
|
|
+ mk_cast t {
|
|
|
+ eexpr = TArray(
|
|
|
+ mk_local dynamic_arg pos,
|
|
|
+ { eexpr = TConst(TInt(Int32.of_int i)); etype = basic.tint; epos = pos });
|
|
|
+ etype = t;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ in
|
|
|
+ map_fn (-1) t_dynamic [dynamic_arg] api
|
|
|
+ in
|
|
|
+
|
|
|
+ let args = [dynamic_arg, None] in
|
|
|
+ let dyn_t = TFun(fun_args args, t_dynamic) in
|
|
|
+ let dyn_cf = mk_class_field (gen.gmk_internal_name "hx" "invokeDynamic") dyn_t false pos (Method MethNormal) [] in
|
|
|
+
|
|
|
+ dyn_cf.cf_expr <- Some {
|
|
|
+ eexpr = TFunction {
|
|
|
+ tf_args = args;
|
|
|
+ tf_type = t_dynamic;
|
|
|
+ tf_expr = mk_block switch
|
|
|
+ };
|
|
|
+ etype = dyn_t;
|
|
|
+ epos = pos;
|
|
|
+ };
|
|
|
+
|
|
|
+ let additional_cfs = begin
|
|
|
+ let new_t = TFun(["arity", false, basic.tint; "type", false, basic.tint],basic.tvoid) in
|
|
|
+ let new_cf = mk_class_field "new" (new_t) true pos (Method MethNormal) [] in
|
|
|
+ let v_arity, v_type = alloc_var "arity" basic.tint, alloc_var "type" basic.tint in
|
|
|
+ let mk_assign v field = mk (TBinop (OpAssign, mk_this field v.v_type, mk_local v pos)) v.v_type pos in
|
|
|
+
|
|
|
+ let arity_name = gen.gmk_internal_name "hx" "arity" in
|
|
|
+ new_cf.cf_expr <- Some {
|
|
|
+ eexpr = TFunction({
|
|
|
+ tf_args = [v_arity, None; v_type, None];
|
|
|
+ tf_type = basic.tvoid;
|
|
|
+ tf_expr =
|
|
|
+ {
|
|
|
+ eexpr = TBlock([
|
|
|
+ mk_assign v_type type_name;
|
|
|
+ mk_assign v_arity arity_name
|
|
|
+ ]);
|
|
|
+ etype = basic.tvoid;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ });
|
|
|
+ etype = new_t;
|
|
|
+ epos = pos;
|
|
|
+ };
|
|
|
+
|
|
|
+ [
|
|
|
+ new_cf;
|
|
|
+ mk_class_field type_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
|
|
|
+ mk_class_field arity_name basic.tint true pos (Var { v_read = AccNormal; v_write = AccNormal }) [];
|
|
|
+ ]
|
|
|
+ end in
|
|
|
+
|
|
|
+ dyn_cf :: (additional_cfs @ cfs)
|
|
|
+ in
|
|
|
+
|
|
|
+ begin
|
|
|
+ (*
|
|
|
+ setup fields for the abstract implementation of the Function class
|
|
|
+
|
|
|
+ new(arity, type)
|
|
|
+ {
|
|
|
+ this.arity = arity;
|
|
|
+ this.type = type;
|
|
|
+ }
|
|
|
+
|
|
|
+ hx::invokeX_f|o (where X is from 0 to max_arity) (args)
|
|
|
+ {
|
|
|
+ if (this.type == 0|1) return invokeX_o|f(args); else throw "Invalid number of arguments."
|
|
|
+ }
|
|
|
+
|
|
|
+ hx::invokeDynamic, which will work in the same way
|
|
|
+ *)
|
|
|
+ let cl = parent_func_class in
|
|
|
+ let pos = cl.cl_pos in
|
|
|
+
|
|
|
+ let rec mk_dyn_call arity api =
|
|
|
+ let zero = ExprBuilder.make_float gen.gcon "0.0" pos in
|
|
|
+ let rec loop i acc =
|
|
|
+ if i = 0 then
|
|
|
+ acc
|
|
|
+ else begin
|
|
|
+ let arr = api (i - 1) t_dynamic None in
|
|
|
+ loop (i - 1) (zero :: arr :: acc)
|
|
|
+ end
|
|
|
+ in
|
|
|
+ loop arity []
|
|
|
+ in
|
|
|
+
|
|
|
+ let this = mk (TConst TThis) (TInst (cl, List.map snd cl.cl_params)) pos in
|
|
|
+ let mk_this field t = { (mk_field_access gen this field pos) with etype = t } in
|
|
|
+
|
|
|
+ let mk_invoke_switch i api =
|
|
|
+ let t = TFun (func_sig_i i, t_dynamic) in
|
|
|
+ (* case i: return this.invokeX_o(0, 0, 0, 0, 0, ... arg[0], args[1]....); *)
|
|
|
+ [ExprBuilder.make_int gen.gcon i pos], mk_return (mk (TCall(mk_this (iname i false) t, mk_dyn_call i api)) t_dynamic pos)
|
|
|
+ in
|
|
|
+ let rec loop_cases api arity acc =
|
|
|
+ if arity < 0 then
|
|
|
+ acc
|
|
|
+ else
|
|
|
+ loop_cases api (arity - 1) (mk_invoke_switch arity api :: acc)
|
|
|
+ in
|
|
|
+
|
|
|
+ let type_name = gen.gmk_internal_name "fn" "type" in
|
|
|
+ let mk_expr i is_float vars =
|
|
|
+ let call_expr =
|
|
|
+ let call_t = TFun(List.map (fun v -> (v.v_name, false, v.v_type)) vars, if is_float then t_dynamic else basic.tfloat) in
|
|
|
+ {
|
|
|
+ eexpr = TCall(mk_this (iname i (not is_float)) call_t, List.map (fun v -> mk_local v pos) vars);
|
|
|
+ etype = if is_float then t_dynamic else basic.tfloat;
|
|
|
+ epos = pos
|
|
|
+ }
|
|
|
+ in
|
|
|
+ {
|
|
|
+ eexpr = TIf(
|
|
|
+ mk (TBinop (Ast.OpNotEq, mk_this type_name basic.tint, (ExprBuilder.make_int gen.gcon (if is_float then 0 else 1) pos))) basic.tbool pos,
|
|
|
+ mk (TThrow (ExprBuilder.make_string gen.gcon "Wrong number of arguments" pos)) t_dynamic pos,
|
|
|
+ Some (mk_return call_expr)
|
|
|
+ );
|
|
|
+ etype = t_dynamic;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ in
|
|
|
+
|
|
|
+ let arities_processed = Hashtbl.create 10 in
|
|
|
+ let max_arity = ref 0 in
|
|
|
+
|
|
|
+ let map_fn cur_arity fun_ret_type vars (api:int->t->tconstant option->texpr) =
|
|
|
+ let is_float = like_float fun_ret_type && not (like_i64 fun_ret_type) in
|
|
|
+ match cur_arity with
|
|
|
+ | -1 ->
|
|
|
+ let dynargs = api (-1) t_dynamic None in
|
|
|
+
|
|
|
+ (* (dynargs == null) ? 0 : dynargs.length *)
|
|
|
+ let switch_cond = {
|
|
|
+ eexpr = TIf(
|
|
|
+ mk (TBinop (OpEq, dynargs, null dynargs.etype pos)) basic.tbool pos,
|
|
|
+ mk (TConst (TInt Int32.zero)) basic.tint pos,
|
|
|
+ Some (mk_field_access gen dynargs "length" pos));
|
|
|
+ etype = basic.tint;
|
|
|
+ epos = pos;
|
|
|
+ } in
|
|
|
+
|
|
|
+ {
|
|
|
+ eexpr = TSwitch(
|
|
|
+ switch_cond,
|
|
|
+ loop_cases api !max_arity [],
|
|
|
+ Some(mk (TThrow (ExprBuilder.make_string gen.gcon "Too many arguments" pos)) basic.tvoid pos));
|
|
|
+ etype = basic.tvoid;
|
|
|
+ epos = pos;
|
|
|
+ }
|
|
|
+ | _ ->
|
|
|
+ if not (Hashtbl.mem arities_processed cur_arity) then begin
|
|
|
+ Hashtbl.add arities_processed cur_arity true;
|
|
|
+ if cur_arity > !max_arity then max_arity := cur_arity
|
|
|
+ end;
|
|
|
+
|
|
|
+ mk_expr cur_arity is_float vars
|
|
|
+ in
|
|
|
+
|
|
|
+ let cfs = map_base_classfields cl map_fn in
|
|
|
+ List.iter (fun cf ->
|
|
|
+ if cf.cf_name = "new" then
|
|
|
+ parent_func_class.cl_constructor <- Some cf
|
|
|
+ else
|
|
|
+ parent_func_class.cl_fields <- PMap.add cf.cf_name cf parent_func_class.cl_fields
|
|
|
+ ) cfs;
|
|
|
+ parent_func_class.cl_ordered_fields <- (List.filter (fun cf -> cf.cf_name <> "new") cfs) @ parent_func_class.cl_ordered_fields
|
|
|
+ end;
|
|
|
+
|
|
|
+ {
|
|
|
+ func_class = parent_func_class;
|
|
|
+ closure_to_classfield = closure_to_classfield;
|
|
|
+ dynamic_fun_call = dynamic_fun_call;
|
|
|
+ map_base_classfields = map_base_classfields;
|
|
|
+ }
|
|
|
end;;
|
Dan Korostelev