diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 004ad3d..bf4353b 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -283,32 +283,6 @@ #f)) ; AFTER doesn't appear in LIST. (cons elt list))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; working directory per thread - -;;; this reflects the cwd of the process -(define *unix-cwd* 'uninitialized) -(define cwd-lock 'uninitialized) - -(define (initialize-cwd) - (set! *unix-cwd* (process-cwd)) - (set! cwd-lock (make-lock))) - -(define (unix-cwd) - *unix-cwd*) - - -;;; Actually do the syscall and update the cache -;;; assumes the cwd lock obtained -(define (chdir-and-cache dir) - (process-chdir dir) - (set! *unix-cwd* (process-cwd))) - -;;; Dynamic-wind is not the right thing to take care of the lock; -;;; it would release the lock on every context switch. -;;; With-lock releases the lock on a condition, using call/cc will -;;; skrew things up - ;;; Should be moved to somewhere else (define (with-lock lock thunk) (with-handler (lambda (condition more) @@ -320,57 +294,88 @@ (release-lock lock) result)))) -;;; The thread-specific CWD: A fluid -(define $cwd +;;; A resource is a part of the process state for which every thread +;;; has its own value +(define-syntax make-process-resource + (syntax-rules () + ((make-process-resource + initialize-resource + thread-read-resource thread-set-resource with-resource* + with-resource-aligned* process-read-resource process-set-resource) +(begin +(define *resource-cache* 'uninitialized) +(define resource-lock 'uninitialized) + +(define (initialize-resource) + (set! *resource-cache* (process-read-resource)) + (set! resource-lock (make-lock))) + +(define (cache-value) + *resource-cache*) + +;;; Actually do the syscall and update the cache +;;; assumes the resource lock obtained +(define (change-and-cache dir) + (process-set-resource dir) + (set! *resource-cache* (process-read-resource))) + +;;; Dynamic-wind is not the right thing to take care of the lock; +;;; it would release the lock on every context switch. +;;; With-lock releases the lock on a condition, using call/cc will +;;; skrew things up + +;;; The thread-specific resource: A thread fluid + +(define $resource (make-thread-fluid - (process-cwd))) + (process-read-resource))) -(define (cwd) (thread-fluid $cwd)) -(define (set-cwd! dir) (set-thread-fluid! $cwd dir)) -(define (let-cwd dir thunk) - (let-thread-fluid $cwd dir thunk)) +(define (thread-read-resource) (thread-fluid $resource)) +(define (set-resource! dir) (set-thread-fluid! $resource dir)) +(define (let-resource dir thunk) + (let-thread-fluid $resource dir thunk)) -(define (with-cwd* dir thunk) - (let ((changed-dir #f)) - (with-lock cwd-lock +(define (with-resource* dir thunk) + (let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!! + (with-lock resource-lock (lambda () - (chdir-and-cache dir) - (set! changed-dir (unix-cwd)))) - (let-cwd changed-dir thunk))) + (change-and-cache dir) + (set! changed-dir (cache-value)))) + (let-resource changed-dir thunk))) -;; Align the Unix CWD with the scsh CWD. +;; Align the value of the Unix resource with scsh's value. ;; Since another thread could disalign, this call and ;; any ensuring syscall that relies upon it should -;; be "glued together" with the cwd lock. +;; be "glued together" with the resource lock. -(define (align-cwd!) - (let ((dir (cwd))) - (if (not (string=? dir (unix-cwd))) - (chdir-and-cache dir)))) +(define (align-resource!) + (let ((dir (thread-read-resource))) + (if (not (string=? dir (cache-value))) + (change-and-cache dir)))) - -(define (chdir dir) - (with-lock cwd-lock +(define (thread-set-resource dir) + (with-lock resource-lock (lambda () - (chdir-and-cache dir) - (set-cwd! (unix-cwd))))) + (change-and-cache dir) + (set-resource! (cache-value))))) ;;; For thunks that don't raise exceptions or throw to continuations, ;;; this is overkill & probably a little heavyweight for frequent use. ;;; But it is general. ;;; -;;; A less-general, more lightweight hack could be done just for syscalls. -;;; We could probably dump the DYNAMIC-WINDs and build the rest of the pattern -;;; into one of the syscall-defining macros, or something. -;;; Olin adds the following: the efficient way to do things is not with -;;; a dynamic wind or a lock. Just turn off interrupts, sync the cwd, do -;;; the syscall, turn them back on. +;;; A less-general, more lightweight hack could be done just for +;;; syscalls. We could probably dump the DYNAMIC-WINDs and build the +;;; rest of the pattern into one of the syscall-defining macros, or +;;; something. +;;; Olin adds the following: the efficient way to do things is not +;;; with a dynamic wind or a lock. Just turn off interrupts, sync the +;;; resource, do the syscall, turn them back on. -(define (with-cwd-aligned* thunk) +(define (with-resource-aligned* thunk) (dynamic-wind (lambda () - (with-lock cwd-lock - align-cwd!)) + (with-lock resource-lock + align-resource!)) thunk values)) @@ -378,24 +383,26 @@ ;;; (define (exported-delete-file fname) ;;;; (with-cwd-aligned (really-delete-file fname))) + +(define resource-reinitializer + (make-reinitializer initialize-resource)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; working directory per thread +(make-process-resource + initialize-cwd cwd chdir with-cwd* with-cwd-aligned* + process-cwd process-chdir) + (initialize-cwd) -(define cwd-reinitializer - (make-reinitializer initialize-cwd)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; umask per thread +(make-process-resource + initialize-umask umask set-umask with-umask* with-umask-aligned* + process-umask set-process-umask) -;;; umask -(define (with-umask* mask thunk) - (let ((old-mask #f)) - (dynamic-wind - (lambda () - (set! old-mask (umask)) - (set-umask mask)) - thunk - (lambda () - (set! mask (umask)) - (set-umask old-mask))))) - +(initialize-umask) ;;; Sugar: (define-simple-syntax (with-cwd dir . body) @@ -826,7 +833,9 @@ (lambda () (with-cwd-aligned* (lambda () - (%exec prog (cons prog arglist) env)))))) + (with-umask-aligned* + (lambda () + (%exec prog (cons prog arglist) env)))))))) ;(define (exec-path/env prog env . arglist) ; (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) => @@ -844,20 +853,22 @@ (lambda () (with-cwd-aligned* (lambda () - (let ((prog (stringify prog))) - (if (string-index prog #\/) - - ;; Contains a slash -- no path search. - (%exec prog (cons prog arglist) env) - - ;; Try each directory in PATH-LIST. - (let ((argv (list->vector (cons prog (map stringify arglist))))) - (for-each (lambda (dir) - (let ((binary (string-append dir "/" prog))) - (%%exec/errno binary argv env))) - (fluid exec-path-list))))) - - (error "No executable found." prog arglist)))))) + (with-umask-aligned* + (lambda () + (let ((prog (stringify prog))) + (if (string-index prog #\/) + + ;; Contains a slash -- no path search. + (%exec prog (cons prog arglist) env) + + ;; Try each directory in PATH-LIST. + (let ((argv (list->vector (cons prog (map stringify arglist))))) + (for-each (lambda (dir) + (let ((binary (string-append dir "/" prog))) + (%%exec/errno binary argv env))) + (fluid exec-path-list))))) + + (error "No executable found." prog arglist)))))))) (define (exec-path prog . arglist) (apply exec-path/env prog #t arglist)) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index e24810c..4192dbd 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -194,12 +194,12 @@ ;;; UMASK -(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS +(define-foreign set-process-umask (umask (mode_t mask)) no-declare ; integer on SunOS mode_t) -(define (umask) - (let ((m (set-umask 0))) - (set-umask m) +(define (process-umask) + (let ((m (set-process-umask 0))) + (set-process-umask m) m))