smp: without-interrupts: sfile.scm

diff --git a/README.txt b/README.txt
index 2e6aef961d8589aa4633c2d1a1ebe6e30dc7947d..f753dac6d09d94831a35e081c220fb46f7990cc6 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -1551,7 +1551,12 @@ The hits with accompanying analysis:
        OK.  This is all about interrupts, not atomicity nor aborts.
 
   sfile.scm:202:        (without-interrupts
+       Caller: allocate-temporary-file
   sfile.scm:216:    (without-interrupts
+       Caller: deallocate-temporary-file
+
+       Added a files-to-delete-mutex to serialize access to the
+       files-to-delete element of the fixed-objects vector.
 
   string.scm:178:         (let ((mask (set-interrupt-enables! interrupt-mask/none)))
   string.scm:199:           (set-interrupt-enables! mask)

diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 4be35f009b0992ef5724007d37a47d1be8c31254..8ffc35b8e51a048e87d672cb7df1c1df76e0dbf1 100644 (file)
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -194,12 +194,18 @@ USA.
      (lambda () (receiver pathname))
      (lambda () (deallocate-temporary-file pathname)))))
 
+(define files-to-delete-mutex (make-thread-mutex))
+
+(define (with-files-to-delete-locked thunk)
+  (with-thread-mutex-locked files-to-delete-mutex
+    (lambda () (without-interruption thunk))))
+
 (define (allocate-temporary-file pathname)
   (and (not (file-exists? pathname))
        (let ((objects (get-fixed-objects-vector))
             (slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
             (filename (->namestring pathname)))
-        (without-interrupts
+        (with-files-to-delete-locked
          (lambda ()
            (and (file-touch pathname)
                 (begin
@@ -213,7 +219,7 @@ USA.
   (let ((objects (get-fixed-objects-vector))
        (slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
        (filename (->namestring pathname)))
-    (without-interrupts
+    (with-files-to-delete-locked
      (lambda ()
        (vector-set! objects slot
                    (delete! filename (vector-ref objects slot)))