From: Matt Birkholz Date: Tue, 21 Jul 2015 07:46:11 +0000 (-0700) Subject: Make uxenv.o state single-threaded. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dab6cc34517a2b47bb72eb551555a4b033473ec5;p=mit-scheme.git 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 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