+ Derive general make-process-resource from cwd stuff
+ Implement cwd with make-process-resource + Implement umask with make-process-resource + Add with-umask-aligned* to exec
This commit is contained in:
mainzelm
parent
04362fd7e3
commit
decf6184d9
187
scsh/scsh.scm
187
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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue