diff --git a/.gitignore b/.gitignore index 2b0a2d9577d..cf7fc529629 100644 --- a/.gitignore +++ b/.gitignore @@ -137,3 +137,4 @@ lib.sexp src/compiler/version.ml tests/party tests/misc/projects/Issue10863/error.log +tests/misc/coroutines/dump diff --git a/src-json/meta.json b/src-json/meta.json index aa231387571..517a6512072 100644 --- a/src-json/meta.json +++ b/src-json/meta.json @@ -142,6 +142,12 @@ "targets": ["TAbstract"], "links": ["https://haxe.org/manual/types-abstract-core-type.html"] }, + { + "name": "Coroutine", + "metadata": ":coroutine", + "doc": "Transform function into a coroutine", + "targets": ["TClassField"] + }, { "name": "CppFileCode", "metadata": ":cppFileCode", diff --git a/src/codegen/codegen.ml b/src/codegen/codegen.ml index 0631180fced..f5db3a439d8 100644 --- a/src/codegen/codegen.ml +++ b/src/codegen/codegen.ml @@ -102,9 +102,13 @@ let rec find_field com c f = let fix_override com c f fd = let f2 = (try Some (find_field com c f) with Not_found -> None) in + let extract_fun f2 = match follow f2.cf_type with + | TFun (args,ret,coro) -> args, ret, coro + | _ -> die "" __LOC__ + in match f2,fd with | Some (f2), Some(fd) -> - let targs, tret = (match follow f2.cf_type with TFun (args,ret) -> args, ret | _ -> die "" __LOC__) in + let targs, tret, coro = extract_fun f2 in let changed_args = ref [] in let prefix = "_tmp_" in let nargs = List.map2 (fun ((v,ct) as cur) (_,_,t2) -> @@ -147,10 +151,10 @@ let fix_override com c f fd = let targs = List.map (fun(v,c) -> (v.v_name, Option.is_some c, v.v_type)) nargs in let fde = (match f.cf_expr with None -> die "" __LOC__ | Some e -> e) in f.cf_expr <- Some { fde with eexpr = TFunction fd2 }; - f.cf_type <- TFun(targs,tret); + f.cf_type <- TFun(targs,tret,coro); | Some(f2), None when (has_class_flag c CInterface) -> - let targs, tret = (match follow f2.cf_type with TFun (args,ret) -> args, ret | _ -> die "" __LOC__) in - f.cf_type <- TFun(targs,tret) + let targs, tret, coro = extract_fun f2 in + f.cf_type <- TFun(targs,tret,coro) | _ -> () @@ -289,7 +293,7 @@ module Dump = struct | Some e -> " = " ^ (s_cf_expr f)); | Method m -> if ((has_class_flag c CExtern) || (has_class_flag c CInterface)) then ( match f.cf_type with - | TFun(al,t) -> print "(%s):%s;" (String.concat ", " ( + | TFun(al,t,_) -> print "(%s):%s;" (String.concat ", " ( List.map (fun (n,o,t) -> n ^ ":" ^ (s_type t)) al)) (s_type t) | _ -> () @@ -320,7 +324,7 @@ module Dump = struct let f = PMap.find n e.e_constrs in print "\t%s%s;\n" f.ef_name ( match f.ef_type with - | TFun (al,t) -> Printf.sprintf "(%s)" (String.concat ", " + | TFun (al,t,_) -> Printf.sprintf "(%s)" (String.concat ", " (List.map (fun (n,o,t) -> (if o then "?" else "") ^ n ^ ":" ^ (s_type t)) al)) | _ -> "") ) e.e_names; @@ -442,7 +446,7 @@ module UnificationCallback = struct List.rev (loop [] el tl) let check_call f el t = match follow t with - | TFun(args,_) -> + | TFun(args,_,_) -> check_call_params f el args | _ -> List.map (fun e -> f e t_dynamic) el diff --git a/src/codegen/genxml.ml b/src/codegen/genxml.ml index 70ebc26efae..611056c3887 100644 --- a/src/codegen/genxml.ml +++ b/src/codegen/genxml.ml @@ -97,7 +97,7 @@ let rec gen_type ?(values=None) t = | TInst (c,params) -> gen_type_decl "c" (TClassDecl c) params | TAbstract (a,params) -> gen_type_decl "x" (TAbstractDecl a) params | TType (t,params) -> gen_type_decl "t" (TTypeDecl t) params - | TFun (args,r) -> + | TFun (args,r,corotodo) -> let names = String.concat ":" (List.map gen_arg_name args) in let values = match values with | None -> [] @@ -180,7 +180,7 @@ and gen_field att f = let gen_constr e = let doc = gen_doc_opt e.ef_doc in let args, t = (match follow e.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> ["a",String.concat ":" (List.map gen_arg_name args)] , List.map (fun (_,opt,t) -> gen_type (if opt then follow_param t else t)) args @ doc | _ -> diff --git a/src/codegen/overloads.ml b/src/codegen/overloads.ml index b2096dfce58..3ff9bf16a7c 100644 --- a/src/codegen/overloads.ml +++ b/src/codegen/overloads.ml @@ -38,7 +38,7 @@ let same_overload_args ?(get_vmtype) t1 t2 f1 f2 = let compare_types () = let t1 = follow (apply_params f1.cf_params (extract_param_types f2.cf_params) t1) in match t1,follow t2 with - | TFun(tl1,_),TFun(tl2,_) -> + | TFun(tl1,_,coro1),TFun(tl2,_,coro2) when coro1 = coro2 -> compare_arguments tl1 tl2 | _ -> false @@ -210,7 +210,7 @@ struct let count_optionals t = match follow t with - | TFun(args,_) -> + | TFun(args,_,_) -> List.fold_left (fun acc (_,is_optional,_) -> if is_optional then acc + 1 else acc) 0 args | _ -> 0 @@ -268,7 +268,7 @@ struct end | fcc :: l -> let args,ret = match follow fcc.fc_type with - | TFun(args,ret) -> args,ret + | TFun(args,ret,_) -> args,ret | _ -> die "" __LOC__ in begin try diff --git a/src/compiler/displayOutput.ml b/src/compiler/displayOutput.ml index bd7795a4a78..b5b6dcdbf86 100644 --- a/src/compiler/displayOutput.ml +++ b/src/compiler/displayOutput.ml @@ -150,11 +150,11 @@ let print_type t p doc = let print_signatures tl = let b = Buffer.create 0 in - List.iter (fun (((args,ret),_),doc) -> + List.iter (fun (((args,ret,coro),_),doc) -> Buffer.add_string b " Buffer.add_string b (Printf.sprintf " d=\"%s\"" (htmlescape (gen_doc_text d)))) doc; Buffer.add_string b ">\n"; - Buffer.add_string b (htmlescape (s_type (print_context()) (TFun(args,ret)))); + Buffer.add_string b (htmlescape (s_type (print_context()) (TFun(args,ret,coro)))); Buffer.add_string b "\n\n"; ) tl; Buffer.contents b @@ -180,7 +180,7 @@ let print_signature tl display_arg = let st = s_type (print_context()) in let s_arg (n,o,t) = Printf.sprintf "%s%s:%s" (if o then "?" else "") n (st t) in let s_fun args ret = Printf.sprintf "(%s):%s" (String.concat ", " (List.map s_arg args)) (st ret) in - let siginf = List.map (fun (((args,ret),_),doc) -> + let siginf = List.map (fun (((args,ret,_),_),doc) -> let label = s_fun args ret in let parameters = List.map (fun arg -> diff --git a/src/compiler/hxb/hxbReader.ml b/src/compiler/hxb/hxbReader.ml index 74133f9b887..95024d949e3 100644 --- a/src/compiler/hxb/hxbReader.ml +++ b/src/compiler/hxb/hxbReader.ml @@ -748,57 +748,57 @@ class hxb_reader let c = {null_class with cl_kind = KExpr e; cl_module = current_module } in TInst(c, []) | 20 -> - TFun([],api#basic_types.tvoid) + TFun([],api#basic_types.tvoid,false) | 21 -> let arg1 = read_fun_arg () in - TFun([arg1],api#basic_types.tvoid) + TFun([arg1],api#basic_types.tvoid,false) | 22 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in - TFun([arg1;arg2],api#basic_types.tvoid) + TFun([arg1;arg2],api#basic_types.tvoid,false) | 23 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in let arg3 = read_fun_arg () in - TFun([arg1;arg2;arg3],api#basic_types.tvoid) + TFun([arg1;arg2;arg3],api#basic_types.tvoid,false) | 24 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in let arg3 = read_fun_arg () in let arg4 = read_fun_arg () in - TFun([arg1;arg2;arg3;arg4],api#basic_types.tvoid) + TFun([arg1;arg2;arg3;arg4],api#basic_types.tvoid,false) | 29 -> let args = self#read_list read_fun_arg in - TFun(args,api#basic_types.tvoid) + TFun(args,api#basic_types.tvoid,false) | 30 -> let ret = self#read_type_instance in - TFun([],ret) + TFun([],ret,false) | 31 -> let arg1 = read_fun_arg () in let ret = self#read_type_instance in - TFun([arg1],ret) + TFun([arg1],ret,false) | 32 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in let ret = self#read_type_instance in - TFun([arg1;arg2],ret) + TFun([arg1;arg2],ret,false) | 33 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in let arg3 = read_fun_arg () in let ret = self#read_type_instance in - TFun([arg1;arg2;arg3],ret) + TFun([arg1;arg2;arg3],ret,false) | 34 -> let arg1 = read_fun_arg () in let arg2 = read_fun_arg () in let arg3 = read_fun_arg () in let arg4 = read_fun_arg () in let ret = self#read_type_instance in - TFun([arg1;arg2;arg3;arg4],ret) + TFun([arg1;arg2;arg3;arg4],ret,false) | 39 -> let args = self#read_list read_fun_arg in let ret = self#read_type_instance in - TFun(args,ret) + TFun(args,ret,false) | 40 -> let c = self#read_class_ref in TInst(c,[]) @@ -1540,7 +1540,7 @@ class hxb_reader a.a_from_field <- self#read_list (fun () -> let cf = self#read_field_ref in let t = match cf.cf_type with - | TFun((_,_,t) :: _, _) -> t + | TFun((_,_,t) :: _, _, _) -> t | _ -> die "" __LOC__ in (t,cf) @@ -1549,7 +1549,7 @@ class hxb_reader a.a_to_field <- self#read_list (fun () -> let cf = self#read_field_ref in let t = match cf.cf_type with - | TFun(_, t) -> t + | TFun(_, t,_) -> t | _ -> die "" __LOC__ in (t,cf) diff --git a/src/compiler/hxb/hxbWriter.ml b/src/compiler/hxb/hxbWriter.ml index 32b2b1e82fd..8222b3fdd81 100644 --- a/src/compiler/hxb/hxbWriter.ml +++ b/src/compiler/hxb/hxbWriter.ml @@ -1252,11 +1252,11 @@ module HxbWriter = struct write_abstract_ref writer a; | TDynamic None -> Chunk.write_u8 writer.chunk 4; - | TFun([],t) when ExtType.is_void (follow_lazy_and_mono t) -> + | TFun([],t,_) when ExtType.is_void (follow_lazy_and_mono t) -> Chunk.write_u8 writer.chunk 20; - | TFun(args,t) when ExtType.is_void (follow_lazy_and_mono t) -> + | TFun(args,t,_) when ExtType.is_void (follow_lazy_and_mono t) -> write_inlined_list 20 4 (fun () -> ()) write_function_arg args; - | TFun(args,t) -> + | TFun(args,t,_) -> write_inlined_list 30 4 (fun () -> ()) write_function_arg args; write_type_instance writer t; | TInst(c,tl) -> @@ -1524,7 +1524,7 @@ module HxbWriter = struct Chunk.write_u8 writer.chunk 101; loop e1; let en = match follow ef.ef_type with - | TFun(_,tr) -> + | TFun(_,tr,_) -> begin match follow tr with | TEnum(en,_) -> en | _ -> die "" __LOC__ diff --git a/src/context/abstractCast.ml b/src/context/abstractCast.ml index 6e5f864629b..87dc43cdc65 100644 --- a/src/context/abstractCast.ml +++ b/src/context/abstractCast.ml @@ -151,7 +151,7 @@ let find_array_read_access_raise ctx a pl e1 p = | cf :: cfl -> let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in match follow (map cf.cf_type) with - | TFun((_,_,tab) :: (_,_,ta1) :: args,r) as tf when is_empty_or_pos_infos args -> + | TFun((_,_,tab) :: (_,_,ta1) :: args,r,_) as tf when is_empty_or_pos_infos args -> begin try Type.unify tab (get_ta()); let e1 = cast_or_unify_raise ctx ta1 e1 p in @@ -171,7 +171,7 @@ let find_array_write_access_raise ctx a pl e1 e2 p = | cf :: cfl -> let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in match follow (map cf.cf_type) with - | TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r) as tf when is_empty_or_pos_infos args -> + | TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r,_) as tf when is_empty_or_pos_infos args -> begin try Type.unify tab (get_ta()); let e1 = cast_or_unify_raise ctx ta1 e1 p in @@ -303,7 +303,7 @@ let handle_abstract_casts ctx e = begin try let fa = quick_field m fname in let get_fun_type t = match follow t with - | TFun(args,tr) as tf -> tf,args,tr + | TFun(args,tr,_) as tf -> tf,args,tr | _ -> raise Not_found in let tf,args,tr = match fa with @@ -333,7 +333,7 @@ let handle_abstract_casts ctx e = maybe_cast e t e.epos :: add_casts orig_args args el in match follow e1.etype with - | TFun (orig_args,_) -> add_casts orig_args args el + | TFun (orig_args,_,_) -> add_casts orig_args args el | _ -> el else el diff --git a/src/context/display/display.ml b/src/context/display/display.ml index 075839bbe12..54cfd32f546 100644 --- a/src/context/display/display.ml +++ b/src/context/display/display.ml @@ -70,7 +70,7 @@ let sort_fields l with_type tk = (* For enum constructors, we consider the return type of the constructor function so it has the same priority as argument-less constructors. *) let t' = match item.ci_kind,follow t' with - | ITEnumField _,TFun(_,r) -> r + | ITEnumField _,TFun(_,r,_) -> r | _ -> t' in let t' = dynamify_type_params t' in @@ -78,7 +78,7 @@ let sort_fields l with_type tk = else if t' == t_dynamic then 5 (* dynamic isn't good, but better than incompatible *) else try Type.unify t' t; 1 (* assignable - great *) with Unify_error _ -> match follow t' with - | TFun(_,tr) -> + | TFun(_,tr,_) -> if type_iseq tr t then 2 (* function returns our exact type - alright *) else (try Type.unify tr t; 3 (* function returns compatible type - okay *) with Unify_error _ -> 7) (* incompatible function - useless *) diff --git a/src/context/display/displayEmitter.ml b/src/context/display/displayEmitter.ml index 2b8e7d0fc1b..4ee2455c94d 100644 --- a/src/context/display/displayEmitter.ml +++ b/src/context/display/displayEmitter.ml @@ -124,7 +124,7 @@ let display_field ctx origin scope cf p = match ctx.com.display.dms_kind with cf in let cf = match origin,scope,follow cf.cf_type with - | Self (TClassDecl c),CFSConstructor,TFun(tl,_) -> {cf with cf_type = TFun(tl,TInst(c,extract_param_types c.cl_params))} + | Self (TClassDecl c),CFSConstructor,TFun(tl,_,coro) -> {cf with cf_type = TFun(tl,TInst(c,extract_param_types c.cl_params),coro)} | _ -> cf in let ct = CompletionType.from_type (get_import_status ctx) ~values:(get_value_meta cf.cf_meta) cf.cf_type in diff --git a/src/context/display/displayException.ml b/src/context/display/displayException.ml index 59c2d8d9454..7b8983752ba 100644 --- a/src/context/display/displayException.ml +++ b/src/context/display/displayException.ml @@ -146,7 +146,7 @@ let fields_to_json ctx fields kind subj = let arg_index signatures signature_index param_index = try - let args,_ = fst (fst (List.nth signatures signature_index)) in + let args,_,_ = fst (fst (List.nth signatures signature_index)) in let rec loop args index = match args with | [] -> param_index diff --git a/src/context/display/displayFields.ml b/src/context/display/displayFields.ml index 842bf97a48c..638aa24748b 100644 --- a/src/context/display/displayFields.ml +++ b/src/context/display/displayFields.ml @@ -52,8 +52,8 @@ let collect_static_extensions ctx items e p = let monos = List.map (fun _ -> spawn_monomorph ctx.e p) f.cf_params in let map = apply_params f.cf_params monos in match follow (map f.cf_type) with - | TFun((_,_,TType({t_path=["haxe";"macro"], "ExprOf"}, [t])) :: args, ret) - | TFun((_,_,t) :: args, ret) -> + | TFun((_,_,TType({t_path=["haxe";"macro"], "ExprOf"}, [t])) :: args, ret, coro) + | TFun((_,_,t) :: args, ret, coro) -> begin try let e = TyperBase.unify_static_extension ctx {e with etype = dup e.etype} t p in List.iter2 (fun m ttp -> match get_constraints ttp with @@ -66,7 +66,7 @@ let collect_static_extensions ctx items e p = acc else begin let f = prepare_using_field f in - let f = { f with cf_params = []; cf_flags = set_flag f.cf_flags (int_of_class_field_flag CfPublic); cf_type = TFun(args,ret) } in + let f = { f with cf_params = []; cf_flags = set_flag f.cf_flags (int_of_class_field_flag CfPublic); cf_type = TFun(args,ret,coro) } in let decl = match c.cl_kind with | KAbstractImpl a -> TAbstractDecl a | _ -> TClassDecl c @@ -128,7 +128,7 @@ let collect_static_extensions ctx items e p = items let collect ctx e_ast e dk with_type p = - let opt_args args ret = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret) in + let opt_args args ret coro = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret,coro) in let should_access c cf stat = if Meta.has Meta.NoCompletion cf.cf_meta then false else if c != ctx.c.curclass && not (has_class_field_flag cf CfPublic) && String.length cf.cf_name > 4 then begin match String.sub cf.cf_name 0 4 with @@ -314,10 +314,10 @@ let collect ctx e_ast e dk with_type p = in iter_fields origin an.a_fields (fun _ -> true) make_ci_class_field end - | TFun (args,ret) -> + | TFun (args,ret,coro) -> (* A function has no field except the magic .bind one. *) if is_new_item items "bind" then begin - let t = opt_args args ret in + let t = opt_args args ret coro in let cf = mk_field "bind" (tfun [t] t) p null_pos in cf.cf_kind <- Method MethNormal; let ct = CompletionType.from_type (get_import_status ctx) ~values:(get_value_meta cf.cf_meta) t in @@ -380,7 +380,7 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield = let e = type_expr ctx e WithType.value in (name,false,e.etype) ) el in - (TFun(tl,tret),Method MethNormal) + (TFun(tl,tret,false),Method MethNormal) with _ -> raise Exit end diff --git a/src/context/display/displayToplevel.ml b/src/context/display/displayToplevel.ml index 41536c6f43a..e982d4b141d 100644 --- a/src/context/display/displayToplevel.ml +++ b/src/context/display/displayToplevel.ml @@ -31,7 +31,7 @@ open Globals persisted on the compilation server, or else the compiler gets COVID. *) let perform_type_voodoo t tl' tr' = match t with - | TFun(tl,tr) -> + | TFun(tl,tr,coro) -> let rec loop acc tl tl' = match tl,tl' with | ((_,_,t1) as a1 :: tl),((_,_,t1') as a1' :: tl') -> let a = if t1 == t_dynamic then a1' else a1 in @@ -39,9 +39,9 @@ let perform_type_voodoo t tl' tr' = | _ -> (List.rev acc) @ tl' in let tl = loop [] tl tl' in - TFun(tl,if tr == t_dynamic then tr' else tr') + TFun(tl,(if tr == t_dynamic then tr' else tr'),coro) | _ -> - TFun(tl',tr') + TFun(tl',tr',false) let maybe_resolve_macro_field ctx t c cf = try @@ -428,7 +428,6 @@ let collect ctx tk with_type sort = ) ctx.m.import_resolution#extract_field_imports; t(); - let t = Timer.timer ["display";"toplevel collect";"rest"] in (* literals *) add (make_ci_literal "null" (tpair t_dynamic)) (Some "null"); add (make_ci_literal "true" (tpair ctx.com.basic.tbool)) (Some "true"); @@ -457,9 +456,8 @@ let collect ctx tk with_type sort = List.iter (fun kwd -> add(make_ci_keyword kwd) (Some (s_keyword kwd))) kwds; (* builtins *) - add (make_ci_literal "trace" (tpair (TFun(["value",false,t_dynamic],ctx.com.basic.tvoid)))) (Some "trace") - end; - t() + add (make_ci_literal "trace" (tpair (TFun(["value",false,t_dynamic],ctx.com.basic.tvoid,false)))) (Some "trace") + end end; (* type params *) diff --git a/src/context/typecore.ml b/src/context/typecore.ml index 7c59767d5ab..40da40e4423 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -104,6 +104,11 @@ type typer_pass_tasks = { mutable tasks : (unit -> unit) list; } +type function_mode = + | FunFunction + | FunCoroutine + | FunNotFunction + type typer_globals = { mutable delayed : typer_pass_tasks Array.t; mutable delayed_min_index : int; @@ -138,7 +143,7 @@ type typer_globals = { is shared by local TFunctions. *) and typer_expr = { curfun : current_fun; - in_function : bool; + function_mode : function_mode; mutable ret : t; mutable opened : anon_status ref list; mutable monomorphs : monomorphs; @@ -147,6 +152,7 @@ and typer_expr = { mutable with_type_stack : WithType.t list; mutable call_argument_stack : expr list list; mutable macro_depth : int; + mutable is_coroutine : bool; } and typer_field = { @@ -191,6 +197,7 @@ let pass_name = function | PFinal -> "final" module TyperManager = struct + let create ctx m c f e pass params = if pass < ctx.pass then die (Printf.sprintf "Bad context clone from %s(%s) to %s(%s)" (s_type_path ctx.m.curmod.m_path) (pass_name ctx.pass) (s_type_path m.curmod.m_path) (pass_name pass)) __LOC__; let new_ctx = { @@ -235,10 +242,10 @@ module TyperManager = struct in_call_args = false; } - let create_ctx_e curfun in_function = + let create_ctx_e curfun function_mode = { curfun; - in_function; + function_mode; ret = t_dynamic; opened = []; monomorphs = { @@ -249,6 +256,7 @@ module TyperManager = struct with_type_stack = []; call_argument_stack = []; macro_depth = 0; + is_coroutine = false; } let clone_for_module ctx m = @@ -291,8 +299,17 @@ module TyperManager = struct let clone_for_type_parameter_expression ctx = let f = create_ctx_f ctx.f.curfield in - let e = create_ctx_e ctx.e.curfun false in + let e = create_ctx_e ctx.e.curfun FunNotFunction in create ctx ctx.m ctx.c f e PTypeField ctx.type_params + + let is_coroutine_context ctx = + ctx.e.function_mode = FunCoroutine + + let is_function_context ctx = match ctx.e.function_mode with + | FunFunction | FunCoroutine -> + true + | FunNotFunction -> + false end type field_host = @@ -648,18 +665,18 @@ let check_field_access ctx c f stat p = (** removes the first argument of the class field's function type and all its overloads *) let prepare_using_field cf = match follow cf.cf_type with - | TFun((_,_,tf) :: args,ret) -> + | TFun((_,_,tf) :: args,ret,coro) -> let rec loop acc overloads = match overloads with - | ({cf_type = TFun((_,_,tfo) :: args,ret)} as cfo) :: l -> + | ({cf_type = TFun((_,_,tfo) :: args,ret,_)} as cfo) :: l -> let tfo = apply_params cfo.cf_params (extract_param_types cfo.cf_params) tfo in (* ignore overloads which have a different first argument *) - if type_iseq tf tfo then loop ({cfo with cf_type = TFun(args,ret)} :: acc) l else loop acc l + if type_iseq tf tfo then loop ({cfo with cf_type = TFun(args,ret,coro)} :: acc) l else loop acc l | _ :: l -> loop acc l | [] -> acc in - {cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret)} + {cf with cf_overloads = loop [] cf.cf_overloads; cf_type = TFun(args,ret,coro)} | _ -> cf let merge_core_doc ctx mt = @@ -685,6 +702,12 @@ let safe_mono_close ctx m p = Unify_error l -> raise_or_display ctx l p +(* TODO: this is wrong *) +let coroutine_type ctx args ret = + let args = args @ [("_hx_continuation",false,(tfun [ret; t_dynamic] ctx.com.basic.tvoid))] in + let ret = ctx.com.basic.tvoid in + TFun(args,ret,true) + let relative_path ctx file = ctx.com.class_paths#relative_path file diff --git a/src/core/display/completionItem.ml b/src/core/display/completionItem.ml index f3f4b804bb5..77b4e531d5c 100644 --- a/src/core/display/completionItem.ml +++ b/src/core/display/completionItem.ml @@ -367,6 +367,7 @@ module CompletionType = struct and ct_function = { ct_args : ct_function_argument list; ct_return : t; + ct_coro : bool; } and ct_anonymous_field = { @@ -484,16 +485,18 @@ module CompletionType = struct CTTypedef (ppath td.t_module.m_path td.t_path tl) | TAbstract(a,tl) -> CTAbstract (ppath a.a_module.m_path a.a_path tl) - | TFun(tl,t) when not (PMap.is_empty values) -> + | TFun(tl,t,coro) when not (PMap.is_empty values) -> let get_arg n = try Some (PMap.find n values) with Not_found -> None in CTFunction { ct_args = List.map (fun (n,o,t) -> funarg (get_arg n) (n,o,t)) tl; ct_return = from_type PMap.empty t; + ct_coro = coro; } - | TFun(tl,t) -> + | TFun(tl,t,coro) -> CTFunction { ct_args = List.map (funarg None) tl; ct_return = from_type PMap.empty t; + ct_coro = coro; } | TAnon an -> let afield af = { diff --git a/src/core/error.ml b/src/core/error.ml index c1b2232693c..08527ee23ca 100644 --- a/src/core/error.ml +++ b/src/core/error.ml @@ -179,6 +179,9 @@ module BetterErrors = struct ) l; root_acc + let maybe_coro coro s = + if coro then Printf.sprintf "Coroutine<%s>" s else s + (* non-recursive s_type *) let rec s_type ctx t = match t with @@ -196,9 +199,9 @@ module BetterErrors = struct s_type_path t.t_path ^ s_type_params ctx tl | TAbstract (a,tl) -> s_type_path a.a_path ^ s_type_params ctx tl - | TFun ([],_) -> - "() -> ..." - | TFun (l,t) -> + | TFun ([],_,coro) -> + maybe_coro coro "() -> ..." + | TFun (l,t,coro) -> let args = match l with | [] -> "()" | ["",b,t] -> ("...") @@ -208,7 +211,7 @@ module BetterErrors = struct ) l) in "(" ^ args ^ ")" in - Printf.sprintf "%s -> ..." args + maybe_coro coro (Printf.sprintf "%s -> ..." args) | TAnon a -> begin match !(a.a_status) with diff --git a/src/core/json/genjson.ml b/src/core/json/genjson.ml index 72b3d4fa951..3e93c3b6850 100644 --- a/src/core/json/genjson.ml +++ b/src/core/json/genjson.ml @@ -224,7 +224,7 @@ let rec generate_type ctx t = | TType(td,tl) -> "TType",Some (generate_type_path_with_params ctx td.t_module.m_path td.t_path tl td.t_meta) | TAbstract(a,tl) -> "TAbstract",Some (generate_type_path_with_params ctx a.a_module.m_path a.a_path tl a.a_meta) | TAnon an -> "TAnonymous", Some(generate_anon ctx an) - | TFun(tl,tr) -> "TFun", Some (jobject (generate_function_signature ctx tl tr)) + | TFun(tl,tr,coro) -> "TFun", Some (jobject (generate_function_signature ctx tl tr coro)) in let name,args = loop t in generate_adt ctx None name args @@ -257,10 +257,11 @@ and generate_function_argument ctx (name,opt,t) = "t",generate_type ctx t; ] -and generate_function_signature ctx tl tr = +and generate_function_signature ctx tl tr coro = [ "args",jlist (generate_function_argument ctx) tl; "ret",generate_type ctx tr; + "coro",jbool coro; ] and generate_types ctx tl = diff --git a/src/core/tFunctions.ml b/src/core/tFunctions.ml index cdb457a8923..7ddc2b3aea1 100644 --- a/src/core/tFunctions.ml +++ b/src/core/tFunctions.ml @@ -101,7 +101,7 @@ let mk_anon ?fields status = let fields = match fields with Some fields -> fields | None -> PMap.empty in TAnon { a_fields = fields; a_status = status; } -let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r) +let tfun pl r = TFun (List.map (fun t -> "",false,t) pl,r,false) let fun_args l = List.map (fun (a,c,t) -> a, c <> None, t) l @@ -344,8 +344,8 @@ let map loop t = TType (t2,List.map loop tl) | TAbstract (a,tl) -> TAbstract (a,List.map loop tl) - | TFun (tl,r) -> - TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r) + | TFun (tl,r,coro) -> + TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r,coro) | TAnon a -> let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in mk_anon ~fields a.a_status @@ -374,7 +374,7 @@ let iter loop t = List.iter loop tl | TAbstract (a,tl) -> List.iter loop tl - | TFun (tl,r) -> + | TFun (tl,r,_) -> List.iter (fun (_,_,t) -> loop t) tl; loop r | TAnon a -> @@ -511,8 +511,8 @@ let apply_params ?stack cparams params t = | _ -> TInst (c,List.map loop tl)) | _ -> TInst (c,List.map loop tl)) - | TFun (tl,r) -> - TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r) + | TFun (tl,r,coro) -> + TFun (List.map (fun (s,o,t) -> s, o, loop t) tl,loop r,coro) | TAnon a -> let fields = PMap.map (fun f -> { f with cf_type = loop f.cf_type }) a.a_fields in mk_anon ~fields a.a_status @@ -624,7 +624,7 @@ let rec follow_lazy_and_mono t = match t with let rec ambiguate_funs t = match follow t with - | TFun _ -> TFun ([], t_dynamic) + | TFun(_,_,coro) -> TFun ([], t_dynamic,coro) | _ -> map ambiguate_funs t let rec is_nullable ?(no_lazy=false) = function @@ -694,7 +694,7 @@ let rec has_mono t = match t with List.exists has_mono pl | TDynamic _ -> false - | TFun(args,r) -> + | TFun(args,r,_) -> has_mono r || List.exists (fun (_,_,t) -> has_mono t) args | TAnon a -> PMap.fold (fun cf b -> has_mono cf.cf_type || b) a.a_fields false diff --git a/src/core/tOther.ml b/src/core/tOther.ml index c3b221418ff..67f2f814baa 100644 --- a/src/core/tOther.ml +++ b/src/core/tOther.ml @@ -33,12 +33,17 @@ module TExprToExpr = struct if (snd t.t_path).[0] = '#' then convert_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map tparam pl) | TAbstract (a,pl) -> tpath a.a_path a.a_module.m_path (List.map tparam pl) - | TFun (args,ret) -> - CTFunction (List.map (fun (n,o,t) -> + | TFun (args,ret,coro) -> + let ct_fun = CTFunction (List.map (fun (n,o,t) -> let ct = convert_type' t in let ct = if n = "" then ct else CTNamed((n,null_pos),ct),null_pos in if o then CTOptional ct,null_pos else ct ) args, (convert_type' ret)) + in + if coro then + tpath ([],"Coroutine") ([],"Coroutine") [TPType (ct_fun,null_pos)] + else + ct_fun | TAnon a -> begin match !(a.a_status) with | ClassStatics c -> tpath ([],"Class") ([],"Class") [TPType (tpath c.cl_path c.cl_path [],null_pos)] @@ -63,7 +68,7 @@ module TExprToExpr = struct let read = (var_access_to_string v.v_read "get",null_pos) in let write = (var_access_to_string v.v_write "set",null_pos) in FProp (read,write,mk_type_hint f.cf_type null_pos,None) - | Method _,TFun(args,ret) -> + | Method _,TFun(args,ret,_) -> FFun({ f_params = []; f_args = List.map (fun (n,o,t) -> diff --git a/src/core/tPrinting.ml b/src/core/tPrinting.ml index 954de7e1104..31b71005a48 100644 --- a/src/core/tPrinting.ml +++ b/src/core/tPrinting.ml @@ -17,7 +17,7 @@ let rec s_type_kind t = | TInst(c,tl) -> Printf.sprintf "TInst(%s, [%s])" (s_type_path c.cl_path) (map tl) | TType(t,tl) -> Printf.sprintf "TType(%s, [%s])" (s_type_path t.t_path) (map tl) | TAbstract(a,tl) -> Printf.sprintf "TAbstract(%s, [%s])" (s_type_path a.a_path) (map tl) - | TFun(tl,r) -> Printf.sprintf "TFun([%s], %s)" (String.concat ", " (List.map (fun (n,b,t) -> Printf.sprintf "%s%s:%s" (if b then "?" else "") n (s_type_kind t)) tl)) (s_type_kind r) + | TFun(tl,r,coro) -> Printf.sprintf "TFun([%s], %s, %b)" (String.concat ", " (List.map (fun (n,b,t) -> Printf.sprintf "%s%s:%s" (if b then "?" else "") n (s_type_kind t)) tl)) (s_type_kind r) coro | TAnon an -> "TAnon" | TDynamic t2 -> "TDynamic" | TLazy _ -> "TLazy" @@ -31,6 +31,9 @@ let s_module_type_kind = function let show_mono_ids = true let rec s_type ctx t = + let maybe_coro coro s = + if coro then Printf.sprintf "Coroutine<%s>" s else s + in match t with | TMono r -> (match r.tm_type with @@ -72,9 +75,9 @@ let rec s_type ctx t = s_type_path t.t_path ^ s_type_params ctx tl | TAbstract (a,tl) -> s_type_path a.a_path ^ s_type_params ctx tl - | TFun ([],t) -> - "() -> " ^ s_fun ctx t false - | TFun (l,t) -> + | TFun ([],t,coro) -> + maybe_coro coro ("() -> " ^ s_fun ctx t false) + | TFun (l,t,coro) -> let args = match l with | [] -> "()" | ["",b,t] -> Printf.sprintf "%s%s" (if b then "?" else "") (s_fun ctx t true) @@ -84,7 +87,7 @@ let rec s_type ctx t = ) l) in "(" ^ args ^ ")" in - Printf.sprintf "%s -> %s" args (s_fun ctx t false) + maybe_coro coro (Printf.sprintf "%s -> %s" args (s_fun ctx t false)) | TAnon a -> begin match !(a.a_status) with diff --git a/src/core/tType.ml b/src/core/tType.ml index 205d4415e91..a2815916b89 100644 --- a/src/core/tType.ml +++ b/src/core/tType.ml @@ -103,7 +103,7 @@ and tlazy = | LProcessing of t | LWait of (unit -> t) -and tsignature = (string * bool * t) list * t +and tsignature = (string * bool * t) list * t * bool (* true = coroutine *) and tparams = t list diff --git a/src/core/tUnification.ml b/src/core/tUnification.ml index 7be40f10d73..82402382779 100644 --- a/src/core/tUnification.ml +++ b/src/core/tUnification.ml @@ -326,7 +326,7 @@ let link e a b = | TMono t -> (match t.tm_type with None -> false | Some t -> loop t) | TEnum (_,tl) -> List.exists loop tl | TInst (_,tl) | TType (_,tl) | TAbstract (_,tl) -> List.exists loop tl - | TFun (tl,t) -> List.exists (fun (_,_,t) -> loop t) tl || loop t + | TFun (tl,t,_) -> List.exists (fun (_,_,t) -> loop t) tl || loop t | TDynamic None -> false | TDynamic (Some t2) -> @@ -359,7 +359,7 @@ let fast_eq_check type_param_check a b = if a == b then true else match a , b with - | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 -> + | TFun (l1,r1,coro1) , TFun (l2,r2,coro2) when coro1 = coro2 && List.length l1 = List.length l2 -> List.for_all2 (fun (_,_,t1) (_,_,t2) -> type_param_check t1 t2) l1 l2 && type_param_check r1 r2 | TType (t1,l1), TType (t2,l2) -> t1 == t2 && List.for_all2 type_param_check l1 l2 @@ -578,7 +578,7 @@ let rec type_eq uctx a b = | TInst (c1,tl1) , TInst (c2,tl2) -> if c1 != c2 && not (param = EqCoreType && c1.cl_path = c2.cl_path) && (match c1.cl_kind, c2.cl_kind with KExpr _, KExpr _ -> false | _ -> true) then error [cannot_unify a b]; type_eq_params uctx a b tl1 tl2 - | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 -> + | TFun (l1,r1,coro1) , TFun (l2,r2,coro2) when coro1 = coro2 && List.length l1 = List.length l2 -> let i = ref 0 in (try type_eq uctx r1 r2; @@ -755,7 +755,7 @@ let rec unify (uctx : unification_context) a b = | _ -> false) in if not (loop c1 tl1) then error [cannot_unify a b] - | TFun (l1,r1) , TFun (l2,r2) when List.length l1 = List.length l2 -> + | TFun (l1,r1,coro1) , TFun (l2,r2,coro2) when coro1 = coro2 && List.length l1 = List.length l2 -> let uctx = get_nested_context uctx in let i = ref 0 in (try @@ -1065,7 +1065,7 @@ and unifies_to_direct uctx a b ab tl t = and unifies_from_field uctx a b ab tl (t,cf) = does_func_unify (fun() -> match follow cf.cf_type with - | TFun(_,r) -> + | TFun(_,r,_) -> let map = apply_params ab.a_params tl in let monos = Monomorph.spawn_constrained_monos map cf.cf_params in let map t = map (apply_params cf.cf_params monos t) in @@ -1078,7 +1078,7 @@ and unifies_from_field uctx a b ab tl (t,cf) = and unifies_to_field uctx a b ab tl (t,cf) = does_func_unify (fun() -> match follow cf.cf_type with - | TFun((_,_,ta) :: _,_) -> + | TFun((_,_,ta) :: _,_,_) -> let map = apply_params ab.a_params tl in let monos = Monomorph.spawn_constrained_monos map cf.cf_params in let map t = map (apply_params cf.cf_params monos t) in @@ -1144,7 +1144,7 @@ and unify_with_variance uctx f t1 t2 = compare_underlying(); | TAnon(a1),TAnon(a2) -> unify_anons uctx t1 t2 a1 a2 - | TFun(al1,r1),TFun(al2,r2) when List.length al1 = List.length al2 -> + | TFun(al1,r1,coro1),TFun(al2,r2,coro2) when coro1 = coro2 && List.length al1 = List.length al2 -> List.iter2 (fun (_,_,t1) (_,_,t2) -> unify_nested t1 t2) al1 al2; unify_nested r1 r2; | _ -> diff --git a/src/core/texpr.ml b/src/core/texpr.ml index e089d306197..992c40af6b1 100644 --- a/src/core/texpr.ml +++ b/src/core/texpr.ml @@ -571,7 +571,7 @@ module Builder = struct in let ef = make_static_field c cf (mk_zero_range_pos p) in let tret = match follow ef.etype with - | TFun(_,r) -> r + | TFun(_,r,_) -> r | _ -> assert false in mk (TCall (ef, args)) tret p diff --git a/src/filters/ES6Ctors.ml b/src/filters/ES6Ctors.ml index 8dd2b526fcb..1d02852af2b 100644 --- a/src/filters/ES6Ctors.ml +++ b/src/filters/ES6Ctors.ml @@ -61,7 +61,7 @@ let has_this_before_super e = let get_num_args cf = match follow cf.cf_type with - | TFun (args, _) -> List.length args + | TFun (args, _, _) -> List.length args | _ -> die "" __LOC__ (* diff --git a/src/filters/addFieldInits.ml b/src/filters/addFieldInits.ml index 91e302294b1..9ea6436c3ad 100644 --- a/src/filters/addFieldInits.ml +++ b/src/filters/addFieldInits.ml @@ -29,7 +29,7 @@ let add_field_inits cl_path locals com t = let el = if !need_this then (mk (TVar((v, Some ethis))) ethis.etype ethis.epos) :: el else el in let cf = match c.cl_constructor with | None -> - let ct = TFun([],com.basic.tvoid) in + let ct = TFun([],com.basic.tvoid,false) in let ce = mk (TFunction { tf_args = []; tf_type = com.basic.tvoid; diff --git a/src/filters/capturedVars.ml b/src/filters/capturedVars.ml index b5bf1f81c3f..ef708bfeaad 100644 --- a/src/filters/capturedVars.ml +++ b/src/filters/capturedVars.ml @@ -172,7 +172,7 @@ let captured_vars com e = tf_args = List.map (fun (_,v) -> v, None) new_vars; tf_type = e.etype; tf_expr = mk_block (mk (TReturn (Some e)) e.etype e.epos); - }) (TFun (List.map (fun (_,v) -> v.v_name,false,v.v_type) new_vars,e.etype)) e.epos), + }) (TFun (List.map (fun (_,v) -> v.v_name,false,v.v_type) new_vars,e.etype,false)) e.epos), List.map (fun v -> mk (TLocal v) v.v_type e.epos) vars) ) e.etype e.epos else diff --git a/src/filters/defaultArguments.ml b/src/filters/defaultArguments.ml index 3a13b79d190..97d7daf85bb 100644 --- a/src/filters/defaultArguments.ml +++ b/src/filters/defaultArguments.ml @@ -64,7 +64,7 @@ let rec change_func com cl cf = () | Var _, _ | Method MethDynamic, _ -> () - | _, TFun(args, ret) -> + | _, TFun(args, ret, coro) -> let is_ctor = cf.cf_name = "new" in let basic = com.basic in @@ -135,7 +135,7 @@ let rec change_func com cl cf = args := List.map (fun (v,s) -> (v.v_name, (s <> None), v.v_type)) tf_args; - let cf_type = TFun (!args, ret) in + let cf_type = TFun (!args, ret, coro) in cf.cf_expr <- Some { texpr with eexpr = TFunction { tf with tf_args = tf_args; @@ -146,7 +146,7 @@ let rec change_func com cl cf = cf.cf_type <- cf_type | _ -> ()); - (if !found then cf.cf_type <- TFun(!args, ret)) + (if !found then cf.cf_type <- TFun(!args, ret, coro)) | _, _ -> Globals.die "" __LOC__ let run com md = diff --git a/src/filters/exceptions.ml b/src/filters/exceptions.ml index 9be6fae7503..af434949b7f 100644 --- a/src/filters/exceptions.ml +++ b/src/filters/exceptions.ml @@ -36,7 +36,7 @@ let haxe_exception_static_call ctx method_name args p = in let return_type = match follow method_field.cf_type with - | TFun(_,t) -> t + | TFun(_,t,_) -> t | _ -> raise_typing_error ("haxe.Exception." ^ method_name ^ " is not a function and cannot be called") p in add_dependency ctx.typer.c.curclass.cl_module ctx.haxe_exception_class.cl_module; @@ -51,7 +51,7 @@ let haxe_exception_instance_call ctx haxe_exception method_name args p = let efield = { eexpr = TField(haxe_exception,faccess); etype = cf.cf_type; epos = p } in let rt = match follow cf.cf_type with - | TFun(_,t) -> t + | TFun(_,t,_) -> t | _ -> raise_typing_error ((s_type (print_context()) haxe_exception.etype) ^ "." ^ method_name ^ " is not a function and cannot be called") p in @@ -70,7 +70,7 @@ let std_is ctx e t p = in let return_type = match follow isOfType_field.cf_type with - | TFun(_,t) -> t + | TFun(_,t,_) -> t | _ -> raise_typing_error ("Std.isOfType is not a function and cannot be called") p in let type_expr = TyperBase.type_module_type ctx.typer (module_type_of_type t) p in @@ -600,7 +600,7 @@ let insert_save_stacks tctx = in let return_type = match follow method_field.cf_type with - | TFun(_,t) -> t + | TFun(_,t,_) -> t | _ -> raise_typing_error ("haxe.NativeStackTrace." ^ method_field.cf_name ^ " is not a function and cannot be called") null_pos in let catch_local = mk (TLocal catch_var) catch_var.v_type catch_var.v_pos in @@ -662,7 +662,7 @@ let patch_constructors tctx = let efield = { eexpr = TField(this,faccess); etype = cf.cf_type; epos = p } in let rt = match follow cf.cf_type with - | TFun(_,t) -> t + | TFun(_,t,_) -> t | _ -> raise_typing_error "haxe.Exception.__shiftStack is not a function and cannot be called" cf.cf_name_pos in diff --git a/src/filters/filters.ml b/src/filters/filters.ml index d9a1077fe60..83a0fad015a 100644 --- a/src/filters/filters.ml +++ b/src/filters/filters.ml @@ -522,7 +522,7 @@ let update_cache_dependencies com t = | TAbstract(a,tl) -> add_dependency m a.a_module; List.iter (check_t m) tl; - | TFun(targs,tret) -> + | TFun(targs,tret,_) -> List.iter (fun (_,_,t) -> check_t m t) targs; check_t m tret; | TAnon an -> diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 05fcb19cf10..93580a4b35c 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -845,7 +845,7 @@ and type_string_suff suffix haxe_type remap = "::cpp::Function< " ^ (cpp_function_signature_params params ) ^ " >" | _ -> type_string_suff suffix (apply_typedef type_def params) remap ) - | TFun (args,haxe_type) -> "Dynamic" ^ suffix + | TFun (args,haxe_type,_) -> "Dynamic" ^ suffix | TAnon a -> "Dynamic" (* (match !(a.a_status) with @@ -888,7 +888,7 @@ and is_dynamic_array_param haxe_type = ) and cpp_function_signature tfun abi = match follow tfun with - | TFun(args,ret) -> (type_string ret) ^ " " ^ abi ^ "(" ^ (gen_tfun_interface_arg_list args) ^ ")" + | TFun(args,ret,_) -> (type_string ret) ^ " " ^ abi ^ "(" ^ (gen_tfun_interface_arg_list args) ^ ")" | _ -> "void *" and cpp_function_signature_params params = match params with @@ -1196,7 +1196,7 @@ let is_super expression = let rec is_dynamic_in_cpp ctx expr = - let expr_type = type_string ( match follow expr.etype with TFun (args,ret) -> ret | _ -> expr.etype) in + let expr_type = type_string ( match follow expr.etype with TFun (args,ret,_) -> ret | _ -> expr.etype) in if ( expr_type="Dynamic" || expr_type="cpp::ArrayBase") then true else begin @@ -1226,7 +1226,7 @@ let rec is_dynamic_in_cpp ctx expr = true else (match follow func.etype with - | TFun (args,ret) -> is_dynamic_in_cpp ctx func + | TFun (args,ret,_) -> is_dynamic_in_cpp ctx func | _ -> true ); | TParenthesis(expr) | TMeta(_,expr) -> is_dynamic_in_cpp ctx expr @@ -1304,7 +1304,7 @@ let is_matching_interface_type t0 t1 = let get_nth_type field index = match follow field.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> let rec nth l index = match l with | [] -> raise Not_found | (_,_,t)::rest -> @@ -1950,7 +1950,7 @@ let rec cpp_type_of stack ctx haxe_type = and cpp_function_type_of_args_ret stack ctx function_type = match follow function_type with - | TFun(args,ret) -> + | TFun(args,ret,_) -> (* Optional types are Dynamic if they norally could not be null *) let cpp_arg_type_of = fun(_,optional,haxe_type) -> if optional then @@ -1993,7 +1993,7 @@ and cpp_instance_type ctx = cpp_instance_type [] ctx let cpp_return_type ctx haxe_type = match haxe_type with - | TFun (_,ret) -> cpp_type_of ctx ret + | TFun (_,ret,_) -> cpp_type_of ctx ret | _ -> TCppDynamic ;; @@ -2209,7 +2209,7 @@ let cpp_macro_var_type_of ctx var = let ctx_function_signature ctx include_names tfun abi = match follow tfun with - | TFun(args,ret) -> (ctx_type_string ctx ret) ^ " " ^ abi ^ "(" ^ (ctx_tfun_arg_list ctx include_names args) ^ ")" + | TFun(args,ret,_) -> (ctx_type_string ctx ret) ^ " " ^ abi ^ "(" ^ (ctx_tfun_arg_list ctx include_names args) ^ ")" | _ -> "void *" @@ -2816,7 +2816,7 @@ let retype_expression ctx request_type function_args function_type expression_tr *) (* Other functions ... *) - | CppFunction( FuncInstance(_, InstStruct, {cf_type=TFun(arg_types,_)}) as func, return_type) -> + | CppFunction( FuncInstance(_, InstStruct, {cf_type=TFun(arg_types,_,_)}) as func, return_type) -> (* For struct access classes use the types of the arguments instead of the function argument types *) (* In the case of generic extern classes a TFun arg type could be `MyClass.T` instead of the real type *) let map_args func_arg passed_arg = @@ -2827,9 +2827,9 @@ let retype_expression ctx request_type function_args function_type expression_tr let retypedArgs = retype_function_args args arg_types in CppCall(func,retypedArgs), return_type - | CppFunction( FuncInstance(_,_,{cf_type=TFun(arg_types,_)} ) as func, returnType ) - | CppFunction( FuncStatic(_,_,{cf_type=TFun(arg_types,_)} ) as func, returnType ) - | CppFunction( FuncThis({cf_type=TFun(arg_types,_)},_ ) as func, returnType ) -> + | CppFunction( FuncInstance(_,_,{cf_type=TFun(arg_types,_,_)} ) as func, returnType ) + | CppFunction( FuncStatic(_,_,{cf_type=TFun(arg_types,_,_)} ) as func, returnType ) + | CppFunction( FuncThis({cf_type=TFun(arg_types,_,_)},_ ) as func, returnType ) -> let arg_types = List.map (fun (_,opt,t) -> cpp_tfun_arg_type_of ctx opt t) arg_types in (* retype args specifically (not just CppDynamic) *) let retypedArgs = retype_function_args args arg_types in @@ -4405,7 +4405,7 @@ let is_override field = let current_virtual_functions_rev clazz base_functions = List.fold_left (fun result elem -> match follow elem.cf_type, elem.cf_kind with | _, Method MethDynamic -> result - | TFun (args,return_type), Method _ -> + | TFun (args,return_type,_), Method _ -> if (is_override elem ) then List.map (fun (e,a,r) -> if e.cf_name<>elem.cf_name then (e,a,r) else (elem,args,return_type) ) result else @@ -4454,7 +4454,7 @@ let all_virtual_functions clazz override_types = let rec unreflective_type t = match follow t with | TInst (klass,_) -> Meta.has Meta.Unreflective klass.cl_meta - | TFun (args,ret) -> + | TFun (args,ret,_) -> List.fold_left (fun result (_,_,t) -> result || (unreflective_type t)) (unreflective_type ret) args; | _ -> false ;; @@ -4474,7 +4474,7 @@ let reflective class_def field = not ( let field_arg_count field = match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> -1 - | TFun (args,return_type), Method _ -> List.length args + | TFun (args,return_type,_), Method _ -> List.length args | _,_ -> -1 ;; @@ -4629,7 +4629,7 @@ let gen_field ctx class_def class_name ptr_name dot_name is_static is_interface output ( " " ^ class_name ^ "::" ^ remap_name ^ ";\n\n"); end else if has_class_field_flag field CfAbstract then begin let tl,tr = match follow field.cf_type with - | TFun(tl,tr) -> tl,tr + | TFun(tl,tr,_) -> tl,tr | _ -> die "" __LOC__ in let nargs = string_of_int (List.length tl) in @@ -4694,7 +4694,7 @@ let gen_member_def ctx class_def is_static is_interface field = if (is_interface) then begin match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () - | TFun (args,return_type), Method _ -> + | TFun (args,return_type,_), Method _ -> let gen_args = ctx_tfun_arg_list ctx true in if is_static || nativeGen then begin output ( (if (not is_static) then " virtual " else " " ) ^ (ctx_type_string ctx return_type) ); @@ -4763,7 +4763,7 @@ let gen_member_def ctx class_def is_static is_interface field = String.concat "," (List.map (fun (n,o,t) -> (ctx_arg ctx n None t prefix) ) arg_list) in let tl,tr = match follow field.cf_type with - | TFun(tl,tr) -> tl,tr + | TFun(tl,tr,_) -> tl,tr | _ -> die "" __LOC__ in let return_type = (ctx_type_string ctx tr) in @@ -4794,7 +4794,7 @@ let gen_member_def ctx class_def is_static is_interface field = (* Add a "dyn" function for variable to unify variable/function access *) (match follow field.cf_type with | _ when nativeGen -> () - | TFun (_,_) -> + | TFun (_,_,_) -> output (if is_static then "\t\tstatic " else "\t\t"); output ("Dynamic " ^ remap_name ^ "_dyn() { return " ^ remap_name ^ ";}\n" ) | _ -> (match field.cf_kind with @@ -4895,7 +4895,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h ) | TAbstract (a,params) when is_scalar_abstract a -> add_extern_type (TAbstractDecl a) - | TFun (args,haxe_type) -> visit_type haxe_type; + | TFun (args,haxe_type,_) -> visit_type haxe_type; List.iter (fun (_,_,t) -> visit_type t; ) args; | _ -> () end; @@ -4987,7 +4987,7 @@ let find_referenced_types_flags ctx obj field_name super_deps constructor_deps h add_type enum_def.e_path; PMap.iter (fun _ constructor -> (match constructor.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> List.iter (fun (_,_,t) -> visit_type t; ) args; | _ -> () ); ) enum_def.e_constrs; @@ -5246,7 +5246,7 @@ let generate_enum_files baseCtx enum_def super_deps meta = PMap.iter (fun _ constructor -> let name = keyword_remap constructor.ef_name in match constructor.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> output_cpp (remap_class_name ^ " " ^ class_name ^ "::" ^ name ^ "(" ^ (ctx_tfun_arg_list ctx true args) ^")\n"); @@ -5260,7 +5260,7 @@ let generate_enum_files baseCtx enum_def super_deps meta = let constructor_arg_count constructor = - (match constructor.ef_type with | TFun(args,_) -> List.length args | _ -> 0 ) + (match constructor.ef_type with | TFun(args,_,_) -> List.length args | _ -> 0 ) in output_cpp ("bool " ^ class_name ^ "::__GetStatic(const ::String &inName, ::Dynamic &outValue, ::hx::PropertyAccess inCallProp)\n{\n"); @@ -5354,7 +5354,7 @@ let generate_enum_files baseCtx enum_def super_deps meta = PMap.iter (fun _ constructor -> let name = constructor.ef_name in match constructor.ef_type with - | TFun (_,_) -> () + | TFun (_,_,_) -> () | _ -> output_cpp ( (keyword_remap name) ^ " = ::hx::CreateConstEnum< " ^ class_name ^ " >(" ^ (strq name) ^ "," ^ (string_of_int constructor.ef_index) ^ ");\n" ) @@ -5403,7 +5403,7 @@ let generate_enum_files baseCtx enum_def super_deps meta = let name = keyword_remap constructor.ef_name in output_h ( "\t\tstatic " ^ remap_class_name ^ " " ^ name ); match constructor.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> output_h ( "(" ^ (ctx_tfun_arg_list ctx true args) ^");\n"); output_h ( "\t\tstatic ::Dynamic " ^ name ^ "_dyn();\n"); | _ -> @@ -5560,7 +5560,7 @@ let find_class_implementation ctx class_def name interface = with FieldFound field -> match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> "" - | TFun (args,return_type), Method _ -> + | TFun (args,return_type,_), Method _ -> cpp_tfun_signature ctx false args return_type | _,_ -> "" ;; @@ -5635,7 +5635,7 @@ let constructor_arg_var_list class_def ctx = function_def.tf_args; | _ -> (match follow definition.cf_type with - | TFun (args,_) -> List.map (fun (a,_,t) -> (a, (ctx_type_string ctx t, a)) ) args + | TFun (args,_,_) -> List.map (fun (a,_,t) -> (a, (ctx_type_string ctx t, a)) ) args | _ -> []) ) | _ -> [] @@ -5700,7 +5700,7 @@ let generate_protocol_delegate ctx class_def output = let dump_delegate field = match field.cf_type with - | TFun(args,ret) -> + | TFun(args,ret,_) -> let retStr = ctx_type_string ctx ret in let nativeName = get_meta_string field.cf_meta Meta.ObjcProtocol in let fieldName,argNames = if nativeName<>"" then begin @@ -6031,7 +6031,7 @@ let generate_class_files baseCtx super_deps constructor_deps class_def inScripta let rec gen_interface_funcs interface = let gen_field field = (match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () - | TFun (args,return_type), Method _ -> + | TFun (args,return_type,_), Method _ -> let cast = cpp_tfun_signature ctx false args return_type in let class_implementation = find_class_implementation ctx class_def field.cf_name interface in let realName= cpp_member_name_of field in @@ -6408,7 +6408,7 @@ let generate_class_files baseCtx super_deps constructor_deps class_def inScripta let generate_script_function isStatic field scriptName callName = match follow field.cf_type with - | TFun (args,return_type) when not (is_data_member field) -> + | TFun (args,return_type,_) when not (is_data_member field) -> let isTemplated = not isStatic && not (has_class_flag class_def CInterface) in if isTemplated then output_cpp ("\ntemplate"); output_cpp ("\nstatic void CPPIA_CALL " ^ scriptName ^ "(::hx::CppiaCtx *ctx) {\n"); @@ -6834,7 +6834,7 @@ let generate_class_files baseCtx super_deps constructor_deps class_def inScripta List.iter (fun field -> match follow field.cf_type, field.cf_kind with | _, Method MethDynamic -> () - | TFun (args,return_type), _ -> + | TFun (args,return_type,_), _ -> let retVal = ctx_type_string ctx return_type in let ret = if retVal="void" then "" else "return " in let name = keyword_remap field.cf_name in @@ -7827,7 +7827,7 @@ class script_writer ctx filename asciiOut = this#gen_expression func; ); let matched_args = match func.etype with - | TFun (args,_) -> + | TFun (args,_,_) -> ( try ( List.iter2 (fun (_,_,protoT) arg -> this#checkCast protoT arg false false) args arg_list; true; ) @@ -7911,7 +7911,7 @@ class script_writer ctx filename asciiOut = this#write ((this#op IaNew) ^ (this#typeText (TInst(clazz,params))) ^ (string_of_int (List.length arg_list)) ^ "\n"); (try match OverloadResolution.maybe_resolve_constructor_overload clazz params arg_list with - | Some (_,{ cf_type = TFun(args,_) },_) -> + | Some (_,{ cf_type = TFun(args,_,_) },_) -> List.iter2 (fun (_,_,protoT) arg -> this#checkCast protoT arg false false) args arg_list; | _ -> raise (Invalid_argument "") @@ -7949,7 +7949,7 @@ class script_writer ctx filename asciiOut = this#gen_expression loop; | TEnumParameter (expr,ef,i) -> let enum = match follow ef.ef_type with - | TEnum(en,_) | TFun(_,TEnum(en,_)) -> en + | TEnum(en,_) | TFun(_,TEnum(en,_),_) -> en | _ -> die "" __LOC__ in this#write ( (this#op IaEnumI) ^ (this#typeText (TEnum(enum,[])) ) ^ (string_of_int i) ^ "\n"); @@ -8400,11 +8400,11 @@ let generate_script_class common_ctx script class_def = in let isExtern = not (is_physical_field field) in script#var (mode_code v.v_read) (mode_code v.v_write) isExtern isStatic field.cf_name field.cf_type field.cf_expr - | Method MethDynamic, TFun(args,ret) -> + | Method MethDynamic, TFun(args,ret,_) -> script#func isStatic true field.cf_name ret args (has_class_flag class_def CInterface) field.cf_expr field.cf_pos - | Method _, TFun(args,ret) when field.cf_name="new" -> + | Method _, TFun(args,ret,_) when field.cf_name="new" -> script#func true false "new" (TInst(class_def,[])) args false field.cf_expr field.cf_pos - | Method _, TFun (args,ret) -> + | Method _, TFun (args,ret,_) -> script#func isStatic false field.cf_name ret args (has_class_flag class_def CInterface) field.cf_expr field.cf_pos | Method _, _ -> print_endline ("Unknown method type " ^ (join_class_path class_def.cl_path "." ) ^ "." ^field.cf_name ) @@ -8429,7 +8429,7 @@ let generate_script_enum common_ctx script enum_def meta = List.iter (fun constructor -> let name = script#stringText constructor.ef_name in match constructor.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> script#write ( name ^ " " ^ (string_of_int (List.length args)) ); List.iter (fun (arg,_,t) -> script#write ( " " ^ (script#stringText arg) ^ " " ^ (script#typeText t) ) ) args; script#write "\n"; diff --git a/src/generators/genhl.ml b/src/generators/genhl.ml index e3ba1481b68..1a17b58663f 100644 --- a/src/generators/genhl.ml +++ b/src/generators/genhl.ml @@ -139,7 +139,7 @@ type access = let is_to_string t = match follow t with - | TFun([],r) -> (match follow r with TInst({ cl_path=[],"String" },[]) -> true | _ -> false) + | TFun([],r,_) -> (match follow r with TInst({ cl_path=[],"String" },[]) -> true | _ -> false) | _ -> false let is_string = function @@ -294,7 +294,7 @@ let array_class ctx t = let member_fun c t = match follow t with - | TFun (args, ret) -> TFun (("this",false,TInst(c,[])) :: args, ret) + | TFun (args, ret, coro) -> TFun (("this",false,TInst(c,[])) :: args, ret, coro) | _ -> die "" __LOC__ let rec unsigned t = @@ -395,7 +395,7 @@ let rec to_type ?tref ctx t = | _ -> t) | TLazy f -> to_type ?tref ctx (lazy_type f) - | TFun (args, ret) -> + | TFun (args, ret, _) -> HFun (List.map (fun (_,o,t) -> let pt = to_type ctx t in if o && not (is_nullable pt) then HRef pt else pt @@ -523,7 +523,7 @@ and real_type ctx e = | TField (_,f) -> let ft = field_type ctx f e.epos in (match ft, e.etype with - | TFun (args,ret), TFun (args2,_) -> + | TFun (args,ret,coro1), TFun (args2,_,coro2) -> TFun (List.map2 (fun ((name,opt,t) as a) ((_,_,t2) as a2) -> match t, t2 with (* @@ -540,7 +540,7 @@ and real_type ctx e = (name, opt, TAbstract (fake_tnull,[t])) | _ -> a - ) args args2, ret) + ) args args2, ret, coro1) | _ -> ft) | TLocal v -> v.v_type | TParenthesis e -> loop e @@ -721,7 +721,7 @@ and enum_type ?(tref=None) ctx e = et.efields <- Array.of_list (List.map (fun f -> let f = PMap.find f e.e_constrs in let args = (match f.ef_type with - | TFun (args,_) -> Array.of_list (List.map (fun (_,_,t) -> to_type ctx t) args) + | TFun (args,_,_) -> Array.of_list (List.map (fun (_,_,t) -> to_type ctx t) args) | _ -> [||] ) in (f.ef_name, alloc_string ctx f.ef_name, args) @@ -2195,7 +2195,7 @@ and eval_expr ctx e = let rt = to_type ctx e.etype in let is_valid_method t = match follow t with - | TFun (_,rt) -> + | TFun (_,rt,_) -> (match follow rt with | TInst({ cl_kind = KTypeParameter ttp },_) -> (* don't allow if we have a constraint virtual, see hxbit.Serializer.getRef *) @@ -2251,7 +2251,7 @@ and eval_expr ctx e = let fid = alloc_fun_path ctx en.e_path name in if fid = cur_fid then begin let ef = PMap.find name en.e_constrs in - let eargs, et = (match follow ef.ef_type with TFun (args,ret) -> args, ret | _ -> die "" __LOC__) in + let eargs, et = (match follow ef.ef_type with TFun (args,ret,_) -> args, ret | _ -> die "" __LOC__) in let ct = ctx.com.basic in let p = ef.ef_pos in let eargs = List.map (fun (n,o,t) -> Type.alloc_var VGenerated n t en.e_pos, if o then Some (mk (TConst TNull) t_dynamic null_pos) else None) eargs in @@ -3446,7 +3446,7 @@ let generate_member ctx c f = | Some { eexpr = TFunction f } -> f | None when has_class_field_flag f CfAbstract -> let tl,tr = match follow f.cf_type with - | TFun(tl,tr) -> tl,tr + | TFun(tl,tr,_) -> tl,tr | _ -> die "" __LOC__ in let args = List.map (fun (n,_,t) -> diff --git a/src/generators/genhxold.ml b/src/generators/genhxold.ml index 5f8660319f6..c5f79fe9f8d 100644 --- a/src/generators/genhxold.ml +++ b/src/generators/genhxold.ml @@ -108,9 +108,9 @@ let generate_type com t = "Dynamic" | TDynamic (Some t2) -> "Dynamic<" ^ stype t2 ^ ">" - | TFun ([],ret) -> + | TFun ([],ret,_) -> "() -> " ^ ftype ret - | TFun (args,ret) -> + | TFun (args,ret,_) -> String.concat " -> " (List.map (fun (_,_,t) -> ftype t) args) ^ " -> " ^ ftype ret and ftype t = match t with @@ -176,7 +176,7 @@ let generate_type com t = p " : %s" (stype f.cf_type); | Method m -> let params, ret = (match follow f.cf_type with - | TFun (args,ret) -> + | TFun (args,ret,_) -> List.map (fun (a,o,t) -> let rec loop = function | [] -> Ident "null" @@ -256,7 +256,7 @@ let generate_type com t = let c = PMap.find n e.e_constrs in p "\t%s" c.ef_name; (match follow c.ef_type with - | TFun (args,_) -> p "(%s)" (String.concat ", " (List.map sparam (List.map (fun (a,o,t) -> a,(if o then Some (Ident "null") else None),t) args))) + | TFun (args,_,_) -> p "(%s)" (String.concat ", " (List.map sparam (List.map (fun (a,o,t) -> a,(if o then Some (Ident "null") else None),t) args))) | _ -> ()); p ";\n"; ) e.e_names; diff --git a/src/generators/genjs.ml b/src/generators/genjs.ml index 05eae361308..1943646b06c 100644 --- a/src/generators/genjs.ml +++ b/src/generators/genjs.ml @@ -557,7 +557,7 @@ and gen_expr ctx e = | TEnumParameter (x,f,i) -> gen_value ctx x; if not (Common.defined ctx.com Define.JsEnumsAsArrays) then - let fname = (match f.ef_type with TFun((args,_)) -> let fname,_,_ = List.nth args i in fname | _ -> die "" __LOC__ ) in + let fname = (match f.ef_type with TFun((args,_,_)) -> let fname,_,_ = List.nth args i in fname | _ -> die "" __LOC__ ) in print ctx ".%s" (ident fname) else print ctx "[%i]" (i + 2) @@ -1525,7 +1525,7 @@ let generate_enum ctx e = end else print ctx "%s%s = " p (field f.ef_name); (match f.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> let sargs = String.concat "," (List.map (fun (n,_,_) -> ident n) args) in begin if as_objects then begin let sfields = String.concat "," (List.map (fun (n,_,_) -> (ident n) ^ ":" ^ (ident n) ) args) in diff --git a/src/generators/genjvm.ml b/src/generators/genjvm.ml index 4c1a8fa664d..d7d36e4c912 100644 --- a/src/generators/genjvm.ml +++ b/src/generators/genjvm.ml @@ -196,7 +196,7 @@ let rec jsignature_of_type gctx stack t = | TEnum(en,tl) -> Hashtbl.replace gctx.enum_paths en.e_path (); TObject(en.e_path,List.map jtype_argument_of_type tl) - | TFun(tl,tr) -> method_sig (List.map (fun (_,o,t) -> + | TFun(tl,tr,_) -> method_sig (List.map (fun (_,o,t) -> let jsig = jsignature_of_type t in let jsig = if o then get_boxed_type jsig else jsig in jsig @@ -719,7 +719,7 @@ class texpr_to_jvm method read cast e1 fa = let read_static_closure path cf = let args,ret = match follow cf.cf_type with - | TFun(tl,tr) -> List.map (fun (n,_,t) -> n,self#vtype t) tl,(return_of_type gctx tr) + | TFun(tl,tr,_) -> List.map (fun (n,_,t) -> n,self#vtype t) tl,(return_of_type gctx tr) | _ -> die "" __LOC__ in self#read_static_closure path cf.cf_name args ret cf.cf_type @@ -1504,7 +1504,7 @@ class texpr_to_jvm method call_arguments ?(cast=true) t el = let tl,tr = match follow t with - | TFun(tl,tr) -> + | TFun(tl,tr,_) -> tl,return_of_type gctx tr | _ -> List.map (fun e -> ("",false,e.etype)) el,Some (object_sig) @@ -2142,7 +2142,7 @@ class texpr_to_jvm | TEnumParameter(e1,ef,i) -> self#texpr rvalue_any e1; let path,name,jsig_arg = match follow ef.ef_type with - | TFun(tl,tr) -> + | TFun(tl,tr,_) -> let en = match follow tr with | TEnum(en,_) -> en | _ -> die "" __LOC__ @@ -2376,7 +2376,7 @@ class tclass_to_jvm gctx c = object(self) in let find_overload map_type c cf = let tl = match follow (map_type cf.cf_type) with - | TFun(tl,_) -> tl + | TFun(tl,_,_) -> tl | _ -> die "" __LOC__ in OverloadResolution.resolve_instance_overload false map_type c cf.cf_name (List.map (fun (_,_,t) -> Texpr.Builder.make_null t null_pos) tl) @@ -2473,7 +2473,7 @@ class tclass_to_jvm gctx c = object(self) DynArray.iter (fun e -> handler#texpr RVoid e; ) field_inits; - let tl = match follow cf.cf_type with TFun(tl,_) -> tl | _ -> die "" __LOC__ in + let tl = match follow cf.cf_type with TFun(tl,_,_) -> tl | _ -> die "" __LOC__ in List.iter (fun (n,_,t) -> let _,load,_ = jm#add_local n (jsignature_of_type gctx t) VarArgument in load(); @@ -2798,7 +2798,7 @@ let generate_enum gctx en = let names = List.map (fun name -> let ef = PMap.find name en.e_constrs in let args = match follow ef.ef_type with - | TFun(tl,_) -> List.map (fun (n,_,t) -> n,jsignature_of_type gctx t) tl + | TFun(tl,_,_) -> List.map (fun (n,_,t) -> n,jsignature_of_type gctx t) tl | _ -> [] in let jsigs = List.map snd args in @@ -2938,7 +2938,7 @@ let generate_anons gctx = let jsig_cf = jsignature_of_type gctx cf.cf_type in let jm = jc#spawn_method cf.cf_name jsig_cf [MPublic] in let tl,tr = match follow cf.cf_type with - | TFun(tl,tr) -> tl,tr + | TFun(tl,tr,_) -> tl,tr | _ -> die "" __LOC__ in let locals = List.map (fun (n,_,t) -> diff --git a/src/generators/genlua.ml b/src/generators/genlua.ml index 176185edbcf..c0079dc9036 100644 --- a/src/generators/genlua.ml +++ b/src/generators/genlua.ml @@ -1768,7 +1768,7 @@ let generate_enum ctx e = let f = PMap.find n e.e_constrs in print ctx "%s%s = " p (field f.ef_name); (match f.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> let count = List.length args in let sargs = String.concat "," (List.map (fun (n,_,_) -> ident n) args) in print ctx "function(%s) local _x = _hx_tab_array({[0]=\"%s\",%d,%s,__enum__=%s}, %i);" sargs f.ef_name f.ef_index sargs p (count + 2); @@ -2197,7 +2197,7 @@ let generate com = tf_expr = mk (TBlock [e;luv_run]) com.basic.tvoid e.epos; } in - gen_value ctx { e with eexpr = TFunction fn; etype = TFun ([],com.basic.tvoid) }; + gen_value ctx { e with eexpr = TFunction fn; etype = TFun ([],com.basic.tvoid,false) }; println ctx ", _hx_handle_error)"; println ctx "if not success then _G.error(err) end"; ) com.main.main_expr; diff --git a/src/generators/genneko.ml b/src/generators/genneko.ml index ce081ea0f7b..b6ba024a089 100644 --- a/src/generators/genneko.ml +++ b/src/generators/genneko.ml @@ -236,7 +236,7 @@ and gen_expr ctx e = gen_binop ctx p op e1 e2 | TField (e2,FClosure (_,f)) -> (match follow e.etype with - | TFun (args,_) -> + | TFun (args,_,_) -> let n = List.length args in if n > 5 then Error.abort "Cannot create closure with more than 5 arguments" e.epos; let tmp = ident p "@tmp" in @@ -262,7 +262,7 @@ and gen_expr ctx e = gen_expr ctx e | TObjectDecl fl -> let hasToString = ref false in - let fl = List.map (fun ((f,_,_),e) -> if f = "toString" then hasToString := (match follow e.etype with TFun ([],_) -> true | _ -> false); f , gen_expr ctx e) fl in + let fl = List.map (fun ((f,_,_),e) -> if f = "toString" then hasToString := (match follow e.etype with TFun ([],_,_) -> true | _ -> false); f , gen_expr ctx e) fl in (EObject (if !hasToString then ("__string",ident p "@default__string") :: fl else fl),p) | TArrayDecl el -> call p (field p (ident p "Array") "new1") [array p (List.map (gen_expr ctx) el); int p (List.length el)] @@ -443,7 +443,7 @@ let gen_class ctx c = let fstring = (try let f = PMap.find "toString" c.cl_fields in match follow f.cf_type with - | TFun ([],_) -> ["__string",ident p "@default__string"] + | TFun ([],_,_) -> ["__string",ident p "@default__string"] | _ -> [] with Not_found -> [] @@ -511,7 +511,7 @@ let gen_enum_constr ctx path c = ctx.curmethod <- c.ef_name; let p = pos ctx c.ef_pos in (EBinop ("=",field p path c.ef_name, match follow c.ef_type with - | TFun (params,_) -> + | TFun (params,_,_) -> let params = List.map (fun (n,_,_) -> n) params in (EFunction (params, (EBlock [ diff --git a/src/generators/genphp7.ml b/src/generators/genphp7.ml index c36622206ff..d15c8c8297e 100644 --- a/src/generators/genphp7.ml +++ b/src/generators/genphp7.ml @@ -412,7 +412,7 @@ let rec needs_temp_var expr = *) let get_function_signature (field:tclass_field) : (string * bool * Type.t) list * Type.t = match follow field.cf_type with - | TFun (args, return_type) -> (args, return_type) + | TFun (args, return_type, _) -> (args, return_type) | _ -> fail field.cf_pos __LOC__ (** @@ -600,7 +600,7 @@ let fix_tsignature_args args = *) let fix_call_args callee_type exprs = match follow callee_type with - | TFun (args,_) -> + | TFun (args,_,_) -> (match List.rev args with | (_,_,t) :: args_rev when is_rest_type t && List.length args_rev > List.length exprs -> let rec loop args exprs = @@ -1492,7 +1492,7 @@ class code_writer (ctx:php_generator_context) hx_type_path php_name = match self#parent_expr with | Some { eexpr = TCall (target, params) } when current != (reveal_expr target) -> (match follow target.etype with - | TFun (args,_) -> + | TFun (args,_,_) -> let rec check args params = match args, params with | (_, _, t) :: _, param :: _ when current == (reveal_expr param) -> @@ -1519,7 +1519,7 @@ class code_writer (ctx:php_generator_context) hx_type_path php_name = | { eexpr = TBinop(OpAssign, left_expr, _) } :: _ | { eexpr = TBinop(OpAssignOp _, left_expr, _) } :: _ -> left_expr == current | { eexpr = TUnop(op, _, _) } :: _ -> is_modifying_unop op - | { eexpr = TCall({ etype = TFun(types,_) }, args) } :: _ when is_in_ref_arg current types args -> true + | { eexpr = TCall({ etype = TFun(types,_,_) }, args) } :: _ when is_in_ref_arg current types args -> true | [] -> false | parent :: rest -> traverse parent rest in @@ -3324,7 +3324,7 @@ class enum_builder ctx (enm:tenum) = method private write_constructor name (field:tenum_field) = let args = match follow field.ef_type with - | TFun (args, _) -> args + | TFun (args, _, _) -> args | TEnum _ -> [] | _ -> fail field.ef_pos __LOC__ in @@ -3395,7 +3395,7 @@ class enum_builder ctx (enm:tenum) = PMap.iter (fun name field -> let count = match follow field.ef_type with - | TFun (params, _) -> List.length params + | TFun (params, _, _) -> List.length params | TEnum _ -> 0 | _ -> fail field.ef_pos __LOC__ in @@ -3461,7 +3461,7 @@ class class_builder ctx (cls:tclass) = let fields = if is_static then cls.cl_statics else cls.cl_fields in try match (PMap.find name fields).cf_type with - | TFun (args,_) -> + | TFun (args,_,_) -> let rec count args mandatory total = match args with | [] -> @@ -3567,7 +3567,7 @@ class class_builder ctx (cls:tclass) = None else Some { - (mk_field "new" (TFun ([], ctx.pgc_common.basic.tvoid)) cls.cl_pos cls.cl_pos) with + (mk_field "new" (TFun ([], ctx.pgc_common.basic.tvoid, false)) cls.cl_pos cls.cl_pos) with cf_kind = Method MethNormal; cf_expr = Some { eexpr = TFunction { diff --git a/src/generators/genpy.ml b/src/generators/genpy.ml index 1a59a94fb3e..307c12fcb7a 100644 --- a/src/generators/genpy.ml +++ b/src/generators/genpy.ml @@ -46,7 +46,7 @@ module Utils = struct let mk_static_call c cf el p = let ef = mk_static_field c cf p in let tr = match follow ef.etype with - | TFun(args,tr) -> tr + | TFun(args,tr,_) -> tr | _ -> die "" __LOC__ in mk (TCall(ef,el)) tr p @@ -601,7 +601,7 @@ module Transformer = struct | _ -> die "" __LOC__) | _ -> die "" __LOC__ in - let f1 = { tf_args = []; tf_type = TFun([],ex.etype); tf_expr = ex} in + let f1 = { tf_args = []; tf_type = TFun([],ex.etype,false); tf_expr = ex} in let fexpr = mk (TFunction f1) ex.etype ex.epos in let fvar = to_tvar name fexpr.etype fexpr.epos in let f = add_non_locals_to_func fexpr in @@ -1458,7 +1458,7 @@ module Printer = struct do_default () | FAnon cf when is_assign && call_override(name) -> begin match follow cf.cf_type with - | TFun([],_) -> + | TFun([],_,_) -> Printf.sprintf "_hx_partial(HxOverrides.%s, %s)" name obj | _ -> do_default() @@ -2166,13 +2166,13 @@ module Generator = struct let const_constructors,param_constructors = List.partition (fun ef -> match follow ef.ef_type with - | TFun(_,_) -> false + | TFun(_,_,_) -> false | _ -> true ) enum_constructs in List.iter (fun ef -> match follow ef.ef_type with - | TFun(args, _) -> + | TFun(args, _, _) -> let arg_name hx_name = let name = handle_keywords hx_name in if name = p_name then p_name ^ "_" ^ name diff --git a/src/generators/genswf.ml b/src/generators/genswf.ml index 20b29992e84..44ce8cfc329 100644 --- a/src/generators/genswf.ml +++ b/src/generators/genswf.ml @@ -78,7 +78,7 @@ let build_dependencies t = if a.a_path <> ([],"Null") && Meta.has Meta.CoreType a.a_meta then add_path a.a_path DKType; List.iter (add_type_rec (t::l)) pl; - | TFun (pl,t2) -> + | TFun (pl,t2,_) -> List.iter (fun (_,_,t2) -> add_type_rec (t::l) t2) pl; add_type_rec (t::l) t2; | TAnon a -> diff --git a/src/generators/genswf9.ml b/src/generators/genswf9.ml index 6495c7a7456..ff81b6e3f27 100644 --- a/src/generators/genswf9.ml +++ b/src/generators/genswf9.ml @@ -1443,7 +1443,7 @@ and gen_call ctx retval e el r = | { eexpr = TUnop (Spread, Prefix, rest) } :: el_rev -> let null = mk (TConst TNull) t_dynamic null_pos and t_array_dyn = ctx.com.basic.tarray t_dynamic in - let t = TFun (["thisArg",false,t_dynamic; "argArray",false,t_array_dyn],r) in + let t = TFun (["thisArg",false,t_dynamic; "argArray",false,t_array_dyn],r,false) in let apply = mk (TField (e,FDynamic "apply")) t e.epos in gen_call ctx retval apply [null; args_as_array ctx (List.rev el_rev) rest e.epos] r (* normal call without `...rest` *) @@ -2141,7 +2141,7 @@ let generate_field_kind ctx f c stat = ); | _ when (has_class_flag c CInterface || has_class_field_flag f CfAbstract) && not stat -> (match follow f.cf_type, f.cf_kind with - | TFun (args,tret), Method (MethNormal | MethInline) -> + | TFun (args,tret,_), Method (MethNormal | MethInline) -> let dparams = ref None in List.iter (fun (_,o,t) -> match !dparams with @@ -2589,7 +2589,7 @@ let generate_class ctx c = ) c.cl_fields [] in let fields = if c.cl_path <> ctx.boot then fields else begin let cf = { - (mk_field "init" ~public:(ctx.swc && ctx.swf_protected) (TFun ([],t_dynamic)) c.cl_pos null_pos) with + (mk_field "init" ~public:(ctx.swc && ctx.swf_protected) (TFun ([],t_dynamic,false)) c.cl_pos null_pos) with cf_kind = Method MethNormal; } in { @@ -2705,7 +2705,7 @@ let generate_enum ctx e meta = hlf_name = ident f.ef_name; hlf_slot = !st_count; hlf_kind = (match f.ef_type with - | TFun (args,_) -> + | TFun (args,_,_) -> let fdata = begin_fun ctx (List.map (fun (a,opt,t) -> alloc_var VGenerated a t e.e_pos, (if opt then Some (mk (TConst TNull) t_dynamic null_pos) else None)) args) (TEnum (e,[])) [] true f.ef_pos in write ctx (HFindPropStrict name_id); write ctx (HString f.ef_name); diff --git a/src/macro/eval/evalMain.ml b/src/macro/eval/evalMain.ml index 6393c2436ad..70276caa4da 100644 --- a/src/macro/eval/evalMain.ml +++ b/src/macro/eval/evalMain.ml @@ -597,7 +597,7 @@ let handle_decoding_error f v t = begin match follow ef.ef_type,Array.to_list ev.eargs with | _,[] -> () - | TFun(tl,_),vl -> + | TFun(tl,_,_),vl -> f "("; loop2 true tl vl; f ")" diff --git a/src/macro/eval/evalPrototype.ml b/src/macro/eval/evalPrototype.ml index e7f8119cbad..3f8fee6456f 100644 --- a/src/macro/eval/evalPrototype.ml +++ b/src/macro/eval/evalPrototype.ml @@ -220,7 +220,7 @@ let create_static_prototype ctx mt = let names = List.map (fun name -> let ef = PMap.find name en.e_constrs in let args = match follow ef.ef_type with - | TFun(args,_) -> + | TFun(args,_,_) -> List.map (fun (n,_,_) -> hash n) args | _ -> [] @@ -229,7 +229,7 @@ let create_static_prototype ctx mt = ) en.e_names in let pctx = PrototypeBuilder.create ctx key None (PEnum names) meta in let enum_field_value ef = match follow ef.ef_type with - | TFun(args,_) -> + | TFun(args,_,_) -> let f = (fun vl -> encode_enum_value key ef.ef_index (Array.of_list vl) (Some ef.ef_pos)) in vstatic_function f | _ -> encode_enum_value key ef.ef_index [||] (Some ef.ef_pos) diff --git a/src/macro/macroApi.ml b/src/macro/macroApi.ml index cfaeb7086f5..389cb584068 100644 --- a/src/macro/macroApi.ml +++ b/src/macro/macroApi.ml @@ -1224,7 +1224,7 @@ and encode_type t = 2 , [encode_clref c; encode_tparams pl] | TType (t,pl) -> 3 , [encode_ref t encode_ttype (fun() -> s_type_path t.t_path); encode_tparams pl] - | TFun (pl,ret) -> + | TFun (pl,ret,coro) -> let pl = List.map (fun (n,o,t) -> encode_obj [ "name",encode_string n; @@ -1232,7 +1232,7 @@ and encode_type t = "t",encode_type t ] ) pl in - 4 , [encode_array pl; encode_type ret] + 4 , [encode_array pl; encode_type ret; vbool coro] | TAnon a -> 5, [encode_ref a encode_tanon (fun() -> "")] | TDynamic None -> @@ -1280,7 +1280,7 @@ and decode_type t = | 1, [e; pl] -> TEnum (decode_ref e, List.map decode_type (decode_array pl)) | 2, [c; pl] -> TInst (decode_ref c, List.map decode_type (decode_array pl)) | 3, [t; pl] -> TType (decode_ref t, List.map decode_type (decode_array pl)) - | 4, [pl; r] -> TFun (List.map (fun p -> decode_string (field p "name"), decode_bool (field p "opt"), decode_type (field p "t")) (decode_array pl), decode_type r) + | 4, [pl; r; coro] -> TFun (List.map (fun p -> decode_string (field p "name"), decode_bool (field p "opt"), decode_type (field p "t")) (decode_array pl), decode_type r, decode_opt_bool coro) | 5, [a] -> TAnon (decode_ref a) | 6, [t] -> if t = vnull then t_dynamic else TDynamic (Some (decode_type t)) | 7, [f] -> TLazy (decode_lazytype f) @@ -1472,7 +1472,7 @@ let decode_efield v = let rec get_enum t = match follow t with | TEnum (enm,_) -> enm - | TFun (_,t) -> get_enum t + | TFun (_,t,_) -> get_enum t | _ -> raise Not_found in let name = decode_string (field v "name") in diff --git a/src/optimization/analyzer.ml b/src/optimization/analyzer.ml index 1664f0e4698..5a0de1d7428 100644 --- a/src/optimization/analyzer.ml +++ b/src/optimization/analyzer.ml @@ -739,7 +739,16 @@ module Debug = struct let dot_debug_node g ch nil bb = let s = Printf.sprintf "(%i)" bb.bb_id in let s = List.fold_left (fun s ni -> s ^ match ni with - | NIExpr -> if DynArray.length bb.bb_el = 0 then "" else "\n" ^ String.concat "\n" (DynArray.to_list (DynArray.map s_expr_pretty bb.bb_el)) + | NIExpr -> + let sl = DynArray.to_list (DynArray.map s_expr_pretty bb.bb_el) in + let sl = match terminator_to_texpr_maybe bb.bb_terminator with + | None -> sl + | Some e -> sl @ [s_expr_pretty e] + in + begin match sl with + | [] -> "" + | _ -> "\n" ^ String.concat "\n" sl + end | NIPhi -> if DynArray.length bb.bb_phi = 0 then "" else "\n" ^ String.concat "\n" (DynArray.to_list (DynArray.map (fun e -> s_expr_pretty e) bb.bb_phi)) | NIVars -> if bb.bb_var_writes = [] then "" else "\n" ^ String.concat ", " (List.map (fun v -> s_var v) bb.bb_var_writes) | NILoopGroups -> if bb.bb_loop_groups = [] then "" else "\nLoops: " ^ (String.concat ", " (List.map string_of_int bb.bb_loop_groups)) @@ -795,6 +804,8 @@ module Debug = struct edge bb_next "next"; | SEMerge bb_next -> edge bb_next "merge" + | SESuspend (call, bb_next) -> + edge bb_next ("suspend " ^ s_expr_pretty (mk (TCall (call.efun, call.args)) t_dynamic call.pos)) | SESwitch ss -> List.iter (fun (el,bb) -> edge bb ("case " ^ (String.concat " | " (List.map s_expr_pretty el)))) ss.ss_cases; (match ss.ss_default with None -> () | Some bb -> edge bb "default"); @@ -1108,6 +1119,13 @@ module Run = struct let e = reduce_control_flow com e in maybe_debug(); cf.cf_expr <- Some e; + + (* lose Coroutine type here *) + (match cf.cf_type with + | TFun (args, ret, true) -> + let args = args @ [("",false,tfun [ret; t_dynamic] com.basic.tvoid)] in + cf.cf_type <- TFun (args, com.basic.tvoid, false); + | _ -> ()) | _ -> () let run_on_field com config c cf = diff --git a/src/optimization/analyzerConfig.ml b/src/optimization/analyzerConfig.ml index 2889bbfcd3c..9ef952b898d 100644 --- a/src/optimization/analyzerConfig.ml +++ b/src/optimization/analyzerConfig.ml @@ -38,6 +38,7 @@ type t = { detail_times : int; user_var_fusion : bool; fusion_debug : bool; + coro_debug : bool; } let flag_optimize = "optimize" @@ -74,6 +75,7 @@ let get_base_config com = detail_times = (try int_of_string (Common.defined_value_safe com ~default:"0" Define.AnalyzerTimes) with _ -> 0); user_var_fusion = (match com.platform with Flash | Jvm -> false | _ -> true) && (Common.raw_defined com "analyzer_user_var_fusion" || (not com.debug && not (Common.raw_defined com "analyzer_no_user_var_fusion"))); fusion_debug = false; + coro_debug = false; } let update_config_from_meta com config ml = @@ -97,6 +99,7 @@ let update_config_from_meta com config ml = | "dot_debug" -> { config with debug_kind = DebugDot } | "full_debug" -> { config with debug_kind = DebugFull } | "fusion_debug" -> { config with fusion_debug = true } + | "coro_debug" -> { config with coro_debug = true } | "as_var" -> config | _ -> let options = Warning.from_meta ml in diff --git a/src/optimization/analyzerCoro.ml b/src/optimization/analyzerCoro.ml new file mode 100644 index 00000000000..138ded3069c --- /dev/null +++ b/src/optimization/analyzerCoro.ml @@ -0,0 +1,390 @@ +open Globals +open Type +open AnalyzerTypes +open BasicBlock +open Graph +open Texpr + +let block_to_texpr_coroutine ctx bb vcontinuation vresult verror p = + assert(bb.bb_closed); + + let open Texpr.Builder in + let com = ctx.com in + + let eerror = make_local verror null_pos in + + let mk_int i = make_int com.basic i null_pos in + + let mk_assign estate eid = + mk (TBinop (OpAssign,estate,eid)) eid.etype null_pos + in + + let vstate = alloc_var VGenerated "_hx_state" com.basic.tint p in + add_var_flag vstate VCaptured; + declare_var ctx.graph vstate bb; + let estate = make_local vstate p in + let set_state id = mk_assign estate (mk_int id) in + + let vexcstate = alloc_var VGenerated "_hx_exceptionState" com.basic.tint p in + add_var_flag vexcstate VCaptured; + declare_var ctx.graph vexcstate bb; + let eexcstate = make_local vexcstate p in + let set_excstate id = mk_assign eexcstate (mk_int id) in + + let tstatemachine = tfun [t_dynamic; t_dynamic] com.basic.tvoid in + let vstatemachine = alloc_var VGenerated "_hx_stateMachine" tstatemachine p in + add_var_flag vstatemachine VCaptured; + declare_var ctx.graph vstatemachine bb; + let estatemachine = make_local vstatemachine p in + + let get_next_state_id = + let counter = ref 0 in + fun () -> (let id = !counter in incr counter; id) + in + + let get_rethrow_state_id = + let rethrow_state_id = ref (-1) in + fun () -> begin + if !rethrow_state_id = (-1) then rethrow_state_id := get_next_state_id (); + !rethrow_state_id; + end + in + + let mk_continuation_call eresult p = + let econtinuation = make_local vcontinuation p in + mk (TCall (econtinuation, [eresult; make_null t_dynamic p])) com.basic.tvoid p + in + let mk_continuation_call_error eerror p = + let econtinuation = make_local vcontinuation p in + mk (TCall (econtinuation, [make_null t_dynamic p; eerror])) com.basic.tvoid p + in + + let mk_suspending_call call = + let p = call.pos in + + (* lose Coroutine type for the called function not to confuse further filters and generators *) + let tcoroutine = tfun [t_dynamic; t_dynamic] com.basic.tvoid in + let tfun = match follow call.efun.etype with + | TFun (args, ret, true) -> + let tcontinuation = tfun [ret; t_dynamic] com.basic.tvoid in + let args = args @ [("",false,tcontinuation)] in + TFun (args, tcoroutine, false) + | _ -> + die "Unexpected coroutine type" __LOC__ + in + let efun = { call.efun with etype = tfun } in + let args = call.args @ [ estatemachine ] in + let ecreatecoroutine = mk (TCall (efun, args)) tcoroutine call.pos in + let enull = make_null t_dynamic p in + mk (TCall (ecreatecoroutine, [enull; enull])) com.basic.tvoid call.pos + in + + (* TODO: stolen from exceptions.ml. we should really figure out the filter ordering here *) + let std_is e t = + let std_cls = + (* TODO: load it? *) + match (try List.find (fun t -> t_path t = ([],"Std")) com.types with Not_found -> die "" __LOC__) with + | TClassDecl cls -> cls + | _ -> die "" __LOC__ + in + let isOfType_field = + try PMap.find "isOfType" std_cls.cl_statics + with Not_found -> die "" __LOC__ + in + let type_expr = mk (TTypeExpr (module_type_of_type t)) t_dynamic null_pos in + let isOfType_expr = Typecore.make_static_field_access std_cls isOfType_field isOfType_field.cf_type null_pos in + mk (TCall (isOfType_expr, [e; type_expr])) com.basic.tbool null_pos + in + + + let states = ref [] in + + let exc_states = ref [] in + + let debug_endline s = + if ctx.config.coro_debug then + print_endline s + in + (* TODO: maybe merge this into block_to_texpr somehow, and only introduce new states when there is a suspension point *) + debug_endline "---"; + let rec loop bb state_id back_state_id current_el while_loop exc_state_id_getter = + let p = bb.bb_pos in + (* TODO: only do this in the end, avoid unnecessary List.rev *) + let el = DynArray.to_list bb.bb_el in + + let ereturn = mk (TReturn None) com.basic.tvoid p in + + let add_state el = + states := (state_id,mk (TBlock el) com.basic.tvoid null_pos) :: !states + in + let get_cond_branch () = match bb.bb_terminator with TermCondBranch e -> e | _ -> die "" __LOC__ in + + match bb.bb_syntax_edge with + | SESuspend (call, bb_next) -> + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "suspend cur:%d,next:%d,back:%d" state_id next_state_id back_state_id); + loop bb_next next_state_id back_state_id [] while_loop exc_state_id_getter; + let ecallcoroutine = mk_suspending_call call in + let esetstate = set_state next_state_id in + add_state (current_el @ el @ [esetstate; ecallcoroutine; ereturn]) + + | SENone -> + debug_endline (Printf.sprintf "none cur:%d,back:%d" state_id back_state_id); + (match bb.bb_terminator with + | TermBreak _ -> (* todo use pos *) + let _,next_state_id = Option.get while_loop in + let esetstate = set_state next_state_id in + add_state (current_el @ el @ [esetstate]) + | TermContinue _ -> (* todo use pos *) + let body_state_id,_ = Option.get while_loop in + let esetstate = set_state body_state_id in + add_state (current_el @ el @ [esetstate]) + | TermReturn _ | TermReturnValue _ -> (* todo use pos *) + let esetstate = set_state (-1) in + let eresult = match bb.bb_terminator with + | TermReturnValue (e,_) -> e + | _ -> make_null t_dynamic p + in + let ecallcontinuation = mk_continuation_call eresult p in + add_state (current_el @ el @ [esetstate; ecallcontinuation; ereturn]) + | TermNone when back_state_id = -1 -> + let esetstate = set_state (-1) in + let ecallcontinuation = mk_continuation_call (make_null t_dynamic p) p in + add_state (current_el @ el @ [esetstate; ecallcontinuation; ereturn]) + | TermNone -> + add_state (current_el @ el @ [set_state back_state_id]) + | TermThrow (e,p) -> + let ethrow = mk (TThrow e) t_dynamic p in + add_state (current_el @ el @ [ethrow]) + | TermCondBranch _ -> + die "unexpected TermCondBranch" __LOC__) + + | SEMerge bb_next -> + debug_endline (Printf.sprintf "merge cur:%d,back:%d" state_id back_state_id); + loop bb_next state_id back_state_id (current_el @ el) while_loop exc_state_id_getter + + | SESubBlock (bb_sub,bb_next) -> + let sub_state_id = get_next_state_id () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "sub cur:%d,sub:%d,next:%d,back:%d" state_id sub_state_id next_state_id back_state_id); + loop bb_next next_state_id back_state_id [] while_loop exc_state_id_getter; + loop bb_sub sub_state_id next_state_id [] while_loop exc_state_id_getter; + add_state (current_el @ el @ [set_state sub_state_id]) + + | SEIfThen (bb_then,bb_next,p) -> + let econd = get_cond_branch () in + let then_state_id = get_next_state_id () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "if-then cur:%d,then:%d,next:%d,back:%d" state_id then_state_id next_state_id back_state_id); + loop bb_then then_state_id next_state_id [] while_loop exc_state_id_getter; + loop bb_next next_state_id back_state_id [] while_loop exc_state_id_getter; + let eif = mk (TIf (econd, set_state then_state_id, Some (set_state next_state_id))) com.basic.tint p in + add_state (current_el @ el @ [eif]) + + | SEIfThenElse (bb_then,bb_else,bb_next,t,p) -> + let econd = get_cond_branch () in + let then_state_id = get_next_state_id () in + let else_state_id = get_next_state_id () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "if-then-else cur:%d,then:%d,else:%d,next:%d,back:%d" state_id then_state_id else_state_id next_state_id back_state_id); + loop bb_then then_state_id next_state_id [] while_loop exc_state_id_getter; + loop bb_else else_state_id next_state_id [] while_loop exc_state_id_getter; + loop bb_next next_state_id back_state_id [] while_loop exc_state_id_getter; + let eif = mk (TIf (econd, set_state then_state_id, Some (set_state else_state_id))) com.basic.tint p in + add_state (current_el @ el @ [eif]) + + | SESwitch switch -> + let esubj = get_cond_branch () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "switch cur:%d,next:%d,back:%d" state_id next_state_id back_state_id); + let ecases = List.map (fun (patterns,bb) -> + (* TODO: variable capture and other fancy things O_o *) + let case_state_id = get_next_state_id () in + debug_endline (Printf.sprintf " case %d" case_state_id); + loop bb case_state_id next_state_id [] while_loop exc_state_id_getter; + {case_patterns = patterns;case_expr = set_state case_state_id} + ) switch.ss_cases in + let default_state_id = match switch.ss_default with + | Some bb -> + let default_state_id = get_next_state_id () in + loop bb default_state_id next_state_id [] while_loop exc_state_id_getter; + default_state_id + | None -> + next_state_id + in + debug_endline (Printf.sprintf " default %d" default_state_id); + let eswitch = mk_switch esubj ecases (Some (set_state default_state_id)) true in + let eswitch = mk (TSwitch eswitch) com.basic.tvoid p in + loop switch.ss_next next_state_id back_state_id [] while_loop exc_state_id_getter; + add_state (current_el @ el @ [eswitch]) + + | SEWhile (bb_body, bb_next, p) -> + let body_state_id = get_next_state_id () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "while cur:%d,body:%d,next:%d,back:%d" state_id body_state_id next_state_id back_state_id); + let new_while_loop = Some (body_state_id,next_state_id) in + (* TODO: next is empty? *) + loop bb_body body_state_id body_state_id [] new_while_loop exc_state_id_getter; + loop bb_next next_state_id back_state_id [] while_loop exc_state_id_getter; + add_state (current_el @ el @ [set_state body_state_id]); + + | SETry (bb_try,_,catches,bb_next,p) -> + let try_state_id = get_next_state_id () in + let new_exc_state_id = get_next_state_id () in + let next_state_id = get_next_state_id () in + debug_endline (Printf.sprintf "try cur:%d,try:%d,catch:%d,next:%d,back:%d" state_id try_state_id new_exc_state_id next_state_id back_state_id); + loop bb_try try_state_id next_state_id [set_excstate new_exc_state_id] while_loop (fun () -> new_exc_state_id); (* TODO: add test for nested try/catch *) + let esetexcstate = set_excstate (exc_state_id_getter ()) in + let catch_case = + let erethrow = mk (TThrow eerror) t_dynamic null_pos in + let eif = + List.fold_left (fun enext (vcatch,bb_catch) -> + let catch_state_id = get_next_state_id () in + let ecatchvar = mk (TVar (vcatch, Some eerror)) com.basic.tvoid null_pos in + loop bb_catch catch_state_id next_state_id [esetexcstate; ecatchvar] while_loop exc_state_id_getter; + + (* TODO: exceptions filter... *) + match follow vcatch.v_type with + | TDynamic _ -> + set_state catch_state_id (* no next *) + | t -> + let etypecheck = std_is (make_local verror null_pos) vcatch.v_type in + mk (TIf (etypecheck, set_state catch_state_id, Some enext)) com.basic.tvoid null_pos + ) erethrow catches + in + (new_exc_state_id, eif) + in + exc_states := catch_case :: !exc_states; + loop bb_next next_state_id back_state_id [esetexcstate (* TODO: test propagation after try/catch *)] while_loop exc_state_id_getter; + add_state (current_el @ el @ [set_state try_state_id]) + in + loop bb (get_next_state_id ()) (-1) [] None get_rethrow_state_id; + + let states = !states @ !exc_states in + + (* TODO: this (and the coroutine transform in general) should probably be run before captured vars handling *) + (* very ugly, but seems to work: extract locals that are used across states *) + let var_usages = Hashtbl.create 5 in + begin + let use v state_id = + let m = try + Hashtbl.find var_usages v.v_id + with Not_found -> + let m = Hashtbl.create 1 in + Hashtbl.add var_usages v.v_id m; + m + in + Hashtbl.replace m state_id true + in + List.iter (fun (state_id, expr) -> + let rec loop e = + match e.eexpr with + | TVar (v, eo) -> + Option.may loop eo; + use v state_id; + | TLocal v -> + use v state_id; + | _ -> + Type.iter loop e + in + loop expr + ) states; + end; + let states, decls = begin + let is_used_across_states v_id = + let m = Hashtbl.find var_usages v_id in + (Hashtbl.length m) > 1 + in + let rec loop cases cases_acc decls = + match cases with + | (id,expr) :: rest -> + let decls = ref decls in + let expr = begin + let rec loop e = + match e.eexpr with + | TVar (v, eo) when is_used_across_states v.v_id -> + decls := v :: !decls; + let elocal = make_local v e.epos in + (match eo with + | None -> elocal + | Some einit -> mk (TBinop (OpAssign,elocal,einit)) v.v_type e.epos) + | _ -> + Type.map_expr loop e + in + loop expr + end in + loop rest ((id,expr) :: cases_acc) !decls + | [] -> + List.rev cases_acc, decls + in + loop states [] [] + end in + + (* TODO: + we can optimize while and switch in some cases: + - if there's only one state (no suspensions) - don't wrap into while/switch, don't introduce state var + *) + + let rethrow_state_id = get_rethrow_state_id () in + let rethrow_state = (rethrow_state_id, mk (TThrow eerror) com.basic.tvoid null_pos) in + let states = states @ [rethrow_state] in + + let ethrow = mk (TBlock [ + set_state rethrow_state_id; + mk (TThrow (make_string com.basic "Invalid coroutine state" p)) com.basic.tvoid p + ]) com.basic.tvoid null_pos + in + + let switch = + let cases = List.map (fun (id,e) -> {case_patterns = [mk_int id];case_expr = e}) states in + mk_switch estate cases (Some ethrow) true + in + let eswitch = mk (TSwitch switch) com.basic.tvoid p in + + let etry = mk (TTry ( + eswitch, + [ + let vcaught = alloc_var VGenerated "e" t_dynamic null_pos in + declare_var ctx.graph vcaught bb; + (vcaught, mk (TIf ( + mk (TBinop (OpEq, estate, mk_int rethrow_state_id)) com.basic.tbool null_pos, + mk (TBlock [ + mk_assign eexcstate (mk_int rethrow_state_id); + mk_continuation_call_error (make_local vcaught null_pos) null_pos; + mk (TReturn None) com.basic.tvoid null_pos; + ]) com.basic.tvoid null_pos, + Some (mk (TBlock [ + mk_assign estate eexcstate; + mk_assign eerror (make_local vcaught null_pos); + ]) com.basic.tvoid null_pos) + )) com.basic.tvoid null_pos) + ] + )) com.basic.tvoid null_pos in + + let eloop = mk (TWhile (make_bool com.basic true p, etry, DoWhile)) com.basic.tvoid p in + + let eif = mk (TIf ( + mk (TBinop ( + OpNotEq, + eerror, + make_null verror.v_type p + )) com.basic.tbool p, + mk_assign estate eexcstate, + None + )) com.basic.tvoid p in + + let estatemachine_def = mk (TFunction { + tf_args = [(vresult,None); (verror,None)]; + tf_type = com.basic.tvoid; + tf_expr = mk (TBlock [eif; eloop]) com.basic.tvoid null_pos + }) tstatemachine p in + + let state_var = mk (TVar (vstate, Some (make_int com.basic 0 p))) com.basic.tvoid p in + let excstate_var = mk (TVar (vexcstate, Some (make_int com.basic rethrow_state_id p))) com.basic.tvoid p in + let shared_vars = List.map (fun v -> mk (TVar (v,None)) com.basic.tvoid null_pos) decls in + let shared_vars = List.rev (excstate_var :: state_var :: shared_vars) in + + mk (TBlock (shared_vars @ [ + mk (TVar (vstatemachine, Some estatemachine_def)) com.basic.tvoid p; + mk (TReturn (Some estatemachine)) com.basic.tvoid p; + ])) com.basic.tvoid p diff --git a/src/optimization/analyzerTexpr.ml b/src/optimization/analyzerTexpr.ml index 7b09d058d5e..900ae33fab2 100644 --- a/src/optimization/analyzerTexpr.ml +++ b/src/optimization/analyzerTexpr.ml @@ -96,6 +96,16 @@ let can_throw e = with Exit -> true + +let terminator_to_texpr_maybe = function +| AnalyzerTypes.BasicBlock.TermReturn p -> Some (mk (TReturn None) t_dynamic p) +| TermBreak p -> Some (mk TBreak t_dynamic p) +| TermContinue p -> Some (mk TContinue t_dynamic p) +| TermReturnValue(e1,p) -> Some (mk (TReturn (Some e1)) t_dynamic p) +| TermThrow(e1,p) -> Some (mk (TThrow e1) t_dynamic p) +| TermCondBranch e1 -> Some e1 (* TODO: this shouldn't be here *) +| _ -> None + let rec can_be_inlined e = match e.eexpr with | TConst _ -> true | TParenthesis e1 | TMeta(_,e1) -> can_be_inlined e1 diff --git a/src/optimization/analyzerTexprTransformer.ml b/src/optimization/analyzerTexprTransformer.ml index 888ded14df5..4f09e858481 100644 --- a/src/optimization/analyzerTexprTransformer.ml +++ b/src/optimization/analyzerTexprTransformer.ml @@ -44,7 +44,16 @@ let rec func ctx bb tf t p = in let bb_root = create_node (BKFunctionBegin tf) tf.tf_expr.etype tf.tf_expr.epos in let bb_exit = create_node BKFunctionEnd tf.tf_expr.etype tf.tf_expr.epos in - add_function g tf t p bb_root; + let coroutine = match follow t with + | TFun(_,_,true) -> + let v_result = alloc_var VGenerated "_hx_result" t_dynamic p in + let v_error = alloc_var VGenerated "_hx_error" t_dynamic p in + declare_var ctx.graph v_result bb_root; + declare_var ctx.graph v_error bb_root; + Some (v_result,v_error) + | _ -> None + in + add_function g tf t p bb_root coroutine; add_cfg_edge bb bb_root CFGFunction; let bb_breaks = ref [] in let bb_continue = ref None in @@ -331,8 +340,34 @@ let rec func ctx bb tf t p = let el = Codegen.UnificationCallback.check_call check el e1.etype in let bb,el = ordered_value_list !bb (e1 :: el) in match el with - | e1 :: el -> bb,{e with eexpr = TCall(e1,el)} - | _ -> die "" __LOC__ + | efun :: el -> + let is_coroutine efun = + match follow efun.etype with + | TFun(_,_,true) -> true + | _ -> false + in + (match coroutine with + | Some (vresult,_) when is_coroutine efun -> + let bb_next = create_node BKNormal e1.etype e1.epos in + add_cfg_edge bb bb_next CFGGoto; + let syntax_edge = SESuspend ( + { + efun = efun; + args = el; + pos = e.epos; + }, + bb_next + ) in + set_syntax_edge bb syntax_edge; + close_node bb; + let eresult = Texpr.Builder.make_local vresult e.epos in + let eresult = mk_cast eresult e.etype e.epos in + bb_next,eresult + | _ -> + bb,{e with eexpr = TCall (efun,el)} + ) + | _ -> + die "" __LOC__ and array_assign_op bb op e ea e1 e2 e3 = let bb,e1 = bind_to_temp bb e1 in let bb,e2 = bind_to_temp bb e2 in @@ -686,15 +721,6 @@ let from_tfunction ctx tf t p = close_node g.g_root; g.g_exit <- bb_exit -let terminator_to_texpr_maybe = function - | TermReturn p -> Some (mk (TReturn None) t_dynamic p) - | TermBreak p -> Some (mk TBreak t_dynamic p) - | TermContinue p -> Some (mk TContinue t_dynamic p) - | TermReturnValue(e1,p) -> Some (mk (TReturn (Some e1)) t_dynamic p) - | TermThrow(e1,p) -> Some (mk (TThrow e1) t_dynamic p) - | TermCondBranch e1 -> Some e1 (* TODO: this shouldn't be here *) - | _ -> None - let rec block_to_texpr_el ctx bb = if bb.bb_dominator == ctx.graph.g_unreachable then [] @@ -730,6 +756,8 @@ let rec block_to_texpr_el ctx bb = }) ss.ss_cases in let switch = mk_switch (get_terminator()) cases (Option.map block ss.ss_default) ss.ss_exhaustive in Some ss.ss_next,Some (mk (TSwitch switch) ctx.com.basic.tvoid ss.ss_pos) + | SESuspend _ -> + assert false in let bb_next,e_term = loop bb bb.bb_syntax_edge in let el = DynArray.to_list bb.bb_el in @@ -751,8 +779,25 @@ and block_to_texpr ctx bb = e and func ctx i = - let bb,t,p,tf = Hashtbl.find ctx.graph.g_functions i in - let e = block_to_texpr ctx bb in + let tfi = Hashtbl.find ctx.graph.g_functions i in + let tf = tfi.tf_tf in + let bb = tfi.tf_bb in + let p = tfi.tf_pos in + let e,tf_args,tf_type = + match tfi.tf_coroutine with + | Some (vresult,verror) -> + let vcontinuation = alloc_var VGenerated "_hx_continuation" (tfun [tf.tf_type; t_dynamic] ctx.com.basic.tvoid) p in + add_var_flag vcontinuation VCaptured; + declare_var ctx.graph vcontinuation bb; + let e = AnalyzerCoro.block_to_texpr_coroutine ctx bb vcontinuation vresult verror p in + (* All actual arguments will be captured after the transformation. *) + List.iter (fun (v,_) -> add_var_flag v VCaptured) tf.tf_args; + let tf_args = tf.tf_args @ [(vcontinuation,None)] in + let sm_type = tfun [t_dynamic; t_dynamic] ctx.com.basic.tvoid in + e, tf_args, sm_type + | None -> + block_to_texpr ctx bb, tf.tf_args, tf.tf_type + in let rec loop e = match e.eexpr with | TLocal v -> {e with eexpr = TLocal (get_var_origin ctx.graph v)} @@ -795,7 +840,7 @@ and func ctx i = Type.map_expr loop e in let e = loop e in - mk (TFunction {tf with tf_expr = e}) t p + mk (TFunction {tf with tf_args = tf_args; tf_type = tf_type; tf_expr = e}) tfi.tf_t p let to_texpr ctx = func ctx ctx.entry.bb_id diff --git a/src/optimization/analyzerTypes.ml b/src/optimization/analyzerTypes.ml index 5a1fd0d6925..27f6b828073 100644 --- a/src/optimization/analyzerTypes.ml +++ b/src/optimization/analyzerTypes.ml @@ -73,6 +73,7 @@ module BasicBlock = struct | SEWhile of t * t * pos (* `while` with "body" and "next" *) | SESubBlock of t * t (* "sub" with "next" *) | SEMerge of t (* Merge to same block *) + | SESuspend of (suspend_call * t) (* Suspension point *) | SENone (* No syntax exit *) and syntax_switch = { @@ -253,7 +254,14 @@ end module Graph = struct open BasicBlock - type tfunc_info = BasicBlock.t * Type.t * pos * tfunc + type tfunc_info = { + tf_bb : BasicBlock.t; + tf_t : Type.t; + tf_pos : pos; + tf_tf : tfunc; + tf_coroutine : (tvar * tvar) option; + } + type texpr_lookup = BasicBlock.t * texpr_lookup_target type var_write = BasicBlock.t list type 'a itbl = (int,'a) Hashtbl.t @@ -339,8 +347,8 @@ module Graph = struct (* nodes *) - let add_function g tf t p bb = - Hashtbl.add g.g_functions bb.bb_id (bb,t,p,tf) + let add_function g tf_tf tf_t tf_pos tf_bb tf_coroutine = + Hashtbl.add g.g_functions tf_bb.bb_id ({tf_bb;tf_t;tf_pos;tf_tf;tf_coroutine}) let alloc_id = let r = ref 1 in @@ -590,11 +598,13 @@ module Graph = struct loop scopes bb_next | SEMerge bb -> loop scopes bb + | SESuspend (_, bb) -> + loop scopes bb | SENone -> () end in - Hashtbl.iter (fun _ (bb,_,_,_) -> loop [0] bb) g.g_functions + Hashtbl.iter (fun _ tfi -> loop [0] tfi.tf_bb) g.g_functions end type analyzer_context = { diff --git a/src/optimization/dce.ml b/src/optimization/dce.ml index 6d122f3fc82..8b028c35269 100644 --- a/src/optimization/dce.ml +++ b/src/optimization/dce.ml @@ -252,7 +252,7 @@ and mark_t dce p t = | TInst(c,pl) -> mark_class dce c; List.iter (mark_t dce p) pl - | TFun(args,ret) -> + | TFun(args,ret,_) -> List.iter (fun (_,_,t) -> mark_t dce p t) args; mark_t dce p ret | TEnum(e,pl) -> diff --git a/src/optimization/inline.ml b/src/optimization/inline.ml index 9cba36f0799..325449b009f 100644 --- a/src/optimization/inline.ml +++ b/src/optimization/inline.ml @@ -576,13 +576,13 @@ class inline_state ctx ethis params cf f p = object(self) let e = inline_metadata e cf.cf_meta in if has_params then begin let mt = map_type cf.cf_type in - let unify_func () = unify_raise mt (TFun (tl,tret)) p in + let unify_func () = unify_raise mt (TFun (tl,tret,false)) p in (match follow ethis.etype with | TAnon a -> (match !(a.a_status) with | ClassStatics {cl_kind = KAbstractImpl a } when has_class_field_flag cf CfImpl -> if cf.cf_name <> "_new" then begin (* the first argument must unify with a_this for abstract implementation functions *) - let tb = (TFun(("",false,map_type a.a_this) :: (List.tl tl),tret)) in + let tb = (TFun(("",false,map_type a.a_this) :: (List.tl tl),tret,false)) in unify_raise mt tb p end | _ -> unify_func()) diff --git a/src/optimization/optimizer.ml b/src/optimization/optimizer.ml index 47ed16d8f18..fa9a91d5e6e 100644 --- a/src/optimization/optimizer.ml +++ b/src/optimization/optimizer.ml @@ -348,7 +348,7 @@ let rec reduce_loop ctx e = | { eexpr = TFunction func } as ef -> let cf = mk_field "" ef.etype e.epos null_pos in let ethis = mk (TConst TThis) t_dynamic e.epos in - let rt = (match follow ef.etype with TFun (_,rt) -> rt | _ -> die "" __LOC__) in + let rt = (match follow ef.etype with TFun (_,rt,_) -> rt | _ -> die "" __LOC__) in begin try let e = type_inline ctx cf func ethis el rt None e.epos ~self_calling_closure:true false in reduce_loop ctx e @@ -359,7 +359,7 @@ let rec reduce_loop ctx e = begin match cf.cf_expr with | Some {eexpr = TFunction tf} -> let config = inline_config (Some cl) cf el e.etype in - let rt = (match Abstract.follow_with_abstracts e1.etype with TFun (_,rt) -> rt | _ -> die "" __LOC__) in + let rt = (match Abstract.follow_with_abstracts e1.etype with TFun (_,rt,_) -> rt | _ -> die "" __LOC__) in begin try let e = type_inline ctx cf tf ef el rt config e.epos false in rec_stack_default inline_stack cf (fun cf' -> cf' == cf) (fun () -> reduce_loop ctx e) e diff --git a/src/typing/callUnification.ml b/src/typing/callUnification.ml index 623c0fe4ed6..dc03e1b14d5 100644 --- a/src/typing/callUnification.ml +++ b/src/typing/callUnification.ml @@ -179,7 +179,7 @@ let unify_call_args ctx el args r callp inline force_inline in_overload = in let el = try loop el args with exc -> restore(); raise exc; in restore(); - el,TFun(args,r) + el type overload_kind = | OverloadProper (* @:overload or overload *) @@ -289,9 +289,11 @@ let unify_field_call ctx fa el_typed el p inline = let monos = Monomorph.spawn_constrained_monos map cf.cf_params in let t = map (apply_params cf.cf_params monos cf.cf_type) in match follow t with - | TFun(args,ret) -> + | TFun(args,ret,true) when not (TyperManager.is_coroutine_context ctx) -> + raise_typing_error "Cannot directly call coroutine from a normal function, use start/create methods instead" p + | TFun(args,ret,coro) -> let args_typed,args = unify_typed_args ctx tmap args el_typed p in - let el,_ = + let el = try unify_call_args ctx el args ret p inline is_forced_inline in_overload with DisplayException.DisplayException de -> @@ -299,7 +301,7 @@ let unify_field_call ctx fa el_typed el p inline = in (* here *) let el = el_typed @ el in - let tf = TFun(args_typed @ args,ret) in + let tf = TFun(args_typed @ args,ret,coro) in let mk_call () = let ef = mk (TField(fa.fa_on,FieldAccess.apply_fa cf fa.fa_host)) t fa.fa_pos in !make_call_ref ctx ef el ret ~force_inline:inline p @@ -382,7 +384,7 @@ let unify_field_call ctx fa el_typed el p inline = commit_delayed_display (attempt_call cf false) with Error _ when Common.ignore_error ctx.com -> check_display_args(); - let tf = TFun(List.map (fun _ -> ("",false,t_dynamic)) el,t_dynamic) in + let tf = TFun(List.map (fun _ -> ("",false,t_dynamic)) el,t_dynamic,false) in let call () = let ef = mk (TField(fa.fa_on,FieldAccess.apply_fa fa.fa_field fa.fa_host)) tf fa.fa_pos in mk (TCall(ef,[])) t_dynamic p @@ -546,11 +548,11 @@ object(self) mk (TCall (e,el)) t p in let rec loop t = match follow t with - | TFun (args,r) -> + | TFun (args,r,coro) -> + if coro && not (TyperManager.is_coroutine_context ctx) then raise_typing_error "Cannot directly call coroutine from a normal function, use start/create methods instead" p; let args_typed,args_left = unify_typed_args ctx (fun t -> t) args el_typed p in - let el, tfunc = unify_call_args ctx el args_left r p false false false in + let el = unify_call_args ctx el args_left r p false false false in let el = el_typed @ el in - let r = match tfunc with TFun(_,r) -> r | _ -> die "" __LOC__ in mk (TCall (e,el)) r p | TAbstract(a,tl) as t -> let check_callable () = diff --git a/src/typing/calls.ml b/src/typing/calls.ml index 7a4e275aec7..f1075a9a724 100644 --- a/src/typing/calls.ml +++ b/src/typing/calls.ml @@ -12,7 +12,7 @@ open CallUnification let make_call ctx e params t ?(force_inline=false) p = let params = match follow e.etype with - | TFun (expected_args,_) -> + | TFun (expected_args,_,_) -> (match List.rev expected_args with | (_,true,t) :: rest when is_pos_infos t && List.length rest = List.length params -> let infos = mk_infos ctx p [] in @@ -212,7 +212,7 @@ let rec acc_get ctx g = let id,_ = store_typed_expr ctx.com sea.se_this e_field.epos in let e_field = {e_field with eexpr = (TMeta((Meta.StaticExtension,[make_stored_id_expr id e_field.epos],null_pos),e_field))} in let t = match follow e_field.etype with - | TFun (_ :: args,ret) -> TFun(args,ret) + | TFun (_ :: args,ret,coro) -> TFun(args,ret,coro) | t -> t in {e_field with etype = t} @@ -239,12 +239,12 @@ let rec acc_get ctx g = let e_field = FieldAccess.get_field_expr sea.se_access FGet in (* build a closure with first parameter applied *) (match follow e_field.etype with - | TFun ((_,_,t0) :: args,ret) -> + | TFun ((_,_,t0) :: args,ret,coro) -> let p = sea.se_access.fa_pos in let te = abstract_using_param_type sea in unify ctx te t0 e.epos; - let tcallb = TFun (args,ret) in - let twrap = TFun ([("_e",false,e.etype)],tcallb) in + let tcallb = TFun (args,ret,false) in + let twrap = TFun ([("_e",false,e.etype)],tcallb,coro) in (* arguments might not have names in case of variable fields of function types, so we generate one (issue #2495) *) let args = List.map (fun (n,o,t) -> let t = if o then ctx.t.tnull t else t in @@ -355,7 +355,7 @@ let call_to_string ctx ?(resume=false) e = mk (TIf (check_null, string_null, Some (gen_to_string e))) ctx.t.tstring e.epos end -let type_bind ctx (e : texpr) (args,ret) params p = +let type_bind ctx (e : texpr) (args,ret,coro) params p = let vexpr v = mk (TLocal v) v.v_type p in let acount = ref 0 in let alloc_name n = @@ -423,7 +423,7 @@ let type_bind ctx (e : texpr) (args,ret) params p = tf_type = ret; tf_expr = body; } in - let t = TFun(List.map (fun (v,o) -> v.v_name,o,v.v_type) missing_args,ret) in + let t = TFun(List.map (fun (v,o) -> v.v_name,o,v.v_type) missing_args,ret,coro) in { eexpr = TBlock (var_decls @ [mk (TFunction fn) t p]); etype = t; diff --git a/src/typing/fields.ml b/src/typing/fields.ml index a29be9a11f0..af603ce73b3 100644 --- a/src/typing/fields.ml +++ b/src/typing/fields.ml @@ -430,7 +430,7 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) = let monos = Monomorph.spawn_constrained_monos (fun t -> t) cf.cf_params in let cft = follow (apply_params cf.cf_params monos cf.cf_type) in match cft with - | TFun ((_,_,(TType ({ t_path = ["haxe";"macro"],"ExprOf" },[t0]) | t0)) :: _,_) -> + | TFun ((_,_,(TType ({ t_path = ["haxe";"macro"],"ExprOf" },[t0]) | t0)) :: _,_,_) -> if t == t_dynamic && follow t0 != t then check() else begin @@ -610,7 +610,7 @@ let get_struct_init_anon_fields c tl = | None -> None in (match follow cf.cf_type with - | TFun (args,_) -> + | TFun (args,_,_) -> Some (match cf.cf_expr with | Some { eexpr = TFunction fn } -> List.map (fun (name,_,t) -> diff --git a/src/typing/finalization.ml b/src/typing/finalization.ml index 67189a59a15..0726a96f56c 100644 --- a/src/typing/finalization.ml +++ b/src/typing/finalization.ml @@ -38,7 +38,7 @@ let get_main ctx types = let ft = Type.field_type f in let fmode, r = match follow ft with - | TFun ([],r) -> FStatic (c,f), r + | TFun ([],r,_) -> FStatic (c,f), r | _ -> raise_typing_error ("Invalid -main : " ^ s_type_path path ^ " has invalid main function") c.cl_pos in if not (ExtType.is_void (follow r)) then raise_typing_error (Printf.sprintf "Return type of main function should be Void (found %s)" (s_type (print_context()) r)) f.cf_name_pos; diff --git a/src/typing/forLoop.ml b/src/typing/forLoop.ml index 6bb73631c7a..a09e2865808 100644 --- a/src/typing/forLoop.ml +++ b/src/typing/forLoop.ml @@ -21,7 +21,7 @@ let optimize_for_loop_iterator ctx v e1 e2 p = | TCall ({ eexpr = TField (_, FInstance (c,pl,cf)) }, _) -> let t = apply_params c.cl_params pl cf.cf_type in (match follow t with - | TFun (_, t) -> + | TFun (_, t, _) -> (match follow t with | TInst (c,pl) -> c,pl | _ -> raise Exit @@ -37,7 +37,7 @@ let optimize_for_loop_iterator ctx v e1 e2 p = let it_type = TInst(c,tl) in let tmp = gen_local ctx it_type e1.epos in let eit = mk (TLocal tmp) it_type p in - let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, tl, fhasnext))) (TFun([],ctx.t.tbool)) p) [] ctx.t.tbool p in + let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, tl, fhasnext))) (TFun([],ctx.t.tbool,false)) p) [] ctx.t.tbool p in let fa_next = try match raw_class_field (fun cf -> apply_params c.cl_params tl cf.cf_type) c tl "next" with @@ -45,7 +45,7 @@ let optimize_for_loop_iterator ctx v e1 e2 p = with Not_found -> quick_field_dynamic eit.etype "next" in - let enext = mk (TVar (v,Some (make_call ctx (mk (TField (eit,fa_next)) (TFun ([],v.v_type)) p) [] v.v_type p))) ctx.t.tvoid p in + let enext = mk (TVar (v,Some (make_call ctx (mk (TField (eit,fa_next)) (TFun ([],v.v_type,false)) p) [] v.v_type p))) ctx.t.tvoid p in let eblock = (match e2.eexpr with | TBlock el -> { e2 with eexpr = TBlock (enext :: el) } | _ -> mk (TBlock [enext;e2]) ctx.t.tvoid p @@ -142,7 +142,7 @@ module IterationKind = struct make_static_call ctx c cf_length (apply_params a.a_params tl) [e] ctx.com.basic.tint p in (match follow cf_length.cf_type with - | TFun(_,tr) -> + | TFun(_,tr,_) -> (match follow tr with | TAbstract({a_path = [],"Int"},_) -> () | _ -> raise Not_found diff --git a/src/typing/generic.ml b/src/typing/generic.ml index 32dcdbd9f24..4ec437bda92 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -38,7 +38,7 @@ let make_generic ctx ps pt debug p = (s_type_path_underscore en.e_path) ^ (loop_tl top tl),(t,None) | TAnon(a) -> "anon_" ^ String.concat "_" (PMap.foldi (fun s f acc -> (s ^ "_" ^ (loop_deep (follow f.cf_type))) :: acc) a.a_fields []),(t,None) - | TFun(args, return_type) -> + | TFun(args, return_type,_) -> ("func_" ^ (String.concat "_" (List.map (fun (_, _, t) -> loop_deep t) args)) ^ "_" ^ (loop_deep return_type)),(t,None) | TAbstract(a,tl) -> (s_type_path_underscore a.a_path) ^ (loop_tl top tl),(t,None) @@ -215,7 +215,7 @@ let set_type_parameter_dependencies mg tl = loop t2 | TAnon a -> PMap.iter (fun _ f -> loop f.cf_type) a.a_fields - | TFun (args,ret) -> + | TFun (args,ret,_) -> List.iter (fun (_,_,t) -> loop t) args; loop ret end diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index fc1c46f036b..683f0a75cc1 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -64,7 +64,7 @@ let typing_timer ctx need_type f = let ctx = if need_type && ctx.pass < PTypeField then begin enter_field_typing_pass ctx.g ("typing_timer",[]); - TyperManager.clone_for_expr ctx ctx.e.curfun false + TyperManager.clone_for_expr ctx ctx.e.curfun ctx.e.function_mode end else ctx in @@ -764,7 +764,7 @@ let load_macro'' com mctx display cpath f p = c, (try PMap.find f c.cl_statics with Not_found -> raise_typing_error ("Method " ^ f ^ " not found on class " ^ s_type_path cpath) p) | _ -> raise_typing_error "Macro should be called on a class" p in - let meth = (match follow meth.cf_type with TFun (args,ret) -> (args,ret,cl,meth),mloaded | _ -> raise_typing_error "Macro call should be a method" p) in + let meth = (match follow meth.cf_type with TFun (args,ret,_) -> (args,ret,cl,meth),mloaded | _ -> raise_typing_error "Macro call should be a method" p) in restore(); if not com.is_macro_context then flush_macro_context mint mctx; mctx.com.cached_macros#add (cpath,f) meth; @@ -917,7 +917,7 @@ let type_macro ctx mode cpath f (el:Ast.expr list) p = incr index; (EArray ((EArrayDecl [e],p),(EConst (Int (string_of_int (!index), None)),p)),p) ) el in - let elt = fst (CallUnification.unify_call_args mctx constants (List.map fst eargs) t_dynamic p false false false) in + let elt = CallUnification.unify_call_args mctx constants (List.map fst eargs) t_dynamic p false false false in List.map2 (fun ((n,_,t),mct) e -> let e, et = (match e.eexpr with (* get back our index and real expression *) @@ -990,7 +990,7 @@ let type_macro ctx mode cpath f (el:Ast.expr list) p = let call_macro mctx args margs call p = mctx.c.curclass <- null_class; - let el, _ = CallUnification.unify_call_args mctx args margs t_dynamic p false false false in + let el = CallUnification.unify_call_args mctx args margs t_dynamic p false false false in call (List.map (fun e -> try Interp.make_const e with Exit -> raise_typing_error "Argument should be a constant" e.epos) el) let resolve_init_macro com e = diff --git a/src/typing/matcher/compile.ml b/src/typing/matcher/compile.ml index c441994c13a..740ad980e5c 100644 --- a/src/typing/matcher/compile.ml +++ b/src/typing/matcher/compile.ml @@ -48,7 +48,7 @@ let get_sub_subjects mctx e con arg_positions = let t_en = TEnum(en,tl) in let e = if not (type_iseq t_en e.etype) then mk (TCast(e,None)) t_en e.epos else e in begin match follow ef.ef_type with - | TFun(args,_) -> + | TFun(args,_,_) -> let rec combine args positions = match (args, positions) with | (a :: args, p :: positions) -> (a, p) :: combine args positions diff --git a/src/typing/matcher/constructor.ml b/src/typing/matcher/constructor.ml index e05a29a1f5c..45128b74598 100644 --- a/src/typing/matcher/constructor.ml +++ b/src/typing/matcher/constructor.ml @@ -29,7 +29,7 @@ let equal con1 con2 = match fst con1,fst con2 with | _ -> false let arity con = match fst con with - | ConEnum (_,{ef_type = TFun(args,_)}) -> List.length args + | ConEnum (_,{ef_type = TFun(args,_,_)}) -> List.length args | ConEnum _ -> 0 | ConConst _ -> 0 | ConFields fields -> List.length fields diff --git a/src/typing/matcher/exprToPattern.ml b/src/typing/matcher/exprToPattern.ml index 34a6ccd9ad1..bab145ef6f5 100644 --- a/src/typing/matcher/exprToPattern.ml +++ b/src/typing/matcher/exprToPattern.ml @@ -239,7 +239,7 @@ let rec make pctx toplevel t e = PatConstructor(con_const ct p,[]) | EConst (Ident i) -> begin match follow t with - | TFun(ta,tr) when tr == fake_tuple_type -> + | TFun(ta,tr,_) when tr == fake_tuple_type -> if i = "_" then PatTuple(List.map (fun (_,_,t) -> (PatAny,pos e)) ta) else raise_typing_error "Cannot bind matched tuple to variable, use _ instead" p | _ -> @@ -252,7 +252,7 @@ let rec make pctx toplevel t e = | ECall(e1,el) -> let e1 = type_expr ctx e1 (WithType.with_type t) in begin match e1.eexpr,follow e1.etype with - | TField(_, FEnum(en,ef)),TFun(_,tr) -> + | TField(_, FEnum(en,ef)),TFun(_,tr,_) -> let tl = match follow tr with | TEnum(_,tl) -> tl | _ -> fail() @@ -262,7 +262,7 @@ let rec make pctx toplevel t e = let map t = map (apply_params ef.ef_params monos t) in unify ctx (map ef.ef_type) e1.etype e1.epos; let args = match follow e1.etype with - | TFun(args,r) -> + | TFun(args,r,_) -> unify_expected r; args | _ -> die "" __LOC__ @@ -297,7 +297,7 @@ let rec make pctx toplevel t e = end | EArrayDecl el -> let rec pattern seen t = match follow t with - | TFun(tl,tr) when tr == fake_tuple_type -> + | TFun(tl,tr,_) when tr == fake_tuple_type -> let rec loop el tl = match el,tl with | e :: el,(_,_,t) :: tl -> let pat = make pctx false t e in diff --git a/src/typing/matcher/texprConverter.ml b/src/typing/matcher/texprConverter.ml index dfe269d63f9..20804462127 100644 --- a/src/typing/matcher/texprConverter.ml +++ b/src/typing/matcher/texprConverter.ml @@ -35,7 +35,7 @@ let s_subject v_lookup s e = if top then loop false s e1 else loop false (Printf.sprintf "{ %s: %s }" (field_name fa) s) e1 | TEnumParameter(e1,ef,i) -> - let arity = match follow ef.ef_type with TFun(args,_) -> List.length args | _ -> die "" __LOC__ in + let arity = match follow ef.ef_type with TFun(args,_,_) -> List.length args | _ -> die "" __LOC__ in let l = make_offset_list i (arity - i - 1) s "_" in loop false (Printf.sprintf "%s(%s)" ef.ef_name (String.concat ", " l)) e1 | TLocal v -> @@ -57,7 +57,7 @@ let s_match_kind = function let unify_constructor ctx params t con = match fst con with | ConEnum(en,ef) -> - let t_ef = match follow ef.ef_type with TFun(_,t) -> t | _ -> ef.ef_type in + let t_ef = match follow ef.ef_type with TFun(_,t,_) -> t | _ -> ef.ef_type in let t_ef = apply_params ctx.type_params params (monomorphs en.e_params (monomorphs ef.ef_params t_ef)) in let monos = List.map (fun t -> match follow t with | TInst({cl_kind = KTypeParameter _},_) | TMono _ -> mk_mono() diff --git a/src/typing/nullSafety.ml b/src/typing/nullSafety.ml index 63d9d0f1f78..90e138ec96b 100644 --- a/src/typing/nullSafety.ml +++ b/src/typing/nullSafety.ml @@ -303,7 +303,7 @@ class unificator = ) b.a_fields - method private unify_functions (a_args, a_result) (b_args, b_result) = + method private unify_functions (a_args, a_result, a_corotodo) (b_args, b_result, b_corotodo) = (* check return type *) (match b_result with | TAbstract ({ a_path = ([], "Void") }, []) -> () @@ -1412,7 +1412,7 @@ class expr_checker mode immediate_execution report = | Some cf -> let traverse t = match follow t with - | TFun (types, _) -> self#check_args e_new args types + | TFun (types, _, _) -> self#check_args e_new args types | _ -> fail ~msg:"Unexpected constructor type." e_new.epos __POS__ in let ctor_type = apply_params cls.cl_params params cf.cf_type in @@ -1432,7 +1432,7 @@ class expr_checker mode immediate_execution report = self#check_expr callee ); (match follow callee.etype with - | TFun (types, _) -> + | TFun (types, _, _) -> if is_trace callee then let real_args = match List.rev args with diff --git a/src/typing/operators.ml b/src/typing/operators.ml index c75663686be..569da669296 100644 --- a/src/typing/operators.ml +++ b/src/typing/operators.ml @@ -160,7 +160,7 @@ let unify_int ctx e k = in let is_dynamic_return t = match follow t with - | TFun (_,r) -> is_dynamic r + | TFun (_,r,_) -> is_dynamic r | _ -> true in (* @@ -450,7 +450,7 @@ let find_abstract_binop_overload ctx op e1 e2 a c tl left is_assign_op p = let is_impl = has_class_field_flag cf CfImpl in begin match follow cf.cf_type with - | TFun((_,_,t1) :: (_,_,t2) :: pos_infos, tret) -> + | TFun((_,_,t1) :: (_,_,t2) :: pos_infos, tret, _) -> (match pos_infos with | [] -> () | [_,true,t] when is_pos_infos t -> () diff --git a/src/typing/overloadResolution.ml b/src/typing/overloadResolution.ml index 456623bbf09..4ed62a1e27c 100644 --- a/src/typing/overloadResolution.ml +++ b/src/typing/overloadResolution.ml @@ -6,7 +6,7 @@ open FieldCallCandidate let unify_cf map_type c cf el = let monos = List.map (fun _ -> mk_mono()) cf.cf_params in match follow (apply_params cf.cf_params monos (map_type cf.cf_type)) with - | TFun(tl'',ret) as tf -> + | TFun(tl'',ret,_) as tf -> let rec loop2 acc el tl = match el,tl with | e :: el,(_,o,t) :: tl -> begin try @@ -57,7 +57,7 @@ let resolve_instance_overload is_ctor map_type c name el = let candidates = ref [] in let has_function t1 fcc2 = begin match follow t1,fcc2.fc_type with - | TFun(tl1,_),TFun(tl2,_) -> type_iseq (TFun(tl1,t_dynamic)) (TFun(tl2,t_dynamic)) + | TFun(tl1,_,coro1),TFun(tl2,_,coro2) -> type_iseq (TFun(tl1,t_dynamic,coro1)) (TFun(tl2,t_dynamic,coro2)) | _ -> false end in diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index cc3ec45e541..2ff1aae03a2 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -420,6 +420,15 @@ and load_instance' ctx ptp get_params mode = | [] -> t_dynamic | [TPType t] -> TDynamic (Some (load_complex_type ctx true LoadNormal t)) | _ -> raise_typing_error "Too many parameters for Dynamic" ptp.pos_full + else if info.build_path = ([],"Coroutine") then + match t.tparams with + | [TPType t] -> + begin match load_complex_type ctx true LoadNormal t with + | TFun(args,ret,_) -> TFun(args,ret,true) + | _ -> raise_typing_error "Argument type should be function" ptp.pos_full + end + | _ -> + raise_typing_error "Wrong number of arguments for Coroutine" ptp.pos_full else if info.build_params = [] then begin match t.tparams with | [] -> info.build_apply [] @@ -581,7 +590,7 @@ and load_complex_type' ctx allow_display mode (t,p) = let old = ctx.type_params in ctx.type_params <- !params @ old; let args = List.map (fun ((name,_),o,_,t,e) -> no_expr e; name, o, topt LoadNormal t) fd.f_args in - let t = TFun (args,topt LoadReturn fd.f_type), Method (if !dyn then MethDynamic else MethNormal) in + let t = TFun (args,topt LoadReturn fd.f_type,false), Method (if !dyn then MethDynamic else MethNormal) in ctx.type_params <- old; t | FProp (i1,i2,t,e) -> @@ -629,13 +638,13 @@ and load_complex_type' ctx allow_display mode (t,p) = | CTFunction (args,r) -> match args with | [CTPath { path = {tpackage = []; tparams = []; tname = "Void" }},_] -> - TFun ([],load_complex_type ctx allow_display LoadReturn r) + TFun ([],load_complex_type ctx allow_display LoadReturn r,false) | _ -> TFun (List.map (fun t -> let t, opt = (match fst t with CTOptional t | CTParent((CTOptional t,_)) -> t, true | _ -> t,false) in let n,t = (match fst t with CTNamed (n,t) -> (fst n), t | _ -> "", t) in n,opt,load_complex_type ctx allow_display LoadNormal t - ) args,load_complex_type ctx allow_display LoadReturn r) + ) args,load_complex_type ctx allow_display LoadReturn r,false) and load_complex_type ctx allow_display mode (t,pn) = try @@ -685,7 +694,7 @@ and init_meta_overloads ctx co cf = ) f.f_args in - let cf = { cf with cf_type = TFun (args,topt LoadReturn f.f_type); cf_params = params; cf_meta = cf_meta} in + let cf = { cf with cf_type = TFun (args,topt LoadReturn f.f_type,false); cf_params = params; cf_meta = cf_meta} in generate_args_meta ctx.com co (fun meta -> cf.cf_meta <- meta :: cf.cf_meta) f.f_args; overloads := cf :: !overloads; ctx.type_params <- old; @@ -694,7 +703,7 @@ and init_meta_overloads ctx co cf = add_class_field_flag cf CfOverload; let topt (n,_,t) = match t with | TMono t when t.tm_type = None -> raise_typing_error ("Explicit type required for overload functions\n... For function argument '" ^ n ^ "'") cf.cf_pos | _ -> () in (match follow cf.cf_type with - | TFun (args,_) -> List.iter topt args + | TFun (args,_,_) -> List.iter topt args | _ -> () (* could be a variable *)); true | (Meta.Overload,[],p) -> @@ -874,7 +883,11 @@ let init_core_api ctx c = raise_typing_error ("Field " ^ f.cf_name ^ " has different property access than core type") p; end; (match follow f.cf_type, follow f2.cf_type with - | TFun (pl1,_), TFun (pl2,_) -> + | TFun (pl1,_,coro1), TFun (pl2,_,coro2) -> + if coro1 then begin + if not coro2 then raise_typing_error "Method should be coroutine" p + end else if coro2 then + raise_typing_error "Method should not be coroutine" p; if List.length pl1 != List.length pl2 then raise_typing_error "Argument count mismatch" p; List.iter2 (fun (n1,_,_) (n2,_,_) -> if n1 <> n2 then raise_typing_error ("Method parameter name '" ^ n2 ^ "' should be '" ^ n1 ^ "'") p; diff --git a/src/typing/typeloadCheck.ml b/src/typing/typeloadCheck.ml index 65b9e6c956f..3adfd9e416a 100644 --- a/src/typing/typeloadCheck.ml +++ b/src/typing/typeloadCheck.ml @@ -93,7 +93,11 @@ let valid_redefinition map1 map2 f1 t1 f2 t2 = (* child, parent *) match f1.cf_kind,f2.cf_kind with | Method m1, Method m2 when not (m1 = MethDynamic) && not (m2 = MethDynamic) -> begin match follow t1, follow t2 with - | TFun (args1,r1) , TFun (args2,r2) -> ( + | TFun (args1,r1,coro1) , TFun (args2,r2,coro2) -> ( + if coro1 then begin + if not coro2 then raise (Unify_error [Unify_custom "Method should be coroutine"]) + end else if coro2 then + if not coro2 then raise (Unify_error [Unify_custom "Method should not be coroutine"]); if not (List.length args1 = List.length args2) then raise (Unify_error [Unify_custom "Different number of function arguments"]); let i = ref 0 in try @@ -421,7 +425,7 @@ module Inheritance = struct else begin let msg = if !is_overload then let ctx = print_context() in - let args = match follow f.cf_type with | TFun(args,_) -> String.concat ", " (List.map (fun (n,o,t) -> (if o then "?" else "") ^ n ^ " : " ^ (s_type ctx t)) args) | _ -> die "" __LOC__ in + let args = match follow f.cf_type with | TFun(args,_,_) -> String.concat ", " (List.map (fun (n,o,t) -> (if o then "?" else "") ^ n ^ " : " ^ (s_type ctx t)) args) | _ -> die "" __LOC__ in "No suitable overload for " ^ f.cf_name ^ "( " ^ args ^ " ), as needed by " ^ s_type_path intf.cl_path ^ " was found" else ("Field " ^ f.cf_name ^ " needed by " ^ s_type_path intf.cl_path ^ " is missing") @@ -497,7 +501,7 @@ module Inheritance = struct let pctx = print_context() in List.iter (fun (cf,_) -> let s = match follow cf.cf_type with - | TFun(tl,tr) -> + | TFun(tl,tr,_) -> String.concat ", " (List.map (fun (n,o,t) -> Printf.sprintf "%s:%s" n (s_type pctx t)) tl) | t -> s_type pctx t diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 0090850fca4..3f2105f310b 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -230,7 +230,7 @@ let ensure_struct_init_constructor ctx c ast_fields p = tf_type = ctx.t.tvoid; tf_expr = mk (TBlock el) ctx.t.tvoid p } in - let e = mk (TFunction tf) (TFun(tl @ super_tl,ctx.t.tvoid)) p in + let e = mk (TFunction tf) (TFun(tl @ super_tl,ctx.t.tvoid,false)) p in let cf = mk_field "new" e.etype p null_pos in cf.cf_doc <- doc_from_string (Buffer.contents doc_buf); cf.cf_expr <- Some e; @@ -657,7 +657,7 @@ module TypeBinding = struct let c = cctx.tclass in let rec is_full_type t = match t with - | TFun (args,ret) -> is_full_type ret && List.for_all (fun (_,_,t) -> is_full_type t) args + | TFun (args,ret,_) -> is_full_type ret && List.for_all (fun (_,_,t) -> is_full_type t) args | TMono r -> (match r.tm_type with None -> false | Some t -> is_full_type t) | TAbstract _ | TInst _ | TEnum _ | TLazy _ | TDynamic _ | TAnon _ | TType _ -> true in @@ -731,7 +731,7 @@ module TypeBinding = struct let c = cctx.tclass in let t = cf.cf_type in let p = cf.cf_pos in - let ctx = TyperManager.clone_for_expr ctx_f (if fctx.is_static then FunStatic else FunMember) false in + let ctx = TyperManager.clone_for_expr ctx_f (if fctx.is_static then FunStatic else FunMember) FunNotFunction in if (has_class_flag c CInterface) then unexpected_expression ctx.com fctx "Initialization on field of interface" (pos e); cf.cf_meta <- ((Meta.Value,[e],null_pos) :: cf.cf_meta); let check_cast e = @@ -822,9 +822,9 @@ module TypeBinding = struct | Some e -> bind_var_expression ctx cctx fctx cf e - let bind_method ctx_f cctx fctx fmode cf t args ret e p = + let bind_method ctx_f cctx fctx fmode cf t args ret e function_mode p = let c = cctx.tclass in - let ctx = TyperManager.clone_for_expr ctx_f fmode true in + let ctx = TyperManager.clone_for_expr ctx_f fmode function_mode in let bind r = incr stats.s_methods_typed; if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing method %s.%s\n" (s_type_path c.cl_path) cf.cf_name); @@ -943,8 +943,8 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = (* the return type of a from-function must be the abstract, not the underlying type *) if not fctx.is_macro then (try type_eq EqStrict ret ta with Unify_error l -> raise_typing_error_ext (make_error (Unify l) p)); match t with - | TFun([_,_,t],_) -> t - | TFun([(_,_,t1);(_,true,t2)],_) when is_pos_infos t2 -> t1 + | TFun([_,_,t],_,_) -> t + | TFun([(_,_,t1);(_,true,t2)],_,_) when is_pos_infos t2 -> t1 | _ -> raise_typing_error ("@:from cast functions must accept exactly one argument") p ) "@:from" in a.a_from_field <- (TLazy r,cf) :: a.a_from_field; @@ -960,10 +960,10 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = (match cf.cf_kind, cf.cf_type with | Var _, _ -> raise_typing_error "Invalid metadata: @:to must be used on method of abstract" p - | Method _, TFun(args, _) when not fctx.is_abstract_member && not (are_valid_args args) -> + | Method _, TFun(args, _,_) when not fctx.is_abstract_member && not (are_valid_args args) -> if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *) raise_typing_error "static @:to method should have one argument" p - | Method _, TFun(args, _) when fctx.is_abstract_member && not (are_valid_args args) -> + | Method _, TFun(args, _,_) when fctx.is_abstract_member && not (are_valid_args args) -> if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *) raise_typing_error "@:to method should have no arguments" p | _ -> () @@ -973,7 +973,7 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = let resolve_m args = (try unify_raise t (tfun (tthis :: args) m) cf.cf_pos with Error ({ err_message = Unify l; } as err) -> raise_typing_error_ext err); match follow m with - | TMono _ when (match t with TFun(_,r) -> r == t_dynamic | _ -> false) -> t_dynamic + | TMono _ when (match t with TFun(_,r,_) -> r == t_dynamic | _ -> false) -> t_dynamic | m -> m in let is_multitype_cast = Meta.has Meta.MultiType a.a_meta && not fctx.is_abstract_member in @@ -988,13 +988,13 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = in (* delay ctx PFinal (fun () -> unify ctx m tthis f.cff_pos); *) let args = match follow (monomorphs a.a_params ctor.cf_type) with - | TFun(args,_) -> List.map (fun (_,_,t) -> t) args + | TFun(args,_,_) -> List.map (fun (_,_,t) -> t) args | _ -> die "" __LOC__ in args end else match cf.cf_type with - | TFun([_;(_,true,t)],_) when is_pos_infos t -> [t] + | TFun([_;(_,true,t)],_,_) when is_pos_infos t -> [t] | _ -> [] in let t = resolve_m args in @@ -1016,11 +1016,11 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = end in begin match follow t with - | TFun((_,_,t1) :: (_,_,t2) :: args,_) when is_empty_or_pos_infos args -> + | TFun((_,_,t1) :: (_,_,t2) :: args,_,_) when is_empty_or_pos_infos args -> if a.a_read <> None then raise_typing_error "Multiple resolve-read methods are not supported" cf.cf_pos; check_fun t1 t2; a.a_read <- Some cf; - | TFun((_,_,t1) :: (_,_,t2) :: (_,_,t3) :: args,_) when is_empty_or_pos_infos args -> + | TFun((_,_,t1) :: (_,_,t2) :: (_,_,t3) :: args,_,_) when is_empty_or_pos_infos args -> if a.a_write <> None then raise_typing_error "Multiple resolve-write methods are not supported" cf.cf_pos; check_fun t1 t2; a.a_write <- Some cf; @@ -1043,9 +1043,9 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = let targ = if fctx.is_abstract_member then tthis else ta in let left_eq,right_eq = match follow t with - | TFun([(_,_,t1);(_,_,t2)],_) -> + | TFun([(_,_,t1);(_,_,t2)],_,_) -> type_iseq targ t1,type_iseq targ t2 - | TFun([(_,_,t1);(_,_,t2);(_,true,t3)],_) when is_pos_infos t3 -> + | TFun([(_,_,t1);(_,_,t2);(_,true,t3)],_,_) when is_pos_infos t3 -> type_iseq targ t1,type_iseq targ t2 | _ -> if fctx.is_abstract_member then @@ -1254,7 +1254,9 @@ let create_method (ctx,cctx,fctx) c f fd p = ctx.type_params <- params @ ctx.type_params; let args,ret = setup_args_ret ctx cctx fctx (fst f.cff_name) fd p in - let t = TFun (args#for_type,ret) in + let is_coroutine = Meta.has Meta.Coroutine f.cff_meta in + let function_mode = if is_coroutine then FunCoroutine else FunFunction in + let t = TFun (args#for_type,ret,is_coroutine) in let cf = { (mk_field name ~public:(is_public (ctx,cctx) f.cff_access parent) t f.cff_pos (pos f.cff_name)) with cf_doc = f.cff_doc; @@ -1325,18 +1327,18 @@ let create_method (ctx,cctx,fctx) c f fd p = init_meta_overloads ctx (Some c) cf; ctx.f.curfield <- cf; if fctx.do_bind then - TypeBinding.bind_method ctx cctx fctx fmode cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) + TypeBinding.bind_method ctx cctx fctx fmode cf t args ret fd.f_expr function_mode (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) else begin if fctx.is_display_field then begin delay ctx.g PTypeField (fun () -> (* We never enter type_function so we're missing out on the argument processing there. Let's do it here. *) - let ctx = TyperManager.clone_for_expr ctx fmode true in + let ctx = TyperManager.clone_for_expr ctx fmode function_mode in ignore(args#for_expr ctx) ); check_field_display ctx fctx c cf; end else delay ctx.g PTypeField (fun () -> - let ctx = TyperManager.clone_for_expr ctx fmode true in + let ctx = TyperManager.clone_for_expr ctx fmode function_mode in args#verify_extern ctx ); if fd.f_expr <> None then begin @@ -1358,7 +1360,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = if Meta.has Meta.IsVar f.cff_meta then raise_typing_error "Abstract properties cannot be real variables" f.cff_pos; let ta = apply_params a.a_params (extract_param_types a.a_params) a.a_this in tfun [ta] ret, tfun [ta;ret] ret - | _ -> tfun [] ret, TFun(["value",false,ret],ret) + | _ -> tfun [] ret, TFun(["value",false,ret],ret,false) in let find_accessor m = if fctx.is_static then begin diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml index db809d420fc..d95aa35b4b2 100644 --- a/src/typing/typeloadFunction.ml +++ b/src/typing/typeloadFunction.ml @@ -198,7 +198,7 @@ let add_constructor ctx_c c force_constructor p = | _ -> let values = get_value_meta cfsup.cf_meta in match follow cfsup.cf_type with - | TFun (args,_) -> + | TFun (args,_,_) -> List.map (fun (n,o,t) -> let def = try type_function_arg_value ctx t (Some (PMap.find n values)) false @@ -216,7 +216,7 @@ let add_constructor ctx_c c force_constructor p = tf_args = vars; tf_type = ctx.t.tvoid; tf_expr = super_call; - }) (TFun (List.map (fun (v,c) -> v.v_name, c <> None, v.v_type) vars,ctx.t.tvoid)) p in + }) (TFun (List.map (fun (v,c) -> v.v_name, c <> None, v.v_type) vars,ctx.t.tvoid,false)) p in cf.cf_expr <- Some constr; cf.cf_type <- t; unify ctx t constr.etype p; diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 1b91133d29f..66ea998a773 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -367,7 +367,7 @@ module TypeLevel = struct if PMap.mem s (!pnames) then raise_typing_error ("Duplicate argument `" ^ s ^ "` in enum constructor " ^ fst c.ec_name) p; pnames := PMap.add s () (!pnames); s, opt, load_type_hint ~opt ctx_ef p LoadNormal (Some (t,tp)) - ) l, rt) + ) l, rt, false) ) in let f = { ef_name = fst c.ec_name; diff --git a/src/typing/typeloadParse.ml b/src/typing/typeloadParse.ml index cfad8bff5f1..773975c1be7 100644 --- a/src/typing/typeloadParse.ml +++ b/src/typing/typeloadParse.ml @@ -172,7 +172,7 @@ module ConditionDisplay = struct let check_expr (e,p) = match e with | ECall ((EConst (Ident "version"),p),_) -> - let t = TFun ([("s",false,com.basic.tstring)],t_semver) in + let t = TFun ([("s",false,com.basic.tstring)],t_semver,false) in if check_position p then DisplayException.raise_hover (CompletionItem.make_ci_class_field { field = { diff --git a/src/typing/typer.ml b/src/typing/typer.ml index c3dbc68d239..8f2fe86010d 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -47,7 +47,7 @@ let get_iterator_param t = | TAnon a -> if !(a.a_status) <> Closed then raise Not_found; (match follow (PMap.find "hasNext" a.a_fields).cf_type, follow (PMap.find "next" a.a_fields).cf_type with - | TFun ([],tb), TFun([],t) when (match follow tb with TAbstract ({ a_path = [],"Bool" },[]) -> true | _ -> false) -> + | TFun ([],tb,_), TFun([],t,_) when (match follow tb with TAbstract ({ a_path = [],"Bool" },[]) -> true | _ -> false) -> if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 2 then raise Not_found; t | _ -> @@ -60,7 +60,7 @@ let get_iterable_param t = | TAnon a -> if !(a.a_status) <> Closed then raise Not_found; (match follow (PMap.find "iterator" a.a_fields).cf_type with - | TFun ([],it) -> + | TFun ([],it,_) -> let t = get_iterator_param it in if PMap.fold (fun _ acc -> acc + 1) a.a_fields 0 <> 1 then raise Not_found; t @@ -123,7 +123,7 @@ let maybe_type_against_enum ctx f with_type iscall p = begin match e with | AKExpr e -> begin match follow e.etype with - | TFun(_,t') when is_enum -> + | TFun(_,t',_) when is_enum -> (* TODO: this is a dodge for #7603 *) (try Type.unify t' t with Unify_error _ -> ()); AKExpr e @@ -207,14 +207,16 @@ let rec unify_min_raise ctx (el:texpr list) : t = | _ -> raise Exit in let args,tr0 = match follow e0.etype with - | TFun(tl,tr) -> + | TFun(tl,tr,_) -> Array.of_list tl,tr | _ -> raise Exit in let arity = Array.length args in + let is_coro = ref false in let rets = List.map (fun e -> match follow e.etype with - | TFun(tl,tr) -> + | TFun(tl,tr,coro) -> + is_coro := coro; (* no need for special checks, this will only unify if everything either is or isn't a coro anyway *) let ta = Array.of_list tl in if Array.length ta <> arity then raise Exit; for i = 0 to arity - 1 do @@ -236,7 +238,7 @@ let rec unify_min_raise ctx (el:texpr list) : t = | UnifyMinError(l,index) -> raise Exit in - TFun(Array.to_list args,tr) + TFun(Array.to_list args,tr,!is_coro) with Exit -> (* Second pass: Get all base types (interfaces, super classes and their interfaces) of most general type. Then for each additional type filter all types that do not unify. *) @@ -651,7 +653,7 @@ and type_access ctx e p mode with_type = let cf = fa.fa_field in no_abstract_constructor c p; check_constructor_access ctx c cf p; - let args = match follow (FieldAccess.get_map_function fa cf.cf_type) with TFun(args,ret) -> args | _ -> die "" __LOC__ in + let args = match follow (FieldAccess.get_map_function fa cf.cf_type) with TFun(args,ret,_) -> args | _ -> die "" __LOC__ in let vl = List.map (fun (n,_,t) -> alloc_var VGenerated n t c.cl_pos) args in let vexpr v = mk (TLocal v) v.v_type p in let el = List.map vexpr vl in @@ -671,7 +673,7 @@ and type_access ctx e p mode with_type = tf_args = List.map (fun v -> v,None) vl; tf_type = t; tf_expr = mk (TReturn (Some ec)) t p; - }) (TFun ((List.map (fun v -> v.v_name,false,v.v_type) vl),t)) p) + }) (TFun ((List.map (fun v -> v.v_name,false,v.v_type) vl),t,false)) p) | _ -> raise_typing_error "Binding new is only allowed on class types" p end; | EField _ -> @@ -885,7 +887,7 @@ and type_object_decl ctx fl with_type p = let fa = FieldAccess.get_constructor_access c tl p in let ctor = fa.fa_field in let args = match follow (FieldAccess.get_map_function fa ctor.cf_type) with - | TFun(args,_) -> + | TFun(args,_,_) -> begin match ctor.cf_expr with | Some {eexpr = TFunction tf} -> let rec loop acc args vl = match args,vl with @@ -1048,7 +1050,7 @@ and type_new ctx ptp el with_type force_inline p = | None -> raise_typing_error_ext (make_error (No_constructor (TClassDecl c)) p) | Some(tl,tr) -> - let el,_ = unify_call_args ctx el tl tr p false false false in + let el = unify_call_args ctx el tl tr p false false false in mk (TNew (c,params,el)) t p end | TAbstract({a_impl = Some c} as a,tl) when not (Meta.has Meta.MultiType a.a_meta) -> @@ -1212,7 +1214,7 @@ and type_map_declaration ctx e1 el with_type p = let el = (mk (TVar (v,Some enew)) t_dynamic p) :: (List.rev el) in mk (TBlock el) tmap p -and type_local_function ctx_from kind f with_type p = +and type_local_function ctx_from kind f with_type want_coroutine p = let name,inline = match kind with FKNamed (name,inline) -> Some name,inline | _ -> None,false in let params = TypeloadFunction.type_function_params ctx_from f TPHLocal (match name with None -> "localfun" | Some (n,_) -> n) p in let curfun = match ctx_from.e.curfun with @@ -1221,7 +1223,18 @@ and type_local_function ctx_from kind f with_type p = | FunMemberAbstractLocal -> FunMemberAbstractLocal | _ -> FunMemberClassLocal in - let ctx = TyperManager.clone_for_expr ctx_from curfun true in + let is_coroutine = match name, with_type with + | None, WithType.WithType (texpected,_) -> + (match follow texpected with + | TFun(_,_,true) -> + true + | _ -> + false) + | _ -> + want_coroutine + in + let function_mode = if is_coroutine then FunCoroutine else FunFunction in + let ctx = TyperManager.clone_for_expr ctx_from curfun function_mode in let vname,pname= match name with | None -> if params <> [] then begin @@ -1259,7 +1272,7 @@ and type_local_function ctx_from kind f with_type p = let rec loop l = match l with | t :: l -> begin match follow t with - | TFun(args,ret) when List.length args = arity -> + | TFun(args,ret,_) when List.length args = arity -> List.iteri (fun i (_,_,t) -> (* We don't want to bind monomorphs because we want the widest type *) let t = dynamify_monos t in @@ -1293,7 +1306,7 @@ and type_local_function ctx_from kind f with_type p = | WithType.WithType(t,_) -> let rec loop stack t = (match follow t with - | TFun (args2,tr) when List.length args2 = List.length targs -> + | TFun (args2,tr,_) when List.length args2 = List.length targs -> List.iter2 (fun (_,_,t1) (_,_,t2) -> maybe_unify_arg t1 t2 ) targs args2; @@ -1327,7 +1340,7 @@ and type_local_function ctx_from kind f with_type p = if name = None then display_error ctx.com "Unnamed lvalue functions are not supported" p | _ -> ()); - let ft = TFun (targs,rt) in + let ft = TFun (targs,rt,is_coroutine) in let ft = match with_type with | WithType.NoValue -> ft @@ -1351,7 +1364,8 @@ and type_local_function ctx_from kind f with_type p = } in let e = mk (TFunction tf) ft p in match v with - | None -> e + | None -> + e | Some v -> Typeload.generate_args_meta ctx.com None (fun m -> v.v_meta <- m :: v.v_meta) f.f_args; let open LocalUsage in @@ -1647,6 +1661,12 @@ and type_meta ?(mode=MGet) ctx m e1 with_type p = | (EReturn e, p) -> type_return ~implicit:true ctx e with_type p | _ -> e() end + | (Meta.Coroutine,_,_) -> + begin match fst e1 with + | EFunction (kind, f) -> + type_local_function ctx kind f with_type true p + | _ -> e() + end (* Allow `${...}` reification because it's a noop and happens easily with macros *) | (Meta.Dollar "",_,p) -> e() @@ -1710,6 +1730,12 @@ and type_call_access ctx e el mode with_type p_inline p = build_call_access ctx acc el mode with_type p and type_call_builtin ctx e el mode with_type p = + let create_coroutine e args ret p = + let args = args @ [("_hx_continuation",false,(tfun [ret; t_dynamic] ctx.com.basic.tvoid))] in + let ret = ctx.com.basic.tvoid in + let el = unify_call_args ctx el args ret p false false false in + mk (TCall (e, el)) (tfun [t_dynamic; t_dynamic] ctx.com.basic.tvoid) p + in match e, el with | (EConst (Ident "trace"),p) , e :: el -> if Common.defined ctx.com Define.NoTraces then @@ -1739,6 +1765,20 @@ and type_call_builtin ctx e el mode with_type p = (match follow e.etype with | TFun signature -> type_bind ctx e signature args p | _ -> raise Exit) + | (EField (e,"start",_),_), args -> + let e = type_expr ctx e WithType.value in + (match follow e.etype with + | TFun (args, ret, true) -> + let ecoro = create_coroutine e args ret p in + let enull = Builder.make_null t_dynamic p in + mk (TCall (ecoro, [enull; enull])) ctx.com.basic.tvoid p + | _ -> raise Exit) + | (EField (e,"create",_),_), args -> + let e = type_expr ctx e WithType.value in + (match follow e.etype with + | TFun (args, ret, true) -> + create_coroutine e args ret p + | _ -> raise Exit) | (EConst (Ident "$type"),_) , e1 :: el -> let expected = match el with | [EConst (Ident "_"),_] -> @@ -1950,7 +1990,7 @@ and type_expr ?(mode=MGet) ctx (e,p) (with_type:WithType.t) = let e = Matcher.Match.match_expr ctx e1 cases def with_type false p in wrap e | EReturn e -> - if not ctx.e.in_function then begin + if not (TyperManager.is_function_context ctx) then begin display_error ctx.com "Return outside function" p; match e with | None -> @@ -1985,7 +2025,7 @@ and type_expr ?(mode=MGet) ctx (e,p) (with_type:WithType.t) = | EUnop (op,flag,e) -> type_unop ctx op flag e with_type p | EFunction (kind,f) -> - type_local_function ctx kind f with_type p + type_local_function ctx kind f with_type false p | EUntyped e -> let old = ctx.f.untyped in ctx.f.untyped <- true; diff --git a/src/typing/typerBase.ml b/src/typing/typerBase.ml index fa7bdefb8e2..05d8f7928ed 100644 --- a/src/typing/typerBase.ml +++ b/src/typing/typerBase.ml @@ -289,7 +289,7 @@ let s_dot_path_part part = let get_constructible_constraint ctx tl p = let extract_function t = match follow t with - | TFun(tl,tr) -> tl,tr + | TFun(tl,tr,_) -> tl,tr | _ -> raise_typing_error "Constructible type parameter should be function" p in let rec loop tl = match tl with @@ -343,7 +343,7 @@ let get_abstract_froms ctx a pl = else if (AbstractFromConfig.update_config_from_meta (AbstractFromConfig.make ()) f.cf_meta).ignored_by_inference then acc else match follow (Type.field_type f) with - | TFun ([_,_,v],t) -> + | TFun ([_,_,v],t,_) -> (try ignore(type_eq EqStrict t (TAbstract(a,List.map duplicate pl))); (* unify fields monomorphs *) (FromField,v) :: acc diff --git a/src/typing/typerDisplay.ml b/src/typing/typerDisplay.ml index 1c38d20f87f..62757136c05 100644 --- a/src/typing/typerDisplay.ml +++ b/src/typing/typerDisplay.ml @@ -20,8 +20,8 @@ open Calls open Error open FieldAccess -let convert_function_signature ctx values (args,ret) = match CompletionType.from_type (get_import_status ctx) ~values (TFun(args,ret)) with - | CompletionType.CTFunction ctf -> ((args,ret),ctf) +let convert_function_signature ctx values (args,ret,coro) = match CompletionType.from_type (get_import_status ctx) ~values (TFun(args,ret,coro)) with + | CompletionType.CTFunction ctf -> ((args,ret,coro),ctf) | _ -> die "" __LOC__ let completion_item_of_expr ctx e = @@ -136,7 +136,7 @@ let completion_item_of_expr ctx e = let fcc = unify_field_call ctx fa el [] e.epos false in let cf = fcc.fc_field in let t = match follow (FieldAccess.get_map_function fa cf.cf_type) with - | TFun(args,_) -> TFun(args,TInst(c,tl)) + | TFun(args,_,coro) -> TFun(args,TInst(c,tl),coro) | t -> t in make_ci_class_field (CompletionClassField.make cf CFSConstructor (Self (decl_of_class c)) true) (tpair ~values:(get_value_meta cf.cf_meta) t) @@ -183,9 +183,9 @@ let display_dollar_type ctx p make_type = let arg = ["expression",false,mono] in begin match ctx.com.display.dms_kind with | DMSignature -> - raise_signatures [(convert_function_signature ctx PMap.empty (arg,mono),doc)] 0 0 SKCall + raise_signatures [(convert_function_signature ctx PMap.empty (arg,mono,false),doc)] 0 0 SKCall | DMHover -> - let t = TFun(arg,mono) in + let t = TFun(arg,mono,false) in raise_hover (make_ci_expr (mk (TIdent "trace") t p) (make_type t)) (Some (WithType.named_argument "expression")) p | DMDefinition | DMTypeDefinition -> raise_positions [] @@ -199,7 +199,7 @@ let rec handle_signature_display ctx e_ast with_type = let handle_call tl el p0 = let rec follow_with_callable (t,doc,values) = match follow t with | TAbstract(a,tl) when Meta.has Meta.Callable a.a_meta -> follow_with_callable (Abstract.get_underlying_type a tl,doc,values) - | TFun(args,ret) -> ((args,ret),doc,values) + | TFun(args,ret,coro) -> ((args,ret,coro),doc,values) | _ -> raise_typing_error ("Not a callable type: " ^ (s_type (print_context()) t)) p in let tl = List.map follow_with_callable tl in @@ -218,7 +218,7 @@ let rec handle_signature_display ctx e_ast with_type = let el = if el <> [] && display_arg >= List.length el then el @ [EConst (Ident "null"),null_pos] else el in let rec loop acc tl = match tl with | (t,doc,values) :: tl -> - let keep (args,r) = + let keep (args,r,coro) = begin try let _ = unify_call_args ctx el args r p false false false in true @@ -286,6 +286,11 @@ let rec handle_signature_display ctx e_ast with_type = (match follow e.etype with | TFun signature -> e | _ -> def ()) + | (EField (e,("start" | "create"),_),p) -> + let e = type_expr ctx e WithType.value in + (match follow e.etype with + | TFun(args,ret,true) -> {e with etype = coroutine_type ctx args ret} + | _ -> def ()) | _ -> def() in let tl = match e1.eexpr with @@ -316,19 +321,19 @@ let rec handle_signature_display ctx e_ast with_type = let e1 = type_expr ctx e1 WithType.value in begin match follow e1.etype with | TInst({cl_path=([],"Array")},[t]) -> - let res = convert_function_signature ctx PMap.empty (["index",false,ctx.t.tint],t) in + let res = convert_function_signature ctx PMap.empty (["index",false,ctx.t.tint],t,false) in raise_signatures [res,doc_from_string "The array index"] 0 0 SKCall | TAbstract(a,tl) -> (match a.a_impl with Some c -> ignore(c.cl_build()) | _ -> ()); let sigs = ExtList.List.filter_map (fun cf -> match follow cf.cf_type with - | TFun(_ :: args,r) -> + | TFun(_ :: args,r,coro) -> if ExtType.is_void (follow r) && (match with_type with WithType.NoValue -> false | _ -> true) then None else begin let map = apply_params a.a_params tl in let tl = List.map (fun (n,o,t) -> n,o,map t) args in let r = map r in - Some (convert_function_signature ctx PMap.empty (tl,r),cf.cf_doc) + Some (convert_function_signature ctx PMap.empty (tl,r,coro),cf.cf_doc) end | _ -> None @@ -558,9 +563,9 @@ let handle_display ctx e_ast dk mode with_type = let p = pos e_ast in begin match ctx.com.display.dms_kind with | DMSignature -> - raise_signatures [(convert_function_signature ctx PMap.empty (arg,ret),doc)] 0 0 SKCall + raise_signatures [(convert_function_signature ctx PMap.empty (arg,ret,false),doc)] 0 0 SKCall | DMHover -> - let t = TFun(arg,ret) in + let t = TFun(arg,ret,false) in raise_hover (make_ci_expr (mk (TIdent "trace") t p) (tpair t)) (Some (WithType.named_argument "value")) p | DMDefinition | DMTypeDefinition -> raise_positions [] diff --git a/src/typing/typerEntry.ml b/src/typing/typerEntry.ml index 9ceba485950..d10254bb6c8 100644 --- a/src/typing/typerEntry.ml +++ b/src/typing/typerEntry.ml @@ -52,7 +52,7 @@ let create com macros = get_build_infos = (fun() -> None); }; f = TyperManager.create_ctx_f null_field; - e = TyperManager.create_ctx_e FunStatic false; + e = TyperManager.create_ctx_e FunStatic FunNotFunction; pass = PBuildModule; allow_inline = true; allow_transform = true; diff --git a/std/StdTypes.hx b/std/StdTypes.hx index b67e3c45556..d6621c23239 100644 --- a/std/StdTypes.hx +++ b/std/StdTypes.hx @@ -170,3 +170,22 @@ typedef KeyValueIterable = { @see https://haxe.org/manual/types-abstract-array-access.html **/ extern interface ArrayAccess {} + +/** + Coroutine function. +**/ +@:coreType +abstract Coroutine { + /** + Suspend running coroutine and expose the continuation callback + for resuming coroutine execution. + **/ + @:coroutine + public static extern function suspend(f:(cont:(T, Null) -> Void)->Void):T; + + #if js // TODO: implement this all properly for all the targets + static function __init__():Void { + js.Syntax.code("{0} = {1}", Coroutine.suspend, cast function(f, cont) return (_, _) -> f(cont)); + } + #end +} diff --git a/std/haxe/macro/Type.hx b/std/haxe/macro/Type.hx index 4ee0afe1aef..e022a99c0a5 100644 --- a/std/haxe/macro/Type.hx +++ b/std/haxe/macro/Type.hx @@ -75,7 +75,7 @@ enum Type { @see https://haxe.org/manual/types-function.html **/ - TFun(args:Array<{name:String, opt:Bool, t:Type}>, ret:Type); + TFun(args:Array<{name:String, opt:Bool, t:Type}>, ret:Type, ?coroutine:Bool); /** Represents an anonymous structure type. diff --git a/std/hl/types/Int64Map.hx b/std/hl/types/Int64Map.hx index fcf711bd9ca..61cae736d5e 100644 --- a/std/hl/types/Int64Map.hx +++ b/std/hl/types/Int64Map.hx @@ -1,74 +1,74 @@ -/* - * Copyright (C)2005-2019 Haxe Foundation - * - * Permission is hereby granted, free of charge, to any person obtaining a - * copy of this software and associated documentation files (the "Software"), - * to deal in the Software without restriction, including without limitation - * the rights to use, copy, modify, merge, publish, distribute, sublicense, - * and/or sell copies of the Software, and to permit persons to whom the - * Software is furnished to do so, subject to the following conditions: - * - * The above copyright notice and this permission notice shall be included in - * all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER - * DEALINGS IN THE SOFTWARE. - */ - -package hl.types; - -#if (hl_ver >= version("1.13.0") && !hl_legacy32) - -typedef Int64MapData = Abstract<"hl_int64_map">; - -abstract Int64Map(Int64MapData) { - extern public inline function new() { - this = alloc(); - } - - @:hlNative("std", "hi64alloc") static function alloc():Int64MapData { - return null; - } - - @:hlNative("std", "hi64set") - public function set(key:haxe.Int64, value:Dynamic) {} - - @:hlNative("std", "hi64exists") - public function exists(key:haxe.Int64):Bool { - return false; - } - - @:hlNative("std", "hi64get") - public function get(key:haxe.Int64):Dynamic { - return null; - } - - @:hlNative("std", "hi64remove") - public function remove(key:haxe.Int64):Bool { - return false; - } - - @:hlNative("std", "hi64keys") - public function keysArray():NativeArray { - return null; - } - - @:hlNative("std", "hi64values") - public function valuesArray():NativeArray { - return null; - } - - @:hlNative("std", "hi64clear") - public function clear():Void {} - - extern public inline function iterator() { - return new NativeArray.NativeArrayIterator(valuesArray()); - } -} - -#end +/* + * Copyright (C)2005-2019 Haxe Foundation + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +package hl.types; + +#if (hl_ver >= version("1.13.0") && !hl_legacy32) + +typedef Int64MapData = Abstract<"hl_int64_map">; + +abstract Int64Map(Int64MapData) { + extern public inline function new() { + this = alloc(); + } + + @:hlNative("std", "hi64alloc") static function alloc():Int64MapData { + return null; + } + + @:hlNative("std", "hi64set") + public function set(key:haxe.Int64, value:Dynamic) {} + + @:hlNative("std", "hi64exists") + public function exists(key:haxe.Int64):Bool { + return false; + } + + @:hlNative("std", "hi64get") + public function get(key:haxe.Int64):Dynamic { + return null; + } + + @:hlNative("std", "hi64remove") + public function remove(key:haxe.Int64):Bool { + return false; + } + + @:hlNative("std", "hi64keys") + public function keysArray():NativeArray { + return null; + } + + @:hlNative("std", "hi64values") + public function valuesArray():NativeArray { + return null; + } + + @:hlNative("std", "hi64clear") + public function clear():Void {} + + extern public inline function iterator() { + return new NativeArray.NativeArrayIterator(valuesArray()); + } +} + +#end diff --git a/tests/misc/coroutines/.gitignore b/tests/misc/coroutines/.gitignore new file mode 100644 index 00000000000..444f0793565 --- /dev/null +++ b/tests/misc/coroutines/.gitignore @@ -0,0 +1,2 @@ +/test.js +/test.js.map diff --git a/tests/misc/coroutines/build.hxml b/tests/misc/coroutines/build.hxml new file mode 100644 index 00000000000..5ffad6504b0 --- /dev/null +++ b/tests/misc/coroutines/build.hxml @@ -0,0 +1,6 @@ +--class-path src +--library utest +--main Main +--debug +--js test.js +--cmd node test.js diff --git a/tests/misc/coroutines/src/Main.hx b/tests/misc/coroutines/src/Main.hx new file mode 100644 index 00000000000..8373005ade2 --- /dev/null +++ b/tests/misc/coroutines/src/Main.hx @@ -0,0 +1,10 @@ +function main() { + utest.UTest.run([ + new TestBasic(), + new TestControlFlow(), + new TestGenerator(), + #if js + new TestJsPromise(), + #end + ]); +} \ No newline at end of file diff --git a/tests/misc/coroutines/src/TestBasic.hx b/tests/misc/coroutines/src/TestBasic.hx new file mode 100644 index 00000000000..5afba856c14 --- /dev/null +++ b/tests/misc/coroutines/src/TestBasic.hx @@ -0,0 +1,47 @@ +class TestBasic extends utest.Test { + function testSimpleStart(async:Async) { + simple.start(42, (result,error) -> { + Assert.equals(42, result); + async.done(); + }); + } + + function testSimpleCreate(async:Async) { + var cont = simple.create(42, (result,error) -> { + Assert.equals(42, result); + async.done(); + }); + cont(null, null); + } + + function testErrorDirect(async:Async) { + error.start((result, error) -> { + // TODO: Exceptions.filter is currently run before coroutine processor + // so we get wrapped exception here... think what we want to do with this + var error:haxe.Exception = error; + Assert.equals("nope", error.message); + async.done(); + }); + } + + function testErrorPropagation(async:Async) { + @:coroutine function propagate() { + error(); + } + propagate.start((result, error) -> { + // TODO: Exceptions.filter is currently run before coroutine processor + // so we get wrapped exception here... think what we want to do with this + var error:haxe.Exception = error; + Assert.equals("nope", error.message); + async.done(); + }); + } + + @:coroutine static function simple(arg:Int):Int { + return arg; + } + + @:coroutine static function error() { + throw "nope"; + } +} diff --git a/tests/misc/coroutines/src/TestControlFlow.hx b/tests/misc/coroutines/src/TestControlFlow.hx new file mode 100644 index 00000000000..16f923ae1ee --- /dev/null +++ b/tests/misc/coroutines/src/TestControlFlow.hx @@ -0,0 +1,132 @@ +class TestControlFlow extends utest.Test { + function testIfThen(async:Async) { + @:coroutine function f(x) { + if (x) return 1; + return 2; + } + mapCalls.start([true, false], f, (result,error) -> { + Assert.same([1, 2], result); + async.done(); + }); + } + + function testIfThenReturnNoValue(async:Async) { + var v; + @:coroutine function f(x) { + v = 1; + if (x) { + return; + } + v = 2; + } + @:coroutine function f2(x) { f(x); return v; } + mapCalls.start([true, false], f2, (result,error) -> { + Assert.same([1, 2], result); + async.done(); + }); + } + + function testIfThenElse(async:Async) { + @:coroutine function f(x) { + return if (x) 1 else 2; + } + mapCalls.start([true, false], f, (result,error) -> { + Assert.same([1, 2], result); + async.done(); + }); + } + + function testSwitchNoDefault(async:Async) { + @:coroutine function f(x) { + switch (x) { + case 1: return "a"; + case 2: return "b"; + case 3: return "c"; + } + return "d"; + } + mapCalls.start([1, 2, 3, 4], f, (result,error) -> { + Assert.same(["a", "b", "c", "d"], result); + async.done(); + }); + } + + function testSwitchDefault(async:Async) { + @:coroutine function f(x) { + switch (x) { + case 1: return "a"; + case 2: return "b"; + case 3: return "c"; + default: return "d"; + } + return "e"; + } + mapCalls.start([1, 2, 3, 4], f, (result,error) -> { + Assert.same(["a", "b", "c", "d"], result); + async.done(); + }); + } + + function testLoop(async:Async) { + @:coroutine function f(x) { + var results = []; + var i = 0; + while (i < 10) { + if (i == 5 && x == 1) break; + if (i == 6 && x == 2) { i++; continue; } + results.push(i); + i++; + } + return results; + } + mapCalls.start([0, 1, 2], f, (result,error) -> { + Assert.same([ + [0,1,2,3,4,5,6,7,8,9], + [0,1,2,3,4], + [0,1,2,3,4,5,7,8,9] + ], result); + async.done(); + }); + } + + function testTryCatch(async:Async) { + mapCalls.start([new E1(), new E2()], tryCatch, (result,error) -> { + Assert.same(["e1", "e2"], result); + async.done(); + }); + } + + function testTryCatchFail(async:Async) { + tryCatch.start(new E3(), (result,error) -> { + Assert.isOfType(error, E3); + async.done(); + }); + } + + @:coroutine function tryCatch(e:haxe.Exception) { + try { + throw e; + } catch (e:E1) { + return "e1"; + } catch (e:E2) { + return "e2"; + } + return "none"; + } +} + +@:coroutine +private function mapCalls(args:Array, f:CoroutineTRet>):Array { + return [for (arg in args) f(arg)]; +} + +private class E1 extends haxe.Exception { + public function new() super("E1"); +} + +private class E2 extends haxe.Exception { + public function new() super("E1"); +} +private class E3 extends haxe.Exception { + public function new() super("E1"); +} diff --git a/tests/misc/coroutines/src/TestGenerator.hx b/tests/misc/coroutines/src/TestGenerator.hx new file mode 100644 index 00000000000..e88ed5e2d16 --- /dev/null +++ b/tests/misc/coroutines/src/TestGenerator.hx @@ -0,0 +1,77 @@ +class TestGenerator extends utest.Test { + function testSimple() { + var iter = sequence(yield -> { + yield(1); + yield(2); + yield(3); + }); + Assert.same([1,2,3], [for (v in iter) v]); + } + + function testTreeIter() { + @:coroutine function iterTreeRec(yield:Yield, tree:Tree) { + yield(tree.leaf); + if (tree.left != null) iterTreeRec(yield, tree.left); + if (tree.right != null) iterTreeRec(yield, tree.right); + } + + function iterTree(tree:Tree):Iterator { + return sequence(yield -> iterTreeRec(yield, tree)); + } + + var tree:Tree = { + leaf: 1, + left: { + leaf: 2, + left: {leaf: 3}, + right: {leaf: 4, left: {leaf: 5}}, + }, + right: { + leaf: 6, + left: {leaf: 7} + } + }; + + Assert.same([1,2,3,4,5,6,7], [for (v in iterTree(tree)) v]); + } +} + +private typedef Yield = CoroutineVoid>; + +private function sequence(f:Coroutine->Void>):Iterator { + var finished = false; + var nextValue:T = null; + + var nextStep = null; + + function finish(_, _) { + finished = true; + } + + @:coroutine function yield(value:T) { + nextValue = value; + Coroutine.suspend(cont -> nextStep = cont); + } + + function hasNext():Bool { + if (nextStep == null) { + nextStep = f.create(yield, finish); + nextStep(null, null); + } + return !finished; + } + + function next():T { + var value = nextValue; + nextStep(null, null); + return value; + } + + return {hasNext: hasNext, next: next}; +} + +private typedef Tree = { + var leaf:T; + var ?left:Tree; + var ?right:Tree; +} diff --git a/tests/misc/coroutines/src/TestJsPromise.hx b/tests/misc/coroutines/src/TestJsPromise.hx new file mode 100644 index 00000000000..9a6b9d57bf2 --- /dev/null +++ b/tests/misc/coroutines/src/TestJsPromise.hx @@ -0,0 +1,77 @@ +import js.lib.Error; +import js.lib.Promise; + +@:coroutine +private function await(p:Promise):T { + return Coroutine.suspend(cont -> p.then(r -> cont(r, null), e -> cont(null, e))); +} + +private function promise(c:Coroutine<()->T>):Promise { + return new Promise((resolve,reject) -> c.start((result, error) -> if (error != null) reject(error) else resolve(result))); +} + +class TestJsPromise extends utest.Test { + function testAwait(async:Async) { + var p = Promise.resolve(41); + + @:coroutine function awaiting() { + var x = await(p); + return x + 1; + } + + awaiting.start((result,error) -> { + Assert.equals(42, result); + async.done(); + }); + } + + function testPromise(async:Async) { + var p = promise(() -> 42); + p.then(result -> { + Assert.equals(42, result); + async.done(); + }); + } + + function testAsyncAwait(async:Async) { + var p1 = Promise.resolve(41); + + var p2 = promise(() -> { + var x = await(p1); + return x + 1; + }); + + p2.then(result -> { + Assert.equals(42, result); + async.done(); + }); + } + + function testAwaitRejected(async:Async) { + var p = Promise.reject("oh no"); + + @:coroutine function awaiting() { + var x = await(p); + return x + 1; + } + + awaiting.start((result,error) -> { + Assert.equals("oh no", error); + async.done(); + }); + } + + function testThrowInPromise(async:Async) { + var p = promise(() -> throw new Error("oh no")); + p.then( + function(result) { + Assert.fail(); + }, + function(error) { + Assert.isOfType(error, Error); + Assert.equals("oh no", (error : Error).message); + async.done(); + } + ); + } +} diff --git a/tests/misc/coroutines/src/import.hx b/tests/misc/coroutines/src/import.hx new file mode 100644 index 00000000000..4a8d34165e8 --- /dev/null +++ b/tests/misc/coroutines/src/import.hx @@ -0,0 +1,2 @@ +import utest.Assert; +import utest.Async; diff --git a/tests/runci/targets/Js.hx b/tests/runci/targets/Js.hx index 575422ffe5d..398d683f823 100644 --- a/tests/runci/targets/Js.hx +++ b/tests/runci/targets/Js.hx @@ -76,6 +76,10 @@ class Js { changeDirectory(getMiscSubDir("es6")); runCommand("haxe", ["run.hxml"]); + infoMsg("Test coroutines:"); + changeDirectory(getMiscSubDir("coroutines")); + runCommand("haxe", ["build.hxml"]); + haxelibInstallGit("HaxeFoundation", "hxnodejs"); final env = Sys.environment(); if ( diff --git a/tests/sys/gen_test_res.py b/tests/sys/gen_test_res.py old mode 100755 new mode 100644