Merge branch 'coroutines_2024' into coroutines_2024_server_tests

src/coro/coro.ml

@@ -29,6 +29,7 @@ let create_coro_context com meta =
 		vthis = None;
 		next_block_id = 0;
 		cb_unreachable = Obj.magic "";
+		current_catch = None;
 	} in
 	ctx.cb_unreachable <- make_block ctx None;
 	ctx

src/coro/coroDebug.ml

@@ -55,12 +55,15 @@ let create_dotgraph path cb =
 				edge_block "next" cb_next;
 				edge_block "body" cb_body;
 				Some ("while " ^ se e)
-			| NextTry(cb_try,catches,cb_next) ->
+			| NextTry(cb_try,catch,cb_next) ->
 				edge_block "next" cb_next;
 				edge_block "try" cb_try;
+				DynArray.add edges (cb_try.cb_id,catch.cc_cb.cb_id,"catch",true);
+				Printf.fprintf ch "n%i [shape=box,label=\"(%i)\"];\n" catch.cc_cb.cb_id catch.cc_cb.cb_id;
 				List.iter (fun (v,cb_catch) ->
-					edge_block (st v.v_type) cb_catch
-				) catches;
+					block cb_catch;
+					DynArray.add edges (catch.cc_cb.cb_id,cb_catch.cb_id,(st v.v_type),true);
+				) catch.cc_catches;
 				None
 			| NextSuspend(suspend,cb_next) ->
 				edge_block "next" cb_next;
@@ -83,6 +86,6 @@ let create_dotgraph path cb =
 	ignore(block cb);
 	DynArray.iter (fun (id_from,id_to,label,tree_edge) ->
 		let style = if tree_edge then "style=\"solid\",color=\"black\""  else "style=\"dashed\", color=\"lightgray\"" in
-		Printf.fprintf ch "n%i -> n%i[%s label=\"%s\"];\n" id_from id_to style label;
+		Printf.fprintf ch "n%i -> n%i[%s label=\"%s\"];\n" id_from id_to style (StringHelper.s_escape label);
 	) edges;
 	close();

src/coro/coroFromTexpr.ml

@@ -117,13 +117,22 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 			loop cb ret (Texpr.for_remap ctx.com.basic v e1 e2 e.epos)
 		| TCast(e1,o) ->
 			let cb,e1 = loop cb ret e1 in
-			cb,{e with eexpr = TCast(e1,o)}
+			if e1 == e_no_value then
+				cb,e1
+			else
+				cb,{e with eexpr = TCast(e1,o)}
 		| TParenthesis e1 ->
 			let cb,e1 = loop cb ret e1 in
-			cb,{e with eexpr = TParenthesis e1}
+			if e1 == e_no_value then
+				cb,e1
+			else
+				cb,{e with eexpr = TParenthesis e1}
 		| TMeta(meta,e1) ->
 			let cb,e1 = loop cb ret e1 in
-			cb,{e with eexpr = TMeta(meta,e1)}
+			if e1 == e_no_value then
+				cb,e1
+			else
+				cb,{e with eexpr = TMeta(meta,e1)}
 		| TUnop(op,flag,e1) ->
 			let cb,e1 = loop cb ret (* TODO: is this right? *) e1 in
 			cb,{e with eexpr = TUnop(op,flag,e1)}
@@ -145,7 +154,7 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 		| TVar(v,Some e1) ->
 			add_expr cb {e with eexpr = TVar(v,None)};
 			let cb,e1 = loop_assign cb (RLocal v) e1 in
-			cb,e_no_value
+			cb,e1
 		(* calls *)
 		| TCall(e1,el) ->
 			let cb,el = ordered_loop cb (e1 :: el) in
