From dab6cc34517a2b47bb72eb551555a4b033473ec5 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 21 Jul 2015 00:46:11 -0700
Subject: [PATCH] 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.
---
 doc/ref-manual/os-interface.texi |  3 ---
 src/runtime/rep.scm              |  8 +-------
 src/runtime/runtime.pkg          |  5 ++++-
 src/runtime/site.scm.unix        | 17 +++++++++++------
 src/runtime/unxprm.scm           | 29 +++++++++++++++++------------
 5 files changed, 33 insertions(+), 29 deletions(-)

diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi
index 257365084..b402ff3ea 100644
--- 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 6277c280d..25b8778ce 100644
--- 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)))
 
 ;;;; Command Loops
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e9215e2f6..4b409e0b7 100644
--- 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 cb241e9da..255e1bdb5 100644
--- 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 befb34e59..0f4838460 100644
--- 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!))
 
 ;;;; 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)))))
 
 (define (file-line-ending pathname)
   ;; This works because the line translation is harmless when not
-- 
2.25.1