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

Add without-preemption.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index eadfc386d..e6e3d9b68 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5078,6 +5078,7 @@ USA.
 	  with-thread-mutex-unlocked
 	  with-thread-timer-stopped
 	  (without-interruption with-thread-events-blocked)
+	  without-preemption
 	  without-thread-mutex-lock
 	  yield-current-thread)
   (export (runtime interrupt-handler)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index ca55b1089..f61946fd0 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -127,6 +127,14 @@ USA.
       (set-interrupt-enables! interrupt-mask)
       value)))
 
+(define (without-preemption thunk)
+  (let* ((thread (current-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 (threads-list)
   (map-over-population thread-population (lambda (thread) thread)))