Add without-preemption.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index eadfc386d5d93fbf08b965c9a5fae052bd4e0b18..e6e3d9b68fb01d0cc6198364e4350c42e5ae1370 100644 (file)
--- 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 ca55b10892c601a0c482837e92aad422f7cf6ce4..f61946fd0ef119fe313be18696dca0569b303765 100644 (file)
--- 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)))