From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 10 Jul 2015 02:30:06 +0000 (-0700)
Subject: Add without-preemption.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a8a631ff14ad80a3e8fae4de410f2ca20bd1a2f3;p=mit-scheme.git

Add without-preemption.
---

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 968eb6065..fb5ed81fb 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -85,6 +85,14 @@ USA.
 		   (%outf-error "with-obarray-lock: unlock failed")))
 	     (%outf-error "with-obarray-lock: lock failed"))))
       (without-interrupts thunk)))
+
+(define (without-preemption thunk)
+  (let* ((thread first-running-thread)
+	 (state (thread/execution-state thread)))
+    (set-thread/execution-state! thread 'RUNNING-WITHOUT-PREEMPTION)
+    (let ((value (thunk)))
+      (set-thread/execution-state! thread state)
+      value)))
 
 (define-structure (thread
 		   (constructor %make-thread (properties))