[eval] Support threads when debugging (#7991)

* [eval] add externs for the thread API

* [eval] implement eval.vm.Mutex

* [eval] add Lock and Tls

* [eval] add Deque

* kind of works

* fixes

* fix some mutexes

* fence

* submodules

* reduce diff

* run threads tests only on travis

* kinda support timeout on lock wait

* remove TODO comments because this is probably fine

* clean up your maps

* add a name to threads

* make socket thread-safe

* add getThreads wip

* broken

The way we process messages isn't really compatible with threads. Basically, whichever thread reads the message first is going to win. We would need a more elaborate system, with a message reader in a separate thread that talks to the other threads.

* kind of works

* fixes

* add pause support

* bring back step

* track caught-types per-thread

* make more stuff per-thread

* more fixes

* don't raise BreakHere if we're not debugging

* remove socket mutex because we have a distinct thread for this now

* actually, we need a send mutex because other threads can send events

* cleanup and fix configuration handling

* make reference handling more thread-safe

src/core/socket.ml

@@ -4,6 +4,7 @@ type t = {
 	addr : Unix.inet_addr;
 	port : int;
 	mutable socket : Unix.file_descr option;
+	send_mutex : Mutex.t;
 }
 
 let create host port =
@@ -14,6 +15,7 @@ let create host port =
 		addr = host;
 		port = port;
 		socket = Some socket;
+		send_mutex = Mutex.create();
 	}
 
 let read_byte this i = int_of_char (Bytes.get this i)
@@ -54,4 +56,8 @@ let send_string socket s =
 				loop (length - k) (offset + k)
 			end
 		in
-		loop l 0
+		loop l 0
+
+let send_string socket s =
+	Mutex.lock socket.send_mutex;
+	Std.finally (fun () -> Mutex.unlock socket.send_mutex) (send_string socket) s

src/macro/eval/evalContext.ml

@@ -96,18 +96,43 @@ type env = {
 	mutable env_extra_locals : value IntMap.t;
 	(* The parent of the current environment, if exists. All environments except EKToplevel have a parent. *)
 	env_parent : env option;
+	env_eval : eval;
 }
 
-type breakpoint_state =
+and eval = {
+	mutable env : env;
+	thread : vthread;
+	(* The threads current debug state *)
+	mutable debug_state : debug_state;
+	(* The currently active breakpoint. Set to a dummy value initially. *)
+	mutable breakpoint : breakpoint;
+	(* Map of all types that are currently being caught. Updated by `emit_try`. *)
+	caught_types : (int,bool) Hashtbl.t;
+	(* The most recently caught exception. Used by `debug_loop` to avoid getting stuck. *)
+	mutable caught_exception : value;
+	(* The value which was last returned. *)
+	mutable last_return : value option;
+	(* The debug channel used to synchronize with the debugger. *)
+	debug_channel : unit Event.channel;
+}
+
+and debug_state =
+	| DbgRunning
+	| DbgWaiting
+	| DbgStep
+	| DbgNext of env * pos
+	| DbgFinish of env (* parent env *)
+
+and breakpoint_state =
 	| BPEnabled
 	| BPDisabled
 	| BPHit
 
-type breakpoint_column =
+and breakpoint_column =
 	| BPAny
 	| BPColumn of int
 
