Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv11465
Modified Files:
scsh.scm syscalls.scm
Log Message:
+ 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
Index: scsh.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh.scm,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -r1.15 -r1.16
*** scsh.scm 2001/07/09 18:29:26 1.15
--- scsh.scm 2001/07/09 21:23:04 1.16
***************
*** 284,313 ****
(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)
--- 284,287 ----
***************
*** 321,359 ****
result))))
! ;;; The thread-specific CWD: A fluid
! (define $cwd
(make-thread-fluid
! (process-cwd)))
! (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 (with-cwd* dir thunk)
! (let ((changed-dir #f))
! (with-lock cwd-lock
(lambda ()
! (chdir-and-cache dir)
! (set! changed-dir (unix-cwd))))
! (let-cwd changed-dir thunk)))
! ;; Align the Unix CWD with the scsh CWD.
;; Since another thread could disalign, this call and
;; any ensuring syscall that relies upon it should
! ;; be "glued together" with the cwd lock.
! (define (align-cwd!)
! (let ((dir (cwd)))
! (if (not (string=? dir (unix-cwd)))
! (chdir-and-cache dir))))
!
! (define (chdir dir)
! (with-lock cwd-lock
(lambda ()
! (chdir-and-cache dir)
! (set-cwd! (unix-cwd)))))
;;; For thunks that don't raise exceptions or throw to continuations,
--- 295,363 ----
result))))
!
! ;;; 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-read-resource)))
! (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-resource* dir thunk)
! (let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!!
! (with-lock resource-lock
(lambda ()
! (change-and-cache dir)
! (set! changed-dir (cache-value))))
! (let-resource changed-dir thunk)))
! ;; 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 resource lock.
! (define (align-resource!)
! (let ((dir (thread-read-resource)))
! (if (not (string=? dir (cache-value)))
! (change-and-cache dir))))
! (define (thread-set-resource dir)
! (with-lock resource-lock
(lambda ()
! (change-and-cache dir)
! (set-resource! (cache-value)))))
;;; For thunks that don't raise exceptions or throw to continuations,
***************
*** 361,375 ****
;;; 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.
! (define (with-cwd-aligned* thunk)
(dynamic-wind (lambda ()
! (with-lock cwd-lock
! align-cwd!))
thunk
values))
--- 365,380 ----
;;; 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
! ;;; resource, do the syscall, turn them back on.
! (define (with-resource-aligned* thunk)
(dynamic-wind (lambda ()
! (with-lock resource-lock
! align-resource!))
thunk
values))
***************
*** 379,400 ****
;;;; (with-cwd-aligned (really-delete-file fname)))
- (initialize-cwd)
! (define cwd-reinitializer
! (make-reinitializer initialize-cwd))
! ;;; 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)))))
;;; Sugar:
--- 384,407 ----
;;;; (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)
!
!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;;; umask per thread
!
! (make-process-resource
! initialize-umask umask set-umask with-umask* with-umask-aligned*
! process-umask set-process-umask)
+ (initialize-umask)
;;; Sugar:
***************
*** 827,831 ****
(with-cwd-aligned*
(lambda ()
! (%exec prog (cons prog arglist) env))))))
;(define (exec-path/env prog env . arglist)
--- 834,840 ----
(with-cwd-aligned*
(lambda ()
! (with-umask-aligned*
! (lambda ()
! (%exec prog (cons prog arglist) env))))))))
;(define (exec-path/env prog env . arglist)
***************
*** 845,862 ****
(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))))))
(define (exec-path prog . arglist)
--- 854,873 ----
(with-cwd-aligned*
(lambda ()
! (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)
Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -r1.21 -r1.22
*** syscalls.scm 2001/06/19 11:31:27 1.21
--- syscalls.scm 2001/07/09 21:23:04 1.22
***************
*** 195,204 ****
;;; UMASK
! (define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
mode_t)
! (define (umask)
! (let ((m (set-umask 0)))
! (set-umask m)
m))
--- 195,204 ----
;;; UMASK
! (define-foreign set-process-umask (umask (mode_t mask)) no-declare ; integer
on SunOS
mode_t)
! (define (process-umask)
! (let ((m (set-process-umask 0)))
! (set-process-umask m)
m))
|