@@ -252,17 +261,25 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 			terminate cb (NextWhile(e1,cb_body,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TTry(e1,catches) ->
-			let cb_try = block_from_e e1 in
 			let cb_next = make_block None in
-			let cb_try_next,_ = loop_block cb_try ret e1 in
-			fall_through cb_try_next cb_next;
 			let catches = List.map (fun (v,e) ->
 				let cb_catch = block_from_e e in
 				let cb_catch_next,_ = loop_block cb_catch ret e in
 				fall_through cb_catch_next cb_next;
 				v,cb_catch
 			) catches in
-			terminate cb (NextTry(cb_try,catches,cb_next)) e.etype e.epos;
+			let catch = make_block None in
+			let old = ctx.current_catch in
+			ctx.current_catch <- Some catch;
+			let catch = {
+				cc_cb = catch;
+				cc_catches = catches;
+			} in
+			let cb_try = block_from_e e1 in
+			let cb_try_next,_ = loop_block cb_try ret e1 in
+			ctx.current_catch <- old;
+			fall_through cb_try_next cb_next;
+			terminate cb (NextTry(cb_try,catch,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TFunction tf ->
 			cb,e
@@ -280,7 +297,9 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 		cb,el
 	and loop_assign cb ret e =
 		let cb,e = loop cb ret e in
-		match ret with
+		if e == e_no_value then
+			cb,e
+		else match ret with
 			| RBlock ->
 				add_expr cb e;
 				cb,e_no_value

src/coro/coroFunctions.ml

@@ -10,4 +10,5 @@ let make_block ctx typepos =
 		cb_el = DynArray.create ();
 		cb_typepos = typepos;
 		cb_next = {next_kind = NextUnknown; next_type = t_dynamic; next_pos = null_pos};
+		cb_catch = ctx.current_catch;
 	}

src/coro/coroToTexpr.ml

@@ -24,30 +24,10 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 	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
-	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
 	let estatemachine = make_local vstatemachine p in
 
-	let get_next_state_id =
-		fun () -> (
-			let id = ctx.next_block_id in
-			ctx.next_block_id <- ctx.next_block_id + 1;
-			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
@@ -57,6 +37,7 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 		mk (TCall (econtinuation, [make_null t_dynamic p; eerror])) com.basic.tvoid p
 	in
 
+	let cb_uncaught = CoroFunctions.make_block ctx None in
 	let mk_suspending_call call =
 		let p = call.cs_pos in
 
@@ -83,20 +64,15 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 
 	let states = ref [] in
 
-	let exc_states = ref [] in
-
 	let init_state = ref 1 in (* TODO: this seems brittle *)
 
 	let make_state id el = {
 		cs_id = id;
 		cs_el = el;
 	} in
-	let debug_endline s =
-		if ctx.coro_debug then
-			print_endline s
-	in
-	debug_endline "---";
-	let rec loop cb current_el exc_state_id_getter =
+
+	let exc_state_map = Array.init ctx.next_block_id (fun _ -> ref []) in
+	let rec loop cb current_el =
 		assert (cb != ctx.cb_unreachable);
 		let el = DynArray.to_list cb.cb_el in
 
@@ -111,11 +87,18 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 					(set_state id) :: el
 			in
 			states := (make_state cb.cb_id el) :: !states;
+			begin match cb.cb_catch with
+				| None ->
+					()
+				| Some cb' ->
+					let r = exc_state_map.(cb'.cb_id) in
+					r := cb.cb_id :: !r
+			end;
 			cb.cb_id
 		in
 		match cb.cb_next.next_kind with
 		| NextSuspend (call, cb_next) ->
-			let next_state_id = loop cb_next [] exc_state_id_getter in
+			let next_state_id = loop cb_next [] in
 			let ecallcoroutine = mk_suspending_call call in
 			add_state (Some next_state_id) [ecallcoroutine; ereturn];
 		| NextUnknown ->
@@ -149,36 +132,36 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 			(* If we're skipping our initial state we have to track this for the _hx_state init *)
 			if cb.cb_id = !init_state then
 				init_state := cb_sub.cb_id;
-			loop cb_sub current_el exc_state_id_getter
+			loop cb_sub current_el
 		| NextSub (bb_sub,bb_next) ->
-			let next_state_id = loop bb_next [] exc_state_id_getter in
-			let sub_state_id = loop bb_sub [] exc_state_id_getter in
+			let next_state_id = loop bb_next [] in
+			let sub_state_id = loop bb_sub [] in
 			ignore(next_state_id);
 			add_state (Some sub_state_id) []
 
 		| NextIfThen (econd,bb_then,bb_next) ->
-			let next_state_id = loop bb_next [] exc_state_id_getter in
-			let then_state_id = loop bb_then [] exc_state_id_getter in
+			let next_state_id = loop bb_next [] in
+			let then_state_id = loop bb_then [] in
 			let eif = mk (TIf (econd, set_state then_state_id, Some (set_state next_state_id))) com.basic.tint p in
 			add_state None [eif]
 
 		| NextIfThenElse (econd,bb_then,bb_else,bb_next) ->
-			let _ = loop bb_next [] exc_state_id_getter in
-			let then_state_id = loop bb_then [] exc_state_id_getter in
-			let else_state_id = loop bb_else [] exc_state_id_getter in
+			let _ = loop bb_next [] in
+			let then_state_id = loop bb_then [] in
+			let else_state_id = loop bb_else [] in
 			let eif = mk (TIf (econd, set_state then_state_id, Some (set_state else_state_id))) com.basic.tint p in
 			add_state None [eif]
 
 		| NextSwitch(switch, bb_next) ->
 			let esubj = switch.cs_subject in
-			let next_state_id = loop bb_next [] exc_state_id_getter in
+			let next_state_id = loop bb_next [] in
 			let ecases = List.map (fun (patterns,bb) ->
-				let case_state_id = loop bb [] exc_state_id_getter in
+				let case_state_id = loop bb [] in
 				{case_patterns = patterns;case_expr = set_state case_state_id}
 			) switch.cs_cases in
 			let default_state_id = match switch.cs_default with
 				| Some bb ->
-					let default_state_id = loop bb [] exc_state_id_getter in
+					let default_state_id = loop bb [] in
 					default_state_id
 				| None ->
 					next_state_id
@@ -189,42 +172,35 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 			add_state None [eswitch]
 
 		| NextWhile (e_cond, bb_body, bb_next) ->
-			let body_state_id = loop bb_body [] exc_state_id_getter in
-			let _ = loop bb_next [] exc_state_id_getter in
+			let body_state_id = loop bb_body [] in
+			let _ = loop bb_next [] in
 			add_state (Some body_state_id) []
 
-		| NextTry (bb_try,catches,bb_next) ->
-			let new_exc_state_id = get_next_state_id () in
-			let esetexcstate = set_excstate (exc_state_id_getter ()) in
-			let _ = loop bb_next [esetexcstate (* TODO: test propagation after try/catch *)] exc_state_id_getter in
-			let try_state_id = loop bb_try [set_excstate new_exc_state_id] (fun () -> new_exc_state_id) in (* TODO: add test for nested try/catch *)
-			let catch_case =
-				let erethrow = mk (TBlock [
-					set_state (get_rethrow_state_id ());
-					mk (TThrow eerror) t_dynamic null_pos
-				]) t_dynamic null_pos in
-				let eif =
-					List.fold_left (fun enext (vcatch,bb_catch) ->
-						let ecatchvar = mk (TVar (vcatch, Some eerror)) com.basic.tvoid null_pos in
-						let catch_state_id = loop bb_catch [esetexcstate; ecatchvar] exc_state_id_getter in
-
-						(* 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 (List.rev catches)
-				in
-				make_state new_exc_state_id [eif]
+		| NextTry (bb_try,catch,bb_next) ->
+			let new_exc_state_id = catch.cc_cb.cb_id in
+			let _ = loop bb_next [] in
+			let try_state_id = loop bb_try [] in
+			let erethrow = mk (TBlock [
+				set_state (match catch.cc_cb.cb_catch with None -> cb_uncaught.cb_id | Some cb -> cb.cb_id);
+			]) t_dynamic null_pos in
+			let eif =
+				List.fold_left (fun enext (vcatch,bb_catch) ->
+					let ecatchvar = mk (TVar (vcatch, Some eerror)) com.basic.tvoid null_pos in
+					let catch_state_id = loop bb_catch [ecatchvar] in
+					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 (List.rev catch.cc_catches)
 			in
-			exc_states := catch_case :: !exc_states;
+			states := (make_state new_exc_state_id [eif]) :: !states;
 			add_state (Some try_state_id) []
 	in
-	ignore(loop cb [] get_rethrow_state_id);
+	ignore(loop cb []);
 
-	let states = !states @ !exc_states in
+	let states = !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 *)
@@ -289,7 +265,7 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 		- 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_id = cb_uncaught.cb_id in
 	let rethrow_state = make_state rethrow_state_id [mk (TThrow eerror) com.basic.tvoid null_pos] in
 	let states = states @ [rethrow_state] in
 	let states = List.sort (fun state1 state2 -> state1.cs_id - state2.cs_id) states in
@@ -309,46 +285,63 @@ let block_to_texpr_coroutine ctx cb vcontinuation vresult verror p =
 	in
 	let eswitch = mk (TSwitch switch) com.basic.tvoid p in
 
-	let eloop = mk (TWhile (make_bool com.basic true p, eswitch, DoWhile)) com.basic.tvoid p in
-
-	let etry = mk (TTry (
-		eloop,
-		[
-			let vcaught = alloc_var VGenerated "e" t_dynamic null_pos in
-			(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 (TCall(estatemachine,[make_local vresult p; make_local vcaught null_pos])) com.basic.tvoid p
-				]) com.basic.tvoid null_pos)
-			)) com.basic.tvoid null_pos)
-		]
-	)) com.basic.tvoid null_pos in
-
 	let eif = mk (TIf (
 		mk (TBinop (
 			OpNotEq,
 			eerror,
 			make_null verror.v_type p
 		)) com.basic.tbool p,
-		mk_assign estate eexcstate,
+		set_state cb_uncaught.cb_id,
 		None
 	)) com.basic.tvoid p in
 
+	let etry = mk (TTry (
+		eswitch,
+		[
+			let vcaught = alloc_var VGenerated "e" t_dynamic null_pos in
+			let cases = DynArray.create () in
+			Array.iteri (fun i l -> match !l with
+				| [] ->
+					()
+				| l ->
+					let patterns = List.map mk_int l in
+					let expr = mk (TBlock [
+						set_state i;
+						Builder.binop OpAssign eerror (Builder.make_local vcaught null_pos) vcaught.v_type null_pos;
+					]) ctx.com.basic.tvoid null_pos in
+					DynArray.add cases {case_patterns = patterns; case_expr = expr};
+			) exc_state_map;
+			let default = mk (TBlock [
+				set_state rethrow_state_id;
+				mk_continuation_call_error (make_local vcaught null_pos) null_pos;
+				mk (TReturn None) t_dynamic null_pos;
+			]) ctx.com.basic.tvoid null_pos in
+			if DynArray.empty cases then
+				(vcaught,default)
+			else begin
+				let switch = {
+					switch_subject = estate;
+					switch_cases = DynArray.to_list cases;
+					switch_default = Some default;
+					switch_exhaustive = true
+				} in
+				let e = mk (TSwitch switch) com.basic.tvoid null_pos in
+				(vcaught,e)
+			end
+		]
+	)) com.basic.tvoid null_pos in
+
+	let eloop = mk (TWhile (make_bool com.basic true p, etry, DoWhile)) 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; etry]) com.basic.tvoid null_pos
+		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 !init_state 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,Some (Texpr.Builder.default_value v.v_type v.v_pos))) com.basic.tvoid null_pos) decls in
-	let shared_vars = List.rev (excstate_var :: state_var :: shared_vars) in
+	let shared_vars = List.rev (state_var :: shared_vars) in
 	let shared_vars = match ctx.vthis with
 		| None ->
 			shared_vars

