some random mess

src-json/meta.json

@@ -183,6 +183,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/context/common.ml

@@ -710,6 +710,7 @@ let create version s_version args =
 			tnull = (fun _ -> die "" __LOC__);
 			tstring = m;
 			tarray = (fun _ -> die "" __LOC__);
+			tcoroutine = (fun _ -> die "" __LOC__);
 		};
 		file_lookup_cache = Hashtbl.create 0;
 		file_keys = new file_keys;

src/context/typecore.ml

@@ -127,6 +127,7 @@ and typer = {
 	mutable in_display : bool;
 	mutable in_macro : bool;
 	mutable macro_depth : int;
+	mutable is_coroutine : bool;
 	mutable curfun : current_fun;
 	mutable ret : t;
 	mutable locals : (string, tvar) PMap.t;

src/core/tType.ml

@@ -372,6 +372,7 @@ type basic_types = {
 	mutable tnull : t -> t;
 	mutable tstring : t;
 	mutable tarray : t -> t;
+	mutable tcoroutine : t -> t;
 }
 
 type class_field_scope =

src/optimization/analyzer.ml

@@ -789,6 +789,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(bbl,bo,bb_next,_) ->
 			List.iter (fun (el,bb) -> edge bb ("case " ^ (String.concat " | " (List.map s_expr_pretty el)))) bbl;
 			(match bo with None -> () | Some bb -> edge bb "default");
@@ -939,7 +941,7 @@ module Run = struct
 		timer();
 		r
 
-	let create_analyzer_context com config e =
+	let create_analyzer_context com config e is_coroutine =
 		let g = Graph.create e.etype e.epos in
 		let ctx = {
 			com = com;
@@ -949,6 +951,7 @@ module Run = struct
 			   avoid problems with the debugger, see https://github.com/HaxeFoundation/hxcpp/issues/365 *)
 			temp_var_name = (match com.platform with Cpp -> "_hx_tmp" | _ -> "tmp");
 			entry = g.g_unreachable;
+			coroutine = if is_coroutine then Some (alloc_var VGenerated "_hx_result" t_dynamic e.epos) else None;
 			has_unbound = false;
 			loop_counter = 0;
 			loop_stack = [];
@@ -1060,7 +1063,7 @@ module Run = struct
 	let run_on_field ctx config c cf = match cf.cf_expr with
 		| Some e when not (is_ignored cf.cf_meta) && not (Typecore.is_removable_field ctx cf) ->
 			let config = update_config_from_meta ctx.Typecore.com config cf.cf_meta in
-			let actx = create_analyzer_context ctx.Typecore.com config e in
+			let actx = create_analyzer_context ctx.Typecore.com config e (Meta.has Meta.Coroutine cf.cf_meta) in
 			let debug() =
 				print_endline (Printf.sprintf "While analyzing %s.%s" (s_type_path c.cl_path) cf.cf_name);
 				List.iter (fun (s,e) ->
@@ -1087,6 +1090,13 @@ module Run = struct
 				| DebugFull -> debug()
 			end;
 			cf.cf_expr <- Some e;
+
+			(* lose Coroutine<T> type here *)
+			(match cf.cf_type with
+			| TAbstract ({ a_path = [],"Coroutine" }, [TFun (args, ret)]) ->
+				let args = args @ [("",false,tfun [ret] ctx.com.basic.tvoid)] in
+				cf.cf_type <- TFun (args, ctx.com.basic.tvoid);
+			| _ -> ())
 		| _ -> ()
 
 	let run_on_class ctx config c =
@@ -1107,7 +1117,7 @@ module Run = struct
 			| Some e ->
 				let tf = { tf_args = []; tf_type = e.etype; tf_expr = e; } in
 				let e = mk (TFunction tf) (tfun [] e.etype) e.epos in
-				let actx = create_analyzer_context ctx.Typecore.com {config with optimize = false} e in
+				let actx = create_analyzer_context ctx.Typecore.com {config with optimize = false} e false in
 				let e = run_on_expr actx e in
 				let e = match e.eexpr with
 					| TFunction tf -> tf.tf_expr
@@ -1139,6 +1149,6 @@ Typecore.analyzer_run_on_expr_ref := (fun com e ->
 	(* We always want to optimize because const propagation might be required to obtain
 	   a constant expression for inline field initializations (see issue #4977). *)
 	let config = {config with AnalyzerConfig.optimize = true} in
-	let actx = Run.create_analyzer_context com config e in
+	let actx = Run.create_analyzer_context com config e false in
 	Run.run_on_expr actx e
 )

src/optimization/analyzerTexprTransformer.ml

@@ -318,8 +318,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
+					| TAbstract ({ a_path = [], "Coroutine"}, _) -> true
+					| _ -> false
+				in
+				(match ctx.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 false e1 in
 		let bb,e2 = bind_to_temp bb false e2 in
@@ -723,9 +749,92 @@ and block_to_texpr ctx bb =
 	let e = mk (TBlock el) bb.bb_type bb.bb_pos in
 	e
 
+and block_to_texpr_coroutine ctx bb vcontinuation vresult p =
+	assert(bb.bb_closed);
+
+	let open Texpr.Builder in
+	let com = ctx.com in
+
+	let vstate = alloc_var VGenerated "_hx_state" com.basic.tint p in
+	let estate = make_local vstate p in
+
+	let tstatemachine = tfun [t_dynamic] com.basic.tvoid in
+	let vstatemachine = alloc_var VGenerated "_hx_stateMachine" tstatemachine p in
+	let estatemachine = make_local vstatemachine p in
+
+	let statecases = ref [] in
+
+	let rec loop bb back_state_id =
+		let p = bb.bb_pos in
+		let e_bb_id = make_int com.basic bb.bb_id p in
+		let el = DynArray.to_list bb.bb_el in
+		let set_state id = mk (TBinop (OpAssign,estate,make_int com.basic id p)) com.basic.tint p in
+		let ereturn = mk (TReturn None) com.basic.tvoid p in
+		let el = match bb.bb_syntax_edge with
+			| SESuspend (call, bb_next) ->
+				loop bb_next back_state_id;
+				let args = call.args @ [ estatemachine ] in
+
+				(* lose Coroutine<T> type for the called function not to confuse further filters and generators *)
+				let tcoroutine = tfun [t_dynamic] com.basic.tvoid in
+				let tfun = match follow call.efun.etype with
+					| TAbstract ({ a_path = [],"Coroutine" }, [TFun (args, ret)]) ->
+						let tcontinuation = tfun [ret] com.basic.tvoid in
+						let args = args @ [("",false,tcontinuation)] in
+						TFun (args, com.basic.tvoid)
+					| _ -> die "" __LOC__
+				in
+				let efun = { call.efun with etype = tfun } in
+				let ecreatecoroutine = mk (TCall (efun, args)) tcoroutine call.pos in
+				let ecallcoroutine = mk (TCall (ecreatecoroutine, [make_null t_dynamic p])) com.basic.tvoid call.pos in
+				let esetstate = set_state bb_next.bb_id in
+				el @ [esetstate; ecallcoroutine; ereturn]
+			| SENone ->
+				let esetstate = set_state back_state_id in
+				let el_rev,eresult = match List.rev el with
+				| { eexpr = TReturn (Some e) } :: el ->
+					el, e
+				| ({ eexpr = TReturn None } :: el) | el ->
+					el, make_null t_dynamic p
+				in
+				let econtinuation = make_local vcontinuation p in
+				let ecallcontinuation = mk (TCall (econtinuation, [eresult])) com.basic.tvoid p in
+				List.rev (ereturn :: ecallcontinuation :: esetstate :: el_rev)
+			| _ ->
+				die "TODO" __LOC__
+		in
+		let case = [e_bb_id], mk (TBlock el) com.basic.tvoid p in
+		statecases := case :: !statecases;
+	in
+	loop bb (-1);
+
+	let ethrow = mk (TThrow (make_string com.basic "Invalid coroutine state" p)) com.basic.tvoid p in
+	let eswitch = mk (TSwitch (estate, !statecases, Some ethrow)) com.basic.tvoid p in
+
+	let estatemachine_def = mk (TFunction {
+		tf_args = [(vresult,None)];
+		tf_type = com.basic.tvoid;
+		tf_expr = eswitch;
+	}) tstatemachine p in
+
+	mk (TBlock [
+		mk (TVar (vstate, Some (make_int com.basic bb.bb_id p))) com.basic.tvoid p;
+		mk (TVar (vstatemachine, Some estatemachine_def)) com.basic.tvoid p;
+		mk (TReturn (Some estatemachine)) com.basic.tvoid p;
+	]) com.basic.tvoid p
+
 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 e,tf_args,tf_type =
+		match ctx.coroutine with
+		| Some vresult ->
+			let vcontinuation = alloc_var VGenerated "_hx_continuation" (tfun [t_dynamic] ctx.com.basic.tvoid) p in
+			let e = block_to_texpr_coroutine ctx bb vcontinuation vresult p in
+			let tf_args = tf.tf_args @ [(vcontinuation,None)] in
+			e, tf_args, tf.tf_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)}
@@ -768,7 +877,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}) t p
 
 let to_texpr ctx =
 	func ctx ctx.entry.bb_id

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 suspend_call = {
@@ -582,6 +583,8 @@ module Graph = struct
 					loop scopes bb_next
 				| SEMerge bb ->
 					loop scopes bb
+				| SESuspend (_, bb) ->
+					loop scopes bb
 				| SENone ->
 					()
 			end
@@ -594,6 +597,7 @@ type analyzer_context = {
 	config : AnalyzerConfig.t;
 	graph : Graph.t;
 	temp_var_name : string;
+	coroutine : tvar option; (* if we're in a coroutine, this field will contain a tvar allocated for reentrancy result *)
 	mutable entry : BasicBlock.t;
 	mutable has_unbound : bool;
 	mutable loop_counter : int;

src/typing/callUnification.ml

@@ -319,6 +319,7 @@ let unify_field_call ctx fa el_typed el p inline =
 			in
 			make_field_call_candidate el ret monos tf cf (mk_call,extract_delayed_display())
 		| t ->
+			(* TODO: field coroutine functions *)
 			error (s_type (print_context()) t ^ " cannot be called") p
 	in
 	let maybe_raise_unknown_ident cerr p =
@@ -521,6 +522,17 @@ object(self)
 			mk (TCall (e,el)) t p
 		in
 		let rec loop t = match follow t with
+		| TAbstract({ a_path = [],"Coroutine" }, [ft]) ->
+			if ctx.is_coroutine then
+				match loop ft with
+				| { eexpr = TCall (efun, eargs) } as e ->
+					(* preserve Coroutine<T> type so we can detect suspending calls when building CFG *)
+					let efun = { efun with etype = t } in
+					{ e with eexpr = TCall (efun, eargs) }
+				| _ ->
+					die "" __LOC__
+			else
+				error "Cannot directly call coroutine from a normal function, use start/create methods instead" p
 		| TFun (args,r) ->
 			let el, tfunc = unify_call_args ctx el args r p false false false in
 			let r = match tfunc with TFun(_,r) -> r | _ -> die "" __LOC__ in

src/typing/typeloadFields.ml

@@ -905,7 +905,7 @@ module TypeBinding = struct
 		| Some e ->
 			bind_var_expression ctx cctx fctx cf e
 
-	let bind_method ctx cctx fctx cf t args ret e p =
+	let bind_method ctx cctx fctx cf t args ret e p is_coroutine =
 		let c = cctx.tclass in
 		let bind r =
 			r := lazy_processing (fun() -> t);
@@ -926,7 +926,7 @@ module TypeBinding = struct
 					cf.cf_type <- t
 				| _ ->
 					if Meta.has Meta.DisplayOverride cf.cf_meta then DisplayEmitter.check_field_modifiers ctx c cf fctx.override fctx.display_modifier;
-					let e = TypeloadFunction.type_function ctx args ret fmode e fctx.is_display_field p in
+					let e = TypeloadFunction.type_function ctx args ret fmode e is_coroutine fctx.is_display_field p in
 					begin match fctx.field_kind with
 					| FKNormal when not fctx.is_static -> TypeloadCheck.check_overriding ctx c cf
 					| _ -> ()
@@ -1230,6 +1230,8 @@ let create_method (ctx,cctx,fctx) c f fd p =
 	let type_arg opt t p = FunctionArguments.type_opt ctx cctx.is_core_api fctx.is_abstract p t in
 	let args = new FunctionArguments.function_arguments ctx type_arg is_extern fctx.is_display_field abstract_this fd.f_args in
 	let t = TFun (args#for_type,ret) in
+	let is_coroutine = Meta.has Meta.Coroutine f.cff_meta in
+	let t = if is_coroutine then ctx.com.basic.tcoroutine t else t in
 	let cf = {
 		(mk_field (fst f.cff_name) ~public:(is_public (ctx,cctx) f.cff_access parent) t f.cff_pos (pos f.cff_name)) with
 		cf_doc = f.cff_doc;
@@ -1273,7 +1275,7 @@ let create_method (ctx,cctx,fctx) c f fd p =
 	init_meta_overloads ctx (Some c) cf;
 	ctx.curfield <- cf;
 	if fctx.do_bind then
-		TypeBinding.bind_method ctx cctx fctx 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 cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) is_coroutine
 	else begin
 		if fctx.is_display_field then begin
 			delay ctx PTypeField (fun () ->

src/typing/typeloadFunction.ml

@@ -31,6 +31,7 @@ open FunctionArguments
 
 let save_field_state ctx =
 	let old_ret = ctx.ret in
+	let old_is_coroutine = ctx.is_coroutine in
 	let old_fun = ctx.curfun in
 	let old_opened = ctx.opened in
 	let old_monos = ctx.monomorphs.perfunction in
@@ -39,6 +40,7 @@ let save_field_state ctx =
 	(fun () ->
 		ctx.locals <- locals;
 		ctx.ret <- old_ret;
+		ctx.is_coroutine <- old_is_coroutine;
 		ctx.curfun <- old_fun;
 		ctx.opened <- old_opened;
 		ctx.monomorphs.perfunction <- old_monos;
@@ -50,9 +52,10 @@ let type_function_params ctx fd fname p =
 	params := Typeload.type_type_params ctx ([],fname) (fun() -> !params) p fd.f_params;
 	!params
 
-let type_function ctx (args : function_arguments) ret fmode e do_display p =
+let type_function ctx (args : function_arguments) ret fmode e is_coroutine do_display p =
 	ctx.in_function <- true;
 	ctx.curfun <- fmode;
+	ctx.is_coroutine <- is_coroutine;
 	ctx.ret <- ret;
 	ctx.opened <- [];
 	ctx.monomorphs.perfunction <- [];
@@ -177,9 +180,9 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p =
 	if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e));
 	e
 
-let type_function ctx args ret fmode e do_display p =
+let type_function ctx args ret fmode e is_coroutine do_display p =
 	let save = save_field_state ctx in
-	Std.finally save (type_function ctx args ret fmode e do_display) p
+	Std.finally save (type_function ctx args ret fmode e is_coroutine do_display) p
 
 let add_constructor ctx c force_constructor p =
 	if c.cl_constructor <> None then () else

src/typing/typeloadModule.ml

@@ -984,6 +984,7 @@ let type_types_into_module ctx m tdecls p =
 		ret = ctx.ret;
 		locals = PMap.empty;
 		type_params = [];
+		is_coroutine = false;
 		curfun = FunStatic;
 		untyped = false;
 		in_macro = ctx.in_macro;

src/typing/typer.ml

@@ -1225,7 +1225,7 @@ and type_local_function ctx kind f with_type p =
 		| FunMemberAbstractLocal -> FunMemberAbstractLocal
 		| _ -> FunMemberClassLocal
 	in
-	let e = TypeloadFunction.type_function ctx args rt curfun f.f_expr ctx.in_display p in
+	let e = TypeloadFunction.type_function ctx args rt curfun f.f_expr false (* TODO: support local coroutines *) ctx.in_display p in
 	ctx.type_params <- old_tp;
 	ctx.in_loop <- old_in_loop;
 	let tf = {
@@ -1564,6 +1564,12 @@ and type_call ?(mode=MGet) ctx e el (with_type:WithType.t) inline p =
 		let e = type_call_target ctx e el with_type inline p in
 		build_call ~mode ctx e el with_type p;
 	in
+	let create_coroutine e args ret p =
+		let args = args @ [("_hx_continuation",false,(tfun [ret] 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] ctx.com.basic.tvoid) p
+	in
 	match e, el with
 	| (EConst (Ident "trace"),p) , e :: el ->
 		if Common.defined ctx.com Define.NoTraces then
@@ -1597,6 +1603,19 @@ and type_call ?(mode=MGet) ctx e el (with_type:WithType.t) inline p =
 		(match follow e.etype with
 			| TFun signature -> type_bind ctx e signature args p
 			| _ -> def ())
+	| (EField (e,"start"),_), args ->
+		let e = type_expr ctx e WithType.value in
+		(match follow e.etype with
+			| TAbstract ({ a_path = [],"Coroutine" }, [TFun (args, ret)]) ->
+				let ecoro = create_coroutine e args ret p in
+				mk (TCall (ecoro, [Builder.make_null t_dynamic p])) ctx.com.basic.tvoid p
+			| _ -> def ())
+	| (EField (e,"create"),_), args ->
+		let e = type_expr ctx e WithType.value in
+		(match follow e.etype with
+			| TAbstract ({ a_path = [],"Coroutine" }, [TFun (args, ret)]) ->
+				create_coroutine e args ret p
+			| _ -> def ())
 	| (EConst (Ident "$type"),_) , [e] ->
 		let e = type_expr ctx e WithType.value in
 		ctx.com.warning (s_type (print_context()) e.etype) e.epos;
@@ -1877,6 +1896,7 @@ let rec create com =
 		pass = PBuildModule;
 		macro_depth = 0;
 		untyped = false;
+		is_coroutine = false;
 		curfun = FunStatic;
 		in_function = false;
 		in_loop = false;
@@ -1921,6 +1941,7 @@ let rec create com =
 			| "Int" -> ctx.t.tint <- TAbstract (a,[])
 			| "Bool" -> ctx.t.tbool <- TAbstract (a,[])
 			| "Dynamic" -> t_dynamic_def := TAbstract(a,List.map snd a.a_params);
+			| "Coroutine" -> ctx.t.tcoroutine <- fun t -> TAbstract (a,[t]);
 			| "Null" ->
 				let mk_null t =
 					try

std/StdTypes.hx

@@ -170,3 +170,9 @@ typedef KeyValueIterable<K, V> = {
 	@see https://haxe.org/manual/types-abstract-array-access.html
 **/
 extern interface ArrayAccess<T> {}
+
+/**
+	Coroutine function.
+**/
+@:coreType
+abstract Coroutine<T> {}