Coroutine Experiments

.gitignore

@@ -137,3 +137,4 @@ lib.sexp
 src/compiler/version.ml
 tests/party
 tests/misc/projects/Issue10863/error.log
+tests/misc/coroutines/dump

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",

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

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
 		| _ ->

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

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 "<type";
 		Option.may (fun d -> 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</type>\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 ->

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)

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__

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

src/context/display/display.ml

@@ -70,15 +70,15 @@ 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
 				if type_iseq t' t then 0 (* equal types - perfect *)
 				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 *)

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

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

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