src/coro/coroTypes.ml

@@ -5,6 +5,7 @@ type coro_block = {
 	cb_id : int;
 	cb_el : texpr DynArray.t;
 	cb_typepos : (Type.t * pos) option;
+	cb_catch : coro_block option;
 	mutable cb_next : coro_next;
 }
 
@@ -18,7 +19,7 @@ and coro_next_kind =
 	| NextIfThenElse of texpr * coro_block * coro_block * coro_block
 	| NextSwitch of coro_switch * coro_block
 	| NextWhile of texpr * coro_block * coro_block
-	| NextTry of coro_block * (tvar * coro_block) list * coro_block
+	| NextTry of coro_block * coro_catch * coro_block
 	| NextSuspend of coro_suspend * coro_block
 	(* graph connections from here on, careful with traversal *)
 	| NextBreak of coro_block
@@ -33,6 +34,11 @@ and coro_switch = {
 	cs_exhaustive : bool;
 }
 
+and coro_catch = {
+	cc_cb : coro_block;
+	cc_catches : (tvar * coro_block) list;
+}
+
 and coro_suspend = {
 	cs_fun : texpr;
 	cs_args : texpr list;
@@ -51,4 +57,5 @@ type coro_ctx = {
 	mutable vthis : tvar option;
 	mutable next_block_id : int;
 	mutable cb_unreachable : coro_block;
+	mutable current_catch : coro_block option;
 }

src/generators/genhl.ml

@@ -472,6 +472,16 @@ let rec to_type ?tref ctx t =
 			| ["hl"], "I64" -> HI64
 			| ["hl"], "NativeArray" -> HArray
 			| ["haxe";"macro"], "Position" -> HAbstract ("macro_pos", alloc_string ctx "macro_pos")
+			| ["haxe";"coro"], "Coroutine" ->
+				begin match pl with
+				| [TFun(args,ret)] ->
+					let tcontinuation = tfun [ret; t_dynamic] ctx.com.basic.tvoid in
+					let args = args @ [("",false,tcontinuation)] in
+					let ret = tfun [t_dynamic; t_dynamic] ctx.com.basic.tvoid in
+					to_type ctx (TFun(args,ret))
+				| _ ->
+					die "" __LOC__
+				end
 			| _ -> failwith ("Unknown core type " ^ s_type_path a.a_path))
 		else
 			get_rec_cache ctx t

tests/misc/coroutines/build-hl.hxml

@@ -0,0 +1,3 @@
+build-base.hxml
+--hl test.hl
+--cmd hl test.hl

tests/misc/coroutines/src/yield/TestYieldTryCatch.hx

@@ -72,8 +72,6 @@ class TestYieldTryCatch extends BaseCase {
 		dummy += '8';
 	}
 
-	#if broken
-
 	public function testTryCatch_nested() {
 		assert([10], tryCatch_nested(1));
 		Assert.equals('124569', dummy);
@@ -104,6 +102,8 @@ class TestYieldTryCatch extends BaseCase {
 		dummy += '9';
 	}
 
+	#if broken
+
 	public function testTryCatch_withoutYield_runInSingleState() {
 		assert([10], tryCatchNoYield(true));
 	}