-type breakpoint = {
+and breakpoint = {
 	bpid : int;
 	bpfile : int;
 	bpline : int;
@@ -121,14 +146,6 @@ type function_breakpoint = {
 	mutable fbpstate : breakpoint_state;
 }
 
-type debug_state =
-	| DbgStart
-	| DbgRunning
-	| DbgWaiting
-	| DbgContinue
-	| DbgNext of env * pos
-	| DbgFinish of env (* parent env *)
-
 type builtins = {
 	mutable instance_builtins : (int * value) list IntMap.t;
 	mutable static_builtins : (int * value) list IntMap.t;
@@ -142,11 +159,13 @@ type debug_scope_info = {
 }
 
 type context_reference =
+	| StackFrame of env
 	| Scope of scope * env
 	| CaptureScope of (int,var_info) Hashtbl.t * env
 	| DebugScope of debug_scope_info * env
 	| Value of value * env
 	| Toplevel
+	| NoSuchReference
 
 class eval_debug_context = object(self)
 	val lut =
@@ -154,24 +173,32 @@ class eval_debug_context = object(self)
 		DynArray.add d Toplevel;
 		d
 
+	val mutex = Mutex.create()
+
+	method private add reference =
+		Mutex.lock mutex;
+		DynArray.add lut reference;
+		let i = DynArray.length lut - 1 in
+		Mutex.unlock mutex;
+		i
+
+	method add_stack_frame env =
+		self#add (StackFrame env)
+
 	method add_scope scope env =
-		DynArray.add lut (Scope(scope,env));
-		DynArray.length lut - 1
+		self#add (Scope(scope,env))
 
 	method add_capture_scope h env =
-		DynArray.add lut (CaptureScope(h,env));
-		DynArray.length lut - 1
+		self#add (CaptureScope(h,env))
 
 	method add_value v env =
-		DynArray.add lut (Value(v,env));
-		DynArray.length lut - 1
+		self#add (Value(v,env))
 
 	method add_debug_scope scope env =
-		DynArray.add lut (DebugScope(scope,env));
-		DynArray.length lut - 1
+		self#add (DebugScope(scope,env))
 
 	method get id =
-		DynArray.get lut id
+		try DynArray.get lut id with _ -> NoSuchReference
 
 end
 
@@ -181,9 +208,9 @@ type exception_mode =
 	| CatchNone
 
 type debug_connection = {
-	wait : context -> (env -> value) -> env -> value;
-	bp_stop : context -> env -> unit;
-	exc_stop : context -> value -> pos -> unit;
+	bp_stop : debug -> unit;
+	exc_stop : debug -> value -> pos -> unit;
+	send_thread_event : int -> string -> unit;
 }
 
 and debug_socket = {
@@ -200,29 +227,14 @@ and debug = {
 	(* Whether or not debugging is supported. Has various effects on the amount of
 	   data being retained at run-time. *)
 	mutable support_debugger : bool;
-	(* The current debug state. Managed by the debugger. *)
-	mutable debug_state : debug_state;
-	(* The currently active breakpoint. Set to a dummy value initially. *)
-	mutable breakpoint : breakpoint;
-	(* Map of all types that are currently being caught. Updated by `emit_try`. *)
-	caught_types : (int,bool) Hashtbl.t;
 	(* The debugger socket *)
 	mutable debug_socket : debug_socket option;
 	(* The current exception mode *)
 	mutable exception_mode : exception_mode;
-	(* The most recently caught exception. Used by `debug_loop` to avoid getting stuck. *)
-	mutable caught_exception : value;
-	(* The value which was last returned. *)
-	mutable last_return : value option;
 	(* The debug context which manages scopes and variables. *)
 	mutable debug_context : eval_debug_context;
 }
 
-and eval = {
-	mutable env : env;
-	thread : vthread;
-}
-
 and context = {
 	ctx_id : int;
 	is_macro : bool;
@@ -253,6 +265,13 @@ let get_ctx_ref : (unit -> context) ref = ref (fun() -> assert false)
 let get_ctx () = (!get_ctx_ref)()
 let select ctx = get_ctx_ref := (fun() -> ctx)
 
+let s_debug_state = function
+	| DbgRunning -> "DbgRunning"
+	| DbgWaiting -> "DbgWaiting"
+	| DbgStep -> "DbgStep"
+	| DbgNext _ -> "DbgNext"
+	| DbgFinish _ -> "DbgFinish"
+
 (* Misc *)
 
 let get_eval ctx =
@@ -299,8 +318,7 @@ let proto_fields proto =
 
 exception RunTimeException of value * env list * pos
 
-let call_stack ctx =
-	let eval = get_eval ctx in
+let call_stack eval =
 	let rec loop acc env =
 		let acc = env :: acc in
 		match env.env_parent with
@@ -315,7 +333,7 @@ let throw v p =
 	let env = eval.env in
 	env.env_leave_pmin <- p.pmin;
 	env.env_leave_pmax <- p.pmax;
-	raise_notrace (RunTimeException(v,call_stack ctx,p))
+	raise_notrace (RunTimeException(v,call_stack eval,p))
 
 let exc v = throw v null_pos
 
@@ -355,6 +373,7 @@ let null_env = {
 	env_captures = [||];
 	env_extra_locals = IntMap.empty;
 	env_parent = None;
+	env_eval = Obj.magic ();
 }
 
 let create_env_info static pfile kind capture_infos =
@@ -398,6 +417,7 @@ let push_environment ctx info num_locals num_captures =
 		env_captures = captures;
 		env_extra_locals = IntMap.empty;
 		env_parent = Some eval.env;
+		env_eval = eval;
 	} in
 	eval.env <- env;
 	begin match ctx.debug.debug_socket,env.env_info.kind with
@@ -405,8 +425,8 @@ let push_environment ctx info num_locals num_captures =
 			begin try
 				let bp = Hashtbl.find ctx.debug.function_breakpoints (key_type,key_field) in
 				if bp.fbpstate <> BPEnabled then raise Not_found;
-				socket.connection.bp_stop ctx env;
-				ctx.debug.debug_state <- DbgWaiting;
+				socket.connection.bp_stop ctx.debug;
+				eval.debug_state <- DbgWaiting;
 			with Not_found ->
 				()
 			end
@@ -416,7 +436,7 @@ let push_environment ctx info num_locals num_captures =
 	env
 
 let pop_environment ctx env =
-	let eval = get_eval ctx in
+	let eval = env.env_eval in
 	begin match env.env_parent with
 		| Some env -> eval.env <- env
 		| None -> assert false

src/macro/eval/evalDebug.ml

@@ -13,25 +13,23 @@ open EvalMisc
 open EvalDebugMisc
 open MacroApi
 
-let is_caught ctx v =
+let is_caught eval v =
 	try
-		Hashtbl.iter (fun path _ -> if is v path then raise Exit) ctx.debug.caught_types;
+		Hashtbl.iter (fun path _ -> if is v path then raise Exit) eval.caught_types;
 		false
 	with Exit ->
 		true
 
 (* Checks debug state and calls what's needed. *)
-let rec run_loop ctx wait run env : value =
+let rec run_loop run env : value =
+	let eval = env.env_eval in
 	let check_breakpoint () =
-		if ctx.debug.breakpoint.bpstate = BPHit && env.env_debug.line <> ctx.debug.breakpoint.bpline then ctx.debug.breakpoint.bpstate <- BPEnabled
+		if eval.breakpoint.bpstate = BPHit && env.env_debug.line <> eval.breakpoint.bpline then eval.breakpoint.bpstate <- BPEnabled
 	in
-	match ctx.debug.debug_state with
+	match eval.debug_state with
 		| DbgRunning ->
 			check_breakpoint();
 			run env
-		| DbgContinue ->
-			check_breakpoint();
-			run env
 		| DbgNext(env',p) ->
 			let b = DisplayPosition.encloses_position (env.env_debug.expr.epos) p in
 			let rec is_on_stack env =
@@ -42,18 +40,22 @@ let rec run_loop ctx wait run env : value =
 			if is_on_stack env || b then
 				run env
 			else begin
-				ctx.debug.debug_state <- DbgWaiting;
-				run_loop ctx wait run env
+				eval.debug_state <- DbgWaiting;
+				run_loop run env
 			end;
 		| DbgFinish env' ->
 			if env' != env then
 				run env
 			else begin
-				ctx.debug.debug_state <- DbgWaiting;
-				run_loop ctx wait run env
+				eval.debug_state <- DbgWaiting;
+				run_loop run env
 			end
-		| DbgWaiting | DbgStart ->
-			wait ctx run env
+		| DbgStep ->
+			eval.debug_state <- DbgWaiting;
+			run env
+		| DbgWaiting ->
+			ignore(Event.sync(Event.receive eval.debug_channel));
+			run_loop run env
 
 let debug_loop jit conn e f =
 	let ctx = jit.ctx in
@@ -65,44 +67,45 @@ let debug_loop jit conn e f =
 	in
 	let condition_holds env breakpoint = match breakpoint.bpcondition with
 		| None -> true
-		| Some e -> match expr_to_value_safe ctx env e with
+		| Some e -> match safe_call env.env_eval (expr_to_value_safe ctx env) e with
 			| VTrue -> true
 			| _ -> false
 	in
-	let debugger_catches v = match ctx.debug.exception_mode with
+	let debugger_catches eval v = match ctx.debug.exception_mode with
 		| CatchAll -> true
-		| CatchUncaught -> not (is_caught ctx v)
+		| CatchUncaught -> not (is_caught eval v)
 		| CatchNone -> false
 	in
 	(* Checks if we hit a breakpoint, runs the code if not. *)
 	let rec run_check_breakpoint env =
+		let eval = env.env_eval in
 		try
 			let h = Hashtbl.find ctx.debug.breakpoints env.env_info.pfile_unique in
 			let breakpoint = Hashtbl.find h env.env_debug.line in
 			begin match breakpoint.bpstate with
 				| BPEnabled when column_matches breakpoint && condition_holds env breakpoint ->
 					breakpoint.bpstate <- BPHit;
-					ctx.debug.breakpoint <- breakpoint;
-					conn.bp_stop ctx env;
-					ctx.debug.debug_state <- DbgWaiting;
-					run_loop ctx conn.wait run_check_breakpoint env
+					eval.breakpoint <- breakpoint; (* TODO: per-thread... *)
+					conn.bp_stop ctx.debug;
+					eval.debug_state <- DbgWaiting;
+					run_loop run_check_breakpoint env
 				| _ ->
 					raise Not_found
 			end
 		with Not_found -> try
 			f env
 		with
-		| RunTimeException(v,_,_) when debugger_catches v && ctx.debug.caught_exception != v ->
-			ctx.debug.caught_exception <- v;
-			conn.exc_stop ctx v e.epos;
-			ctx.debug.debug_state <- DbgWaiting;
-			run_loop ctx conn.wait run_check_breakpoint env
+		| RunTimeException(v,_,_) when debugger_catches env.env_eval v && eval.caught_exception != v ->
+			eval.caught_exception <- v;
+			conn.exc_stop ctx.debug v e.epos;
+			eval.debug_state <- DbgWaiting;
+			run_loop run_check_breakpoint env
 		| BreakHere ->
-			conn.bp_stop ctx env;
-			ctx.debug.debug_state <- DbgWaiting;
-			run_loop ctx conn.wait run_check_breakpoint env
+			conn.bp_stop ctx.debug;
+			eval.debug_state <- DbgWaiting;
+			run_loop (fun _ -> vnull) env
 		| Return v as exc ->
-			ctx.debug.last_return <- Some v;
+			eval.last_return <- Some v;
 			raise exc
 		(* | Return _ | Break | Continue | Sys_exit _ | RunTimeException _ as exc ->
 			raise exc
@@ -114,6 +117,6 @@ let debug_loop jit conn e f =
 		env.env_debug.scopes <- scopes;
 		env.env_debug.line <- line;
 		env.env_debug.expr <- e;
-		run_loop ctx conn.wait run_check_breakpoint env;
+		run_loop run_check_breakpoint env;
 	in
 	run_set

src/macro/eval/evalDebugMisc.ml

@@ -146,7 +146,9 @@ let resolve_ident ctx env s =
 					| Some env -> loop env
 				end
 			| EKMethod _ -> env
-			| EKToplevel | EKEntrypoint -> assert false
+			| EKToplevel | EKEntrypoint ->
+				(* This can happen due to threads. Have to check what we can do here... *)
+				raise Not_found
 		in
 		let env = loop env in
 		let v = env.env_locals.(0) in
@@ -184,15 +186,15 @@ let find_enum_field_by_name ve name =
 	| _ ->
 		raise Not_found
 
-let safe_call ctx f a =
-	let old = ctx.debug.debug_state in
-	ctx.debug.debug_state <- DbgContinue;
+let safe_call eval f a =
+	let old = eval.debug_state in
+	eval.debug_state <- DbgRunning;
 	try
 		let r = f a in
-		ctx.debug.debug_state <- old;
+		eval.debug_state <- old;
 		r
 	with exc ->
-		ctx.debug.debug_state <- old;
+		eval.debug_state <- old;
 		raise exc
 
 let rec expr_to_value ctx env e =
@@ -285,11 +287,11 @@ let rec expr_to_value ctx env e =
 				let vthis = loop ethis in
 				let v1 = EvalField.field vthis (hash s) in
 				let vl = List.map loop el in
-				safe_call ctx (EvalPrinting.call_value_on vthis v1) vl
+				safe_call env.env_eval (EvalPrinting.call_value_on vthis v1) vl
 			| _ ->
 				let v1 = loop e1 in
 				let vl = List.map loop el in
-				safe_call ctx (call_value v1) vl
+				safe_call env.env_eval (call_value v1) vl
 			end
 		| EBlock el ->
 			let rec loop2 el = match el with
@@ -348,7 +350,7 @@ let rec expr_to_value ctx env e =
 			let v1 = loop2 v1 [match tp.tsub with None -> tp.tname | Some s -> s] in
 			let vl = List.map loop el in
 			let vc = loop2 ctx.toplevel ["Type";"createInstance"] in
-			safe_call ctx (call_value vc) [v1;encode_array vl]
+			safe_call env.env_eval (call_value vc) [v1;encode_array vl]
 		| ETry _ | ESwitch _ | EFunction _ | EFor _ | EDisplay _
 		| EDisplayNew _ | ECast(_,Some _) ->
 			raise Exit

src/macro/eval/evalDebugSocket.ml

@@ -95,7 +95,7 @@ let var_to_json name value vio env =
 		| VArray va -> jv "Array" (array_elems (EvalArray.to_list va)) va.alength
 		| VVector vv -> jv "Vector" (array_elems (Array.to_list vv)) (Array.length vv)
 		| VInstance vi ->
-			let class_name = EvalDebugMisc.safe_call (get_ctx()) EvalPrinting.value_string v in
+			let class_name = EvalDebugMisc.safe_call env.env_eval EvalPrinting.value_string v in
 			let fields = instance_fields vi in
 			jv class_name (class_name) (List.length fields)
 		| VPrototype proto ->
@@ -106,32 +106,29 @@ let var_to_json name value vio env =
 	in
 	value_string value
 
-let get_call_stack_envs ctx kind p =
-	let envs = match call_stack ctx with
-		| _ :: envs -> envs
-		| [] -> []
-	in
+let get_call_stack_envs eval p =
+	let envs = call_stack eval in
 	let rec loop delta envs = match envs with
 		| _ :: envs when delta < 0 -> loop (delta + 1) envs
 		| _ -> envs
 	in
 	loop 0 envs
 
-let output_call_stack ctx kind p =
-	let envs = get_call_stack_envs ctx kind p in
-	let id = ref (-1) in
-	let stack_item kind p =
-		incr id;
+let output_call_stack ctx eval p =
+	let envs = get_call_stack_envs eval p in
+	let stack_item env p =
+		let id = ctx.debug.debug_context#add_stack_frame env in
+		let kind = env.env_info.kind in
 		let line1,col1,line2,col2 = Lexer.get_pos_coords p in
 		let path = Path.get_real_path p.pfile in
 		let artificial,name = match kind with
-			| EKMethod _ | EKLocalFunction _ -> false,kind_name (get_eval ctx) kind
+			| EKMethod _ | EKLocalFunction _ -> false,kind_name eval kind
 			| EKEntrypoint -> true,p.pfile
-			| EKToplevel -> true,kind_name (get_eval ctx) kind
+			| EKToplevel -> true,kind_name eval kind
 		in
 		let source = if Sys.file_exists path then JString path else JNull in
 		JObject [
-			"id",JInt !id;
+			"id",JInt id;
 			"name",JString name;
 			"source",source;
 			"line",JInt line1;
@@ -141,13 +138,22 @@ let output_call_stack ctx kind p =
 			"artificial",JBool artificial;
 		]
 	in
-	let l = [stack_item kind p] in
-	let stack = List.fold_left (fun acc env ->
-		let p = {pmin = env.env_leave_pmin; pmax = env.env_leave_pmax; pfile = rev_hash env.env_info.pfile} in
-		(stack_item env.env_info.kind p) :: acc
-	) l envs in
+	let _,stack = List.fold_left (fun (first,acc) env ->
+		let p = if first then p else {pmin = env.env_leave_pmin; pmax = env.env_leave_pmax; pfile = rev_hash env.env_info.pfile} in
+		false,((stack_item env p) :: acc)
+	) (true,[]) envs in
 	JArray (List.rev stack)
 
+let output_threads ctx =
+	let fold id eval acc =
+		(JObject [
+			"id",JInt id;
+			"name",JString eval.thread.tname
+		]) :: acc
+	in
+	let threads = IntMap.fold fold ctx.evals [] in
+	JArray threads
+
 let is_simn = false
 
 let output_scopes ctx env =
@@ -181,7 +187,7 @@ let output_scopes ctx env =
 	else begin
 		let dbg = {
 			ds_expr = env.env_debug.expr;
-			ds_return = ctx.debug.last_return;
+			ds_return = env.env_eval.last_return;
 		} in
 		(mk_scope (ctx.debug.debug_context#add_debug_scope dbg env) "Eval" null_pos) :: scopes
 	end in
@@ -278,11 +284,6 @@ let output_inner_vars v env =
 	let vars = List.map (fun (n,v) -> var_to_json n v None env) children in
 	JArray vars
 
-type command_outcome =
-	| Loop of Json.t
-	| Run of Json.t * EvalContext.env
-	| Wait of Json.t * EvalContext.env
-
 module ValueCompletion = struct
 	let prototype_instance_fields proto =
 		let rec loop acc proto =
@@ -445,7 +446,7 @@ module ValueCompletion = struct
 				raise Exit
 			with
 			| JsonException json ->
-				Loop (json)
+				json
 			end
 		with _ ->
 			save();
@@ -457,14 +458,10 @@ end
 type handler_context = {
 	ctx : context;
 	jsonrpc : Jsonrpc_handler.jsonrpc_handler;
-	env : env;
 	send_error : 'a . string -> 'a;
 }
 
 let handler =
-	let get_real_env ctx =
-		(get_eval ctx).env
-	in
 	let parse_breakpoint hctx jo =
 		let j = hctx.jsonrpc in
 		let obj = j#get_object "breakpoint" jo in
@@ -472,56 +469,69 @@ let handler =
 		let column = j#get_opt_param (fun () -> BPColumn (j#get_int_field "column" "column" obj)) BPAny in
 		let condition = j#get_opt_param (fun () ->
 			let s = j#get_string_field "condition" "condition" obj in
-			Some (parse_expr hctx.ctx s hctx.env.env_debug.expr.epos)
+			let env = hctx.ctx.eval.env in (* Use the main env, we only care about the position anyway *)
+			Some (parse_expr hctx.ctx s env.env_debug.expr.epos)
 		) None in
 		(line,column,condition)
 	in
-	let rec move_frame hctx offset =
-		let eval = get_eval hctx.ctx in
-		let rec loop env i =
-			if i = 0 then env
-			else match env.env_parent with
-			| None -> hctx.send_error "Frame out of bounds"
-			| Some env -> loop env (i - 1)
+	let select_frame hctx =
+		let frame_id = hctx.jsonrpc#get_int_param "frameId" in
+		let env = match hctx.ctx.debug.debug_context#get frame_id with
+			| StackFrame env -> env
+			| _ -> hctx.send_error (Printf.sprintf "Bad frame ID: %i" frame_id);
 		in
-		if offset < 0 then
-			hctx.send_error "Frame out of bounds"
-		else begin
-			loop eval.env offset
-		end
+		env
 	in
-	let update_frame hctx =
-		let frame = hctx.jsonrpc#get_int_param "frameId" in
-		move_frame hctx frame
+	let select_thread hctx =
+		let id = hctx.jsonrpc#get_opt_param (fun () -> hctx.jsonrpc#get_int_param "threadId") 0 in
+		let eval = try IntMap.find id hctx.ctx.evals with Not_found -> hctx.send_error "Invalid thread id" in
+		eval
 	in
 	let h = Hashtbl.create 0 in
 	let l = [
+		"pause",(fun hctx ->
+			let eval = select_thread hctx in
+			eval.debug_state <- DbgWaiting;
+			JNull
+		);
 		"continue",(fun hctx ->
-			let env = get_real_env hctx.ctx in
-			hctx.ctx.debug.debug_state <- (if hctx.ctx.debug.debug_state = DbgStart then DbgRunning else DbgContinue);
-			Run (JNull,env)
+			let eval = select_thread hctx in
+			eval.debug_state <- DbgRunning;
+			ignore(Event.poll (Event.send eval.debug_channel ()));
+			JNull
 		);
 		"stepIn",(fun hctx ->
-			let env = get_real_env hctx.ctx in
-			Run (JNull,env)
+			let eval = select_thread hctx in
+			eval.debug_state <- DbgStep;
+			ignore(Event.poll (Event.send eval.debug_channel ()));
+			JNull
 		);
 		"next",(fun hctx ->
-			let env = get_real_env hctx.ctx in
-			hctx.ctx.debug.debug_state <- DbgNext(env,env.env_debug.expr.epos);
-			Run (JNull,env)
+			let eval = select_thread hctx in
+			let env = eval.env in
+			eval.debug_state <- DbgNext(env,env.env_debug.expr.epos);
+			ignore(Event.poll (Event.send eval.debug_channel ()));
+			JNull
 		);
 		"stepOut",(fun hctx ->
-			let env = get_real_env hctx.ctx in
+			let eval = select_thread hctx in
+			let env = eval.env in
 			let penv = Option.get env.env_parent in
-			hctx.ctx.debug.debug_state <- DbgFinish penv;
-			Run (JNull,env)
+			eval.debug_state <- DbgFinish penv;
+			ignore(Event.poll (Event.send eval.debug_channel ()));
+			JNull
+		);
+		"getThreads",(fun hctx ->
+			output_threads hctx.ctx
 		);
 		"stackTrace",(fun hctx ->
-			Loop (output_call_stack hctx.ctx hctx.env.env_info.kind hctx.env.env_debug.expr.epos)
+			let eval = select_thread hctx in
+			let env = eval.env in
+			output_call_stack hctx.ctx eval env.env_debug.expr.epos
 		);
 		"getScopes",(fun hctx ->
-			let env = update_frame hctx in
-			Loop (output_scopes hctx.ctx env);
+			let env = select_frame hctx in
+			output_scopes hctx.ctx env
 		);
 		"getVariables",(fun hctx ->
 			let sid = hctx.jsonrpc#get_int_param "id" in
@@ -539,13 +549,13 @@ let handler =
 								output_debug_scope dbg env
 							| Value(value,env) ->
 								output_inner_vars value env
-							| Toplevel ->
-								hctx.send_error "Invalid scope id";
+							| Toplevel | StackFrame _ | NoSuchReference ->
+								hctx.send_error (Printf.sprintf "Bad ID: %i" sid);
 						end
 					with Exit ->
 						hctx.send_error "Invalid scope id"
 				in
-				Loop vars
+				vars
 			end
 		);
 		"setBreakpoints",(fun hctx ->
@@ -568,13 +578,13 @@ let handler =
 				Hashtbl.add h line bp;
 				JObject ["id",JInt bp.bpid]
 			) bps in
-			Loop (JArray bps)
+			JArray bps
 		);
 		"setBreakpoint",(fun hctx ->
 			let line,column,condition = parse_breakpoint hctx (hctx.jsonrpc#get_params) in
 			let file = hctx.jsonrpc#get_string_param "file" in
 			let breakpoint = add_breakpoint hctx.ctx file line column condition in
-			Loop (JObject ["id",JInt breakpoint.bpid])
+			JObject ["id",JInt breakpoint.bpid]
 		);
 		"setFunctionBreakpoints",(fun hctx ->
 			Hashtbl.clear hctx.ctx.debug.function_breakpoints;
@@ -591,7 +601,7 @@ let handler =
 				Hashtbl.add hctx.ctx.debug.function_breakpoints (hash key_type,hash key_field) bp;
 				JObject ["id",JInt bp.fbpid]
 			) bps in
-			Loop (JArray bps)
+			JArray bps
 		);
 		"removeBreakpoint",(fun hctx ->
 			let id = hctx.jsonrpc#get_int_param "id" in
@@ -604,23 +614,23 @@ let handler =
 			with Not_found ->
 				hctx.send_error (Printf.sprintf "Unknown breakpoint: %d" id)
 			end;
-			Loop JNull
+			JNull
 		);
 		"setVariable",(fun hctx ->
-			let env = hctx.env in
 			let id = hctx.jsonrpc#get_int_param "id" in
 			let name = hctx.jsonrpc#get_string_param "name" in
 			let value = hctx.jsonrpc#get_string_param "value" in
-			let value = try
+			let get_value env = try
 				let e = parse_expr hctx.ctx value env.env_debug.expr.epos in
 				expr_to_value hctx.ctx env e
 			with Parse_expr_error e ->
 				hctx.send_error e
 			in
 			begin match hctx.ctx.debug.debug_context#get id with
-			| Toplevel ->
-				hctx.send_error "Invalid id";
+			| Toplevel | NoSuchReference ->
+				hctx.send_error (Printf.sprintf "Bad ID: %i" id);
 			| Value(v,env) ->
+				let value = get_value env in
 				let name_as_index () = try
 					(* The name is [1] so we have to extract the number. This is quite stupid but not really our fault... *)
 					int_of_string (String.sub name 1 (String.length name - 2))
@@ -633,18 +643,20 @@ let handler =
 				| _ ->
 					set_field v (hash name) value;
 				end;
-				Loop (var_to_json "" value None env)
+				var_to_json "" value None env
 			| Scope(scope,env) ->
+				let value = get_value env in
 				let id = Hashtbl.find scope.local_ids name in
 				let slot = Hashtbl.find scope.locals id in
 				env.env_locals.(slot + scope.local_offset) <- value;
-				Loop (var_to_json "" value None env)
+				var_to_json "" value None env
 			| CaptureScope(infos,env) ->
+				let value = get_value env in
 				let slot = get_capture_slot_by_name infos name in
 				env.env_captures.(slot) := value;
-				Loop (var_to_json "" value None env)
-			| DebugScope(_,env) ->
-				Loop JNull
+				var_to_json "" value None env
+			| DebugScope _ | StackFrame _ ->
+				JNull
 			end
 		);
 		"setExceptionOptions",(fun hctx ->
@@ -653,15 +665,15 @@ let handler =
 			hctx.ctx.debug.exception_mode <- if List.mem "all" sl then CatchAll
 				else if List.mem "uncaught" sl then CatchUncaught
 				else CatchNone;
-			Loop(JNull)
+			JNull
 		);
 		"evaluate",(fun hctx ->
-			let env = update_frame hctx in
+			let env = try select_frame hctx with _ -> hctx.ctx.eval.env in
 			let s = hctx.jsonrpc#get_string_param "expr" in
 			begin try
 				let e = parse_expr hctx.ctx s env.env_debug.expr.epos in
 				let v = expr_to_value hctx.ctx env e in
-				Loop (var_to_json "" v None env)
+				var_to_json "" v None env
 			with
 			| Parse_expr_error e ->
 				hctx.send_error e
@@ -670,7 +682,7 @@ let handler =
 			end
 		);
 		"getCompletion",(fun hctx ->
-			let env = hctx.env in
+			let env = hctx.ctx.eval.env in
 			let text = hctx.jsonrpc#get_string_param "text" in
 			let column = hctx.jsonrpc#get_int_param "column" in
 			try
@@ -683,34 +695,30 @@ let handler =
 	h
 
 let make_connection socket =
-	let output_breakpoint_stop ctx _ =
-		ctx.debug.debug_context <- new eval_debug_context;
-		send_event socket "breakpointStop" None
+	let output_thread_event thread_id reason =
+		send_event socket "threadEvent" (Some (JObject ["threadId",JInt thread_id;"reason",JString reason]))
 	in
-	let output_exception_stop ctx v _ =
-		ctx.debug.debug_context <- new eval_debug_context;
-		send_event socket "exceptionStop" (Some (JObject ["text",JString (value_string v)]))
+	let output_breakpoint_stop debug =
+		(* TODO: this isn't thread-safe. We should only creates these anew if all threads continued *)
+		debug.debug_context <- new eval_debug_context;
+		send_event socket "breakpointStop" (Some (JObject ["threadId",JInt (Thread.id (Thread.self()))]))
 	in
-	let rec wait ctx (run : env -> value) env =
+	let output_exception_stop debug v _ =
+		debug.debug_context <- new eval_debug_context;
+		send_event socket "exceptionStop" (Some (JObject ["threadId",JInt (Thread.id (Thread.self()));"text",JString (value_string v)]))
+	in
+	let rec wait () : unit =
 		let rec process_outcome id outcome =
 			let output j = send_json socket (JsonRpc.result id j) in
-			match outcome with
-			| Loop result ->
-				output result;
-				loop ()
-			| Run (result,env) ->
-				output result;
-				run env
-			| Wait (result,env) ->
-				output result;
-				wait ctx run env;
+			output outcome;
+			loop ()
 		and send_output_and_continue json =
 			send_json socket json;
 			loop ()
 		and send_output_and_exit json =
 			send_json socket json;
 			raise Exit
-		and loop () : value =
+		and loop () =
 			let input = Socket.read_string socket in
 			let input =
 				JsonRpc.handle_jsonrpc_error (fun () -> JsonRpc.parse_request input) send_output_and_exit
@@ -721,9 +729,8 @@ let make_connection socket =
 				raise (JsonRpc_error (Custom (jsonrpc#get_id, 1, msg)))
 			in
 			let hctx = {
-				ctx = ctx;
+				ctx = get_ctx();
 				jsonrpc = jsonrpc;
-				env = env;
 				send_error = error;
 			} in
 			JsonRpc.handle_jsonrpc_error (fun () ->
@@ -741,8 +748,9 @@ let make_connection socket =
 		with Exit ->
 			loop ()
 	in
+	ignore(Thread.create wait ());
 	{
-		wait = wait;
 		bp_stop = output_breakpoint_stop;
 		exc_stop = output_exception_stop;
+		send_thread_event = output_thread_event;
 	}

src/macro/eval/evalEmitter.ml

@@ -202,19 +202,19 @@ let emit_do_while_break_continue exec_cond exec_body env =
 
 let emit_try exec catches env =
 	let ctx = get_ctx() in
-	let eval = get_eval ctx in
+	let eval = env.env_eval in
 	if ctx.debug.support_debugger then begin
-		List.iter (fun (_,path,_) -> Hashtbl.add ctx.debug.caught_types path true) catches
+		List.iter (fun (_,path,_) -> Hashtbl.add eval.caught_types path true) catches
 	end;
 	let restore () =
-		List.iter (fun (_,path,_) -> Hashtbl.remove ctx.debug.caught_types path) catches
+		List.iter (fun (_,path,_) -> Hashtbl.remove eval.caught_types path) catches
 	in
 	let v = try
 		let v = exec env in
 		restore();
 		v
 	with RunTimeException(v,_,_) as exc ->
-		ctx.debug.caught_exception <- vnull;
+		eval.caught_exception <- vnull;
 		restore();
 		build_exception_stack ctx env;
 		while eval.env != env do pop_environment ctx eval.env done;

src/macro/eval/evalExceptions.ml

@@ -105,7 +105,7 @@ let get_exc_error_message ctx v stack p =
 		Printf.sprintf "%s : Uncaught exception %s\n%s" (format_pos p) (value_string v) sstack
 
 let build_exception_stack ctx env =
-	let eval = get_eval ctx in
+	let eval = env.env_eval in
 	let rec loop acc env' =
 		let acc = env' :: acc in
 		if env == env' then
@@ -131,7 +131,7 @@ let catch_exceptions ctx ?(final=(fun() -> ())) f p =
 		Some v
 	with
 	| RunTimeException(v,stack,p') ->
-		ctx.debug.caught_exception <- vnull;
+		eval.caught_exception <- vnull;
 		build_exception_stack ctx env;
 		eval.env <- env;
 		if is v key_haxe_macro_Error then begin

src/macro/eval/evalMain.ml

@@ -41,6 +41,8 @@ let sid = ref (-1)
 let stdlib = ref None
 let debug = ref None
 
+let debugger_initialized = ref false
+
 let create com api is_macro =
 	let t = Timer.timer [(if is_macro then "macro" else "interp");"create"] in
 	incr sid;
@@ -87,13 +89,8 @@ let create com api is_macro =
 				breakpoints = Hashtbl.create 0;
 				function_breakpoints = Hashtbl.create 0;
 				support_debugger = support_debugger;
-				debug_state = DbgStart;
-				breakpoint = EvalDebugMisc.make_breakpoint 0 0 BPDisabled BPAny None;
-				caught_types = Hashtbl.create 0;
 				debug_socket = socket;
 				exception_mode = CatchUncaught;
-				caught_exception = vnull;
-				last_return = None;
 				debug_context = new eval_debug_context;
 			} in
 			debug := Some debug';
@@ -105,11 +102,18 @@ let create com api is_macro =
 	let eval = {
 		env = null_env;
 		thread = {
+			tname = "mainThread";
 			tthread = Thread.self();
 			tchannel = Event.new_channel();
 			tqueue = Queue.create ();
 			tstorage = IntMap.empty;
-		}
+		};
+		debug_channel = Event.new_channel ();
+		debug_state = DbgRunning;
+		breakpoint = EvalDebugMisc.make_breakpoint 0 0 BPDisabled BPAny None;
+		caught_types = Hashtbl.create 0;
+		last_return = None;
+		caught_exception = vnull;
 	} in
 	let evals = IntMap.singleton 0 eval in
 	let rec ctx = {
@@ -140,6 +144,16 @@ let create com api is_macro =
 		evals = evals;
 		exception_stack = [];
 	} in
+	if debug.support_debugger && not !debugger_initialized then begin
+		(* Let's wait till the debugger says we're good to continue. This allows it to finish configuration.
+		   Note that configuration is shared between macro and interpreter contexts, which is why the check
+		   is governed by a global variable. *)
+		debugger_initialized := true;
+		 (* There's select_ctx in the json-rpc handling, so let's select this one. It's fine because it's the
+		    first context anyway. *)
+		select ctx;
+		ignore(Event.sync(Event.receive eval.debug_channel));
+	end;
 	t();
 	ctx
 

src/macro/eval/evalStdLib.ml

@@ -556,7 +556,7 @@ module StdCallStack = struct
 
 	let getCallStack = vfun0 (fun () ->
 		let ctx = get_ctx() in
-		let envs = call_stack ctx in
+		let envs = call_stack (get_eval ctx) in
 		let envs = match envs with
 			| _ :: _ :: envs -> envs (* Skip calls to callStack() and getCallStack() *)
 			| _ -> envs
@@ -640,7 +640,8 @@ module StdContext = struct
 	)
 
 	let breakHere = vfun0 (fun () ->
-		raise (EvalDebugMisc.BreakHere)
+		if not ((get_ctx()).debug.support_debugger) then vnull
+		else raise (EvalDebugMisc.BreakHere)
 	)
 
 	let callMacroApi = vfun1 (fun f ->
@@ -3171,15 +3172,44 @@ let init_constructors builtins =
 				if ctx.is_macro then exc_string "Creating threads in macros is not supported";
 				let f thread =
 					let id = Thread.id (Thread.self()) in
-					let new_eval = {env = null_env; thread = thread} in
+					let maybe_send_thread_event reason = match ctx.debug.debug_socket with
+						| Some socket ->
+							socket.connection.send_thread_event id reason
+						| None ->
+							()
+					in
+					let new_eval = {
+						env = null_env;
+						thread = thread;
+						debug_state = DbgRunning;
+						debug_channel = Event.new_channel ();
+						breakpoint = EvalDebugMisc.make_breakpoint 0 0 BPDisabled BPAny None;
+						caught_types = Hashtbl.create 0;
+						last_return = None;
+						caught_exception = vnull;
+					} in
 					ctx.evals <- IntMap.add id new_eval ctx.evals;
+					let close () =
+						ctx.evals <- IntMap.remove id ctx.evals;
+						maybe_send_thread_event "exited";
+					in
 					try
+						maybe_send_thread_event "started";
 						ignore(call_value f []);
-					with RunTimeException(v,stack,p) ->
+						close();
+					with
+					| RunTimeException(v,stack,p) ->
 						let msg = get_exc_error_message ctx v stack p in
-						prerr_endline msg
+						prerr_endline msg;
+						close();
+					| exc ->
+						close();
+						raise exc
 				in
+				let eval = get_eval ctx in
+				let name = kind_name eval eval.env.env_info.kind in
 				let thread = {
+					tname = name;
 					tthread = Obj.magic ();
 					tchannel = Event.new_channel ();
 					tqueue = Queue.create ();

src/macro/eval/evalValue.ml

@@ -192,6 +192,7 @@ and venum_value = {
 }
 
 and vthread = {
+	tname : string;
 	mutable tthread : Thread.t;
 	tchannel : value Event.channel;
 	tqueue : value Queue.t;