Make uxenv.o state single-threaded.

Serialize use of the process's current working directory.

The top-level REPL no longer munges the cwd.  The only use of the
SET-WORKING-DIRECTORY-PATHNAME! primitive is serially, with a thread
mutex lock, in a dynamic-wind.

diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi
index 257365084af80f9f0a142535f7377ac9f54ba061..b402ff3ea5bfc01fddd2559673254b331bdb881a 100644 (file)
--- a/doc/ref-manual/os-interface.texi
+++ b/doc/ref-manual/os-interface.texi
@@ -811,9 +811,6 @@ Additionally, @code{set-working-directory-pathname!} modifies the value
 of@* @code{*default-pathname-defaults*} by merging the new working
 directory into it.
 
-When this procedure is executed in the top-level @acronym{REP} loop, it
-changes the working directory of the running Scheme executable.
-
 @example
 @group
 (set-working-directory-pathname! "/usr/morris/blisp")

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 6277c280d12769938c99b8655453835f484b1805..25b8778cebf0f91b670ffa2c3451de0139001cf8 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -51,17 +51,11 @@ USA.
                            console-i/o-port
                            user-initial-environment
                            #f
-                           `((SET-DEFAULT-DIRECTORY
-                              ,top-level-repl/set-default-directory))
+                           '()
                            user-initial-prompt)
                 (cmdl-message/strings "Cold load finished")))))
 
 (define root-continuation)
-
-(define (top-level-repl/set-default-directory cmdl pathname)
-  cmdl
-  ((ucode-primitive set-working-directory-pathname! 1)
-   (->namestring pathname)))
 \f
 ;;;; Command Loops
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e9215e2f683ac867110015e297348c2e70c29e74..4b409e0b7e827d26d7b6a36ca1cd429ae0c0a417 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -894,7 +894,10 @@ USA.
            unix/current-uid
            unix/gid->string
            unix/system
-           unix/uid->string)))
+           unix/uid->string)
+    (import (runtime thread)
+           allow-preempt-current-thread
+           disallow-preempt-current-thread)))
  ((nt)
   (extend-package (runtime os-primitives)
     (files "ntprm")

diff --git a/src/runtime/site.scm.unix b/src/runtime/site.scm.unix
index cb241e9da7c7c3cc8ccf585602000ada10e618f0..255e1bdb5a175970f4b401c8821b23dae30bbd4b 100644 (file)
--- a/src/runtime/site.scm.unix
+++ b/src/runtime/site.scm.unix
@@ -50,17 +50,22 @@ USA.
     (system command-line)))
 
 (define (system command-line)
-  (let ((inside (->namestring
-                (directory-pathname-as-file (working-directory-pathname))))
-       (outside false))
+  (let ((inside (->namestring (working-directory-pathname)))
+       (preemptible? (thread-execution-state (current-thread)))
+       (outside))
     (dynamic-wind
      (lambda ()
-       (stop-thread-timer)
+       (lock-thread-mutex cwd-mutex)
+       (set! preemptible? (not (eq? 'RUNNING-WITHOUT-PREEMPTION
+                                   (thread-execution-state (current-thread)))))
+       (disallow-preempt-current-thread)
        (set! outside ((ucode-primitive working-directory-pathname 0)))
        ((ucode-primitive set-working-directory-pathname! 1) inside))
      (lambda ()
        ((ucode-primitive system 1) command-line))
      (lambda ()
-       (set! inside ((ucode-primitive working-directory-pathname 0)))
        ((ucode-primitive set-working-directory-pathname! 1) outside)
-       (start-thread-timer)))))
\ No newline at end of file
+       (set! outside)
+       (if preemptible?
+          (allow-preempt-current-thread))
+       (unlock-thread-mutex cwd-mutex)))))
\ No newline at end of file

diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm
index befb34e5907f37636df689da50386234321cd22a..0f4838460fbd24603fd1cd6986043724a28f5c1c 100644 (file)
--- a/src/runtime/unxprm.scm
+++ b/src/runtime/unxprm.scm
@@ -185,6 +185,7 @@ USA.
 
 (define (initialize-system-primitives!)
   (set! environment-variables (make-string-hash-table))
+  (set! cwd-mutex (make-thread-mutex))
   (add-event-receiver! event:after-restart reset-environment-variables!))
 \f
 ;;;; MIME types
@@ -316,24 +317,28 @@ USA.
   (or ((ucode-primitive gid->string 1) gid)
       (number->string gid 10)))
 
+(define cwd-mutex)
+
 (define (unix/system string)
-  (let ((wd-inside (->namestring (working-directory-pathname)))
-       (wd-outside)
-       (ti-outside))
+  (let ((inside (->namestring (working-directory-pathname)))
+       (preemptible?)
+       (outside))
     (dynamic-wind
      (lambda ()
-       (set! wd-outside ((ucode-primitive working-directory-pathname 0)))
-       ((ucode-primitive set-working-directory-pathname! 1) wd-inside)
-       (set! ti-outside (thread-timer-interval))
-       (set-thread-timer-interval! #f))
+       (lock-thread-mutex cwd-mutex)
+       (set! preemptible? (not (eq? 'RUNNING-WITHOUT-PREEMPTION
+                                   (thread-execution-state (current-thread)))))
+       (disallow-preempt-current-thread)
+       (set! outside ((ucode-primitive working-directory-pathname 0)))
+       ((ucode-primitive set-working-directory-pathname! 1) inside))
      (lambda ()
        ((ucode-primitive system 1) string))
      (lambda ()
-       ((ucode-primitive set-working-directory-pathname! 1) wd-outside)
-       (set! wd-outside)
-       (set-thread-timer-interval! ti-outside)
-       (set! ti-outside)
-       unspecific))))
+       ((ucode-primitive set-working-directory-pathname! 1) outside)
+       (set! outside)
+       (if preemptible?
+          (allow-preempt-current-thread))
+       (unlock-thread-mutex cwd-mutex)))))
 \f
 (define (file-line-ending pathname)
   ;; This works because the line translation is harmless when not