give blocks IDs and track fall-through connections

src/coro/coro.ml

@@ -7,7 +7,7 @@ let fun_to_coro ctx e tf =
 	let p = e.epos in
 	let v_result = alloc_var VGenerated "_hx_result" t_dynamic p in
 	let v_error = alloc_var VGenerated "_hx_error" t_dynamic p in
-	let cb_root = make_block (Some(e.etype,p)) in
+	let cb_root = make_block ctx (Some(e.etype,p)) in
 	ignore(CoroFromTexpr.expr_to_coro ctx (v_result,v_error) cb_root tf.tf_expr);
 	let ret_type = if ExtType.is_void (follow tf.tf_type) then t_dynamic else tf.tf_type in
 	let vcontinuation = alloc_var VGenerated "_hx_continuation" (tfun [ret_type; t_dynamic] ctx.com.basic.tvoid) p in
@@ -22,9 +22,13 @@ let fun_to_coro ctx e tf =
 	if ctx.coro_debug then print_endline ("AFTER:\n" ^ (s_expr_debug e));
 	e
 
-let create_coro_context com meta = {
-	com;
-	coro_debug = Meta.has (Meta.Custom ":coroutine.debug") meta;
-	vthis = None;
-	cb_unreachable = make_block None;
-}
+let create_coro_context com meta =
+	let ctx = {
+		com;
+		coro_debug = Meta.has (Meta.Custom ":coroutine.debug") meta;
+		vthis = None;
+		next_block_id = 0;
+		cb_unreachable = Obj.magic "";
+	} in
+	ctx.cb_unreachable <- make_block ctx None;
+	ctx

src/coro/coroDebug.ml

@@ -5,25 +5,22 @@ open Type
 let create_dotgraph path cb =
 	print_endline (String.concat "." path);
 	let ch,close = DotGraph.start_graph path "coro" in
-	let i = ref 0 in
 	let pctx = print_context() in
 	let st = s_type pctx in
 	let se = s_expr_pretty true "" false st in
 	let edges = DynArray.create () in
 	let rec block cb =
-		let cb_id = !i in
 		let edge_block label cb_target =
-			let target_id = block cb_target in
-			DynArray.add edges (cb_id,target_id,label);
+			block cb_target;
+			DynArray.add edges (cb.cb_id,cb_target.cb_id,label);
 		in
-		incr i;
 		let s = String.concat "\n" (DynArray.to_list (DynArray.map se cb.cb_el)) in
 		let snext = match cb.cb_next.next_kind with
 			| NextUnknown ->
 				None
 			| NextSub(cb_sub,cb_next) ->
-				edge_block "sub" cb_sub;
 				edge_block "next" cb_next;
+				edge_block "sub" cb_sub;
 				None
 			| NextBreak ->
 				Some "break"
@@ -36,35 +33,38 @@ let create_dotgraph path cb =
 			| NextThrow e ->
 				Some ("throw " ^ se e)
 			| NextIfThen(e,cb_then,cb_next) ->
-				edge_block "then" cb_then;
 				edge_block "next" cb_next;
+				edge_block "then" cb_then;
 				Some ("if " ^ se e)
 			| NextIfThenElse(e,cb_then,cb_else,cb_next) ->
+				edge_block "next" cb_next;
 				edge_block "then" cb_then;
 				edge_block "else" cb_else;
-				edge_block "next" cb_next;
 				Some ("if " ^ se e)
 			| NextSwitch(switch,cb_next) ->
+				edge_block "next" cb_next;
 				List.iter (fun (el,cb_case) ->
 					edge_block (String.concat " | " (List.map se el)) cb_case
 				) switch.cs_cases;
-				edge_block "next" cb_next;
 				Option.may (fun cb_default -> edge_block "default" cb_default) switch.cs_default;
 				Some ("switch " ^ se switch.cs_subject)
 			| NextWhile(e,cb_body,cb_next) ->
-				edge_block "body" cb_body;
 				edge_block "next" cb_next;
+				edge_block "body" cb_body;
 				Some ("while " ^ se e)
 			| NextTry(cb_try,catches,cb_next) ->
+				edge_block "next" cb_next;
 				edge_block "try" cb_try;
 				List.iter (fun (v,cb_catch) ->
 					edge_block (st v.v_type) cb_catch
 				) catches;
-				edge_block "next" cb_next;
 				None
 			| NextSuspend(suspend,cb_next) ->
 				edge_block "next" cb_next;
 				Some (Printf.sprintf "%s(%s)" (se suspend.cs_fun) (String.concat ", " (List.map se suspend.cs_args)))
+			| NextFallThrough cb_next ->
+				DynArray.add edges (cb.cb_id,cb_next.cb_id,"fall-through");
+				None
 		in
 		let s = match snext with
 			| None ->
@@ -72,8 +72,7 @@ let create_dotgraph path cb =
 			| Some snext ->
 				if s = "" then snext else s ^ "\n" ^ snext
 		in
-		Printf.fprintf ch "n%i [shape=box,label=\"%s\"];\n" cb_id (StringHelper.s_escape s);
-		cb_id
+		Printf.fprintf ch "n%i [shape=box,label=\"%s\"];\n" cb.cb_id (StringHelper.s_escape s);
 	in
 	ignore(block cb);
 	DynArray.iter (fun (id_from,id_to,label) ->

src/coro/coroFromTexpr.ml

@@ -25,6 +25,9 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 			cur
 		)
 	in
+	let make_block typepos =
+		make_block ctx typepos
+	in
 	let block_from_e e =
 		make_block (Some(e.etype,e.epos))
 	in
@@ -32,6 +35,9 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 		if cb.cb_next.next_kind = NextUnknown && e != e_no_value && cb != ctx.cb_unreachable then
 			DynArray.add cb.cb_el e
 	in
