[eval] move some common code to evalThread.ml

src/macro/eval/evalMain.ml

@@ -99,20 +99,12 @@ let create com api is_macro =
 			debug
 	in
 	let detail_times = Common.defined com Define.EvalTimes in
-	let eval = {
-		env = None;
-		thread = {
-			tthread = Thread.self();
-			tstorage = IntMap.empty;
-			tdeque = EvalStdLib.Deque.create();
-		};
-		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;
+	let thread = {
+		tthread = Thread.self();
+		tstorage = IntMap.empty;
+		tdeque = EvalThread.Deque.create();
 	} in
+	let eval = EvalThread.create_eval thread in
 	let evals = IntMap.singleton 0 eval in
 	let rec ctx = {
 		ctx_id = !sid;

src/macro/eval/evalStdLib.ml

@@ -28,6 +28,7 @@ open EvalMisc
 open EvalField
 open EvalHash
 open EvalString
+open EvalThread
 
 let macro_lib = Hashtbl.create 0
 
@@ -54,44 +55,6 @@ let encode_i64_direct i64 =
 	let high = Int64.to_int32 (Int64.shift_right_logical i64 32) in
 	encode_i64 low high
 
-module Deque = struct
-	let create () = {
-		dvalues = [];
-		dmutex = Mutex.create();
-	}
-
-	let add this i =
-		Mutex.lock this.dmutex;
-		this.dvalues <- this.dvalues @ [i];
-		Mutex.unlock this.dmutex
-
-	let pop this blocking =
-		let rec loop () =
-			Mutex.lock this.dmutex;
-			match this.dvalues with
-			| v :: vl ->
-				this.dvalues <- vl;
-				Mutex.unlock this.dmutex;
-				Some v
-			| [] ->
-				if not blocking then begin
-					Mutex.unlock this.dmutex;
-					None
-				end else begin
-					Mutex.unlock this.dmutex;
-					Thread.yield();
-					loop()
-				end
-		in
-		loop()
-
-	let push this i =
-		Mutex.lock this.dmutex;
-		this.dvalues <- i :: this.dvalues;
-		Mutex.unlock this.dmutex
-end
-
-
 module StdEvalVector = struct
 	let this this = match this with
 		| VVector vv -> vv
@@ -3175,51 +3138,7 @@ let init_constructors builtins =
 			| [f] ->
 				let ctx = get_ctx() in
 				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 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 = None;
-						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 []);
-						close();
-					with
-					| RunTimeException(v,stack,p) ->
-						let msg = get_exc_error_message ctx v stack p in
-						prerr_endline msg;
-						close();
-					| Sys_exit i ->
-						close();
-						exit i;
-					| exc ->
-						close();
-						raise exc
-				in
-				let thread = {
-					tthread = Obj.magic ();
-					tstorage = IntMap.empty;
-					tdeque = Deque.create();
-				} in
-				thread.tthread <- Thread.create f thread;
+				let thread = EvalThread.spawn ctx (fun () -> call_value f []) in
 				encode_instance key_sys_net_Thread ~kind:(IThread thread)
 			| _ -> assert false
 		);

src/macro/eval/evalThread.ml

@@ -0,0 +1,92 @@
+open Globals
+open EvalContext
+open EvalDebugMisc
+open EvalExceptions
+open EvalValue
+
+module Deque = struct
+	let create () = {
+		dvalues = [];
+		dmutex = Mutex.create();
+	}
+
+	let add this i =
+		Mutex.lock this.dmutex;
+		this.dvalues <- this.dvalues @ [i];
+		Mutex.unlock this.dmutex
+
+	let pop this blocking =
+		let rec loop () =
+			Mutex.lock this.dmutex;
+			match this.dvalues with
+			| v :: vl ->
+				this.dvalues <- vl;
+				Mutex.unlock this.dmutex;
+				Some v
+			| [] ->
+				if not blocking then begin
+					Mutex.unlock this.dmutex;
+					None
+				end else begin
+					Mutex.unlock this.dmutex;
+					Thread.yield();
+					loop()
+				end
+		in
+		loop()
+
+	let push this i =
+		Mutex.lock this.dmutex;
+		this.dvalues <- i :: this.dvalues;
+		Mutex.unlock this.dmutex
+end
+
+let create_eval thread = {
+	env = None;
+	thread = thread;
+	debug_channel = Event.new_channel ();
+	debug_state = DbgRunning;
+	breakpoint = make_breakpoint 0 0 BPDisabled BPAny None;
+	caught_types = Hashtbl.create 0;
+	last_return = None;
+	caught_exception = vnull;
+}
+
+let spawn ctx f =
+	let f thread =
+		let id = Thread.id (Thread.self()) 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 = create_eval thread 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(f ());
+			close();
+		with
+		| RunTimeException(v,stack,p) ->
+			let msg = get_exc_error_message ctx v stack p in
+			prerr_endline msg;
+			close();
+		| Sys_exit i ->
+			close();
+			exit i;
+		| exc ->
+			close();
+			raise exc
+	in
+	let thread = {
+		tthread = Obj.magic ();
+		tstorage = IntMap.empty;
+		tdeque = Deque.create();
+	} in
+	thread.tthread <- Thread.create f thread;
+	thread