+	let fall_through cb_from cb_to =
+		terminate cb_from (NextFallThrough cb_to) t_dynamic null_pos
+	in
 	let replace_this e =
 		let v = match ctx.vthis with
 			| Some v ->
@@ -61,6 +67,7 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 			let cb_sub = block_from_e e in
 			let cb_sub_next,e1 = loop_block cb_sub ret e in
 			let cb_next = make_block None in
+			fall_through cb_sub_next cb_next;
 			terminate cb (NextSub(cb_sub,cb_next)) e.etype e.epos;
 			cb_next,e1
 		| TArray(e1,e2) ->
@@ -180,25 +187,30 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 		| TIf(e1,e2,None) ->
 			let cb,e1 = loop cb RValue e1 in
 			let cb_then = block_from_e e2 in
-			let _ = loop_block cb_then RBlock e2 in
+			let cb_then_next,_ = loop_block cb_then RBlock e2 in
 			let cb_next = make_block None in
+			fall_through cb_then_next cb_next;
 			terminate cb (NextIfThen(e1,cb_then,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TIf(e1,e2,Some e3) ->
 			let cb,e1 = loop cb RValue e1 in
 			let cb_then = block_from_e e2 in
-			let _ = loop_block cb_then ret e2 in
+			let cb_then_next,_ = loop_block cb_then ret e2 in
 			let cb_else = block_from_e e3 in
-			let _ = loop_block cb_else ret e3 in
+			let cb_else_next,_ = loop_block cb_else ret e3 in
 			let cb_next = make_block None in
+			fall_through cb_then_next cb_next;
+			fall_through cb_else_next cb_next;
 			terminate cb (NextIfThenElse(e1,cb_then,cb_else,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TSwitch switch ->
 			let e1 = switch.switch_subject in
 			let cb,e1 = loop cb RValue e1 in
+			let cb_next = make_block None in
 			let cases = List.map (fun case ->
 				let cb_case = block_from_e case.case_expr in
-				let _ = loop_block cb_case ret case.case_expr in
+				let cb_case_next,_ = loop_block cb_case ret case.case_expr in
+				fall_through cb_case_next cb_next;
 				(case.case_patterns,cb_case)
 			) switch.switch_cases in
 			let def = match switch.switch_default with
@@ -206,7 +218,8 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 					None
 				| Some e ->
 					let cb_default = block_from_e e in
-					let _ = loop_block cb_default ret e in
+					let cb_default_next,_ = loop_block cb_default ret e in
+					fall_through cb_default_next cb_next;
 					Some cb_default
 			in
 			let switch = {
@@ -215,7 +228,6 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 				cs_default = def;
 				cs_exhaustive = switch.switch_exhaustive
 			} in
-			let cb_next = make_block None in
 			terminate cb (NextSwitch(switch,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TWhile(e1,e2,flag) (* always while(true) *) ->
@@ -226,13 +238,15 @@ let expr_to_coro ctx (vresult,verror) cb_root e =
 			cb_next,e_no_value
 		| TTry(e1,catches) ->
 			let cb_try = block_from_e e1 in
-			let _ = loop_block cb_try ret 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 _ = loop_block cb_catch ret 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
-			let cb_next = make_block None in
 			terminate cb (NextTry(cb_try,catches,cb_next)) e.etype e.epos;
 			cb_next,e_no_value
 		| TFunction tf ->

src/coro/coroFunctions.ml

@@ -2,8 +2,12 @@ open Globals
 open Type
 open CoroTypes
 
-let make_block typepos = {
-	cb_el = DynArray.create ();
-	cb_typepos = typepos;
-	cb_next = {next_kind = NextUnknown; next_type = t_dynamic; next_pos = null_pos};
-}
+let make_block ctx typepos =
+	let id = ctx.next_block_id in
+	ctx.next_block_id <- ctx.next_block_id + 1;
+	{
+		cb_id = id;
+		cb_el = DynArray.create ();
+		cb_typepos = typepos;
+		cb_next = {next_kind = NextUnknown; next_type = t_dynamic; next_pos = null_pos};
+	}

src/coro/coroToTexpr.ml

@@ -118,7 +118,7 @@ let block_to_texpr_coroutine ctx bb vcontinuation vresult verror p =
 		| NextUnknown when back_state_id = (-1) ->
 			let ecallcontinuation = mk_continuation_call (make_null t_dynamic p) p in
 			add_state (Some (-1)) [ecallcontinuation; ereturn]
-		| NextUnknown ->
+		| NextUnknown | NextFallThrough _ ->
 			add_state (Some back_state_id) []
 		| NextBreak ->
 			let _,next_state_id = Option.get while_loop in

src/coro/coroTypes.ml

@@ -3,6 +3,7 @@ open Globals
 open Type
 
 type coro_block = {
+	cb_id : int;
 	cb_el : texpr DynArray.t;
 	cb_typepos : (Type.t * pos) option;
 	mutable cb_next : coro_next;
@@ -22,6 +23,8 @@ and coro_next_kind =
 	| NextWhile of texpr * coro_block * coro_block
 	| NextTry of coro_block * (tvar * coro_block) list * coro_block
 	| NextSuspend of coro_suspend * coro_block
+	(* graph connections from here on, careful with traversal *)
+	| NextFallThrough of coro_block
 
 and coro_switch = {
 	cs_subject : texpr;
@@ -46,5 +49,6 @@ type coro_ctx = {
 	com : Common.context;
 	coro_debug : bool;
 	mutable vthis : tvar option;
-	cb_unreachable : coro_block;
+	mutable next_block_id : int;
+	mutable cb_unreachable : coro_block;
 }