diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index 9242a93..167dfaa 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -590,7 +590,8 @@ check-arg conjoin disjoin negate compose reverse! call/cc deprecated-proc deposit-bit-field - real->exact-integer)) + real->exact-integer + make-reinitializer)) (define-interface weak-tables-interface (export make-weak-table weak-table-set! weak-table-ref weak-table-walk diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 7aec629..4b5a7c8 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -33,7 +33,8 @@ (define-structure scsh-utilities scsh-utilities-interface - (open bitwise error-package loopholes let-opt scheme) + (open bitwise error-package loopholes let-opt scheme define-record-types + records) (files utilities) ; (optimize auto-integrate) ) @@ -162,7 +163,7 @@ conditions scsh-utilities handle - fluids + fluids thread-fluids weak-tables scsh-char-set-low-level-lib ; rdelim.scm needs it. @@ -463,5 +464,6 @@ (open scheme define-record-types finite-types locks thread-fluids external-calls + scsh-utilities bitwise) (files syslog)) diff --git a/scsh/scsh.scm b/scsh/scsh.scm index 04238ce..004ad3d 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -287,26 +287,22 @@ ;;; working directory per thread ;;; this reflects the cwd of the process -(define-record cache - cwd) +(define *unix-cwd* 'uninitialized) +(define cwd-lock 'uninitialized) -(define-record-resumer type/cache - (lambda (cache) - (set-cache:cwd cache (process-cwd)))) ; set the cache to an impossible filename. - -(define *unix-cwd* - (make-cache (process-cwd))) ; Initialise the cache to an impossible filename. +(define (initialize-cwd) + (set! *unix-cwd* (process-cwd)) + (set! cwd-lock (make-lock))) (define (unix-cwd) - (cache:cwd *unix-cwd*)) + *unix-cwd*) -(define cwd-lock (make-lock)) ;;; Actually do the syscall and update the cache ;;; assumes the cwd lock obtained (define (chdir-and-cache dir) (process-chdir dir) - (set-cache:cwd *unix-cwd* (process-cwd))) + (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. @@ -325,32 +321,27 @@ result)))) ;;; The thread-specific CWD: A fluid -(define-record state - cwd) -(define-record-resumer type/state - (lambda (state) - (set-state:cwd state (make-fluid (process-cwd))))) +(define $cwd + (make-thread-fluid + (process-cwd))) -(define $cwd (make-state (make-fluid (process-cwd)))) - -(define (cwd) (fluid (state:cwd $cwd))) -(define (set-cwd! dir) (set-fluid! (state:cwd $cwd) dir)) +(define (cwd) (thread-fluid $cwd)) +(define (set-cwd! dir) (set-thread-fluid! $cwd dir)) (define (let-cwd dir thunk) - (let-fluid (state:cwd $cwd) dir thunk)) + (let-thread-fluid $cwd dir thunk)) (define (with-cwd* dir thunk) (let ((changed-dir #f)) (with-lock cwd-lock (lambda () - (align-cwd!) (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 ensuing syscall that relies upon it should +;; any ensuring syscall that relies upon it should ;; be "glued together" with the cwd lock. (define (align-cwd!) @@ -362,7 +353,6 @@ (define (chdir dir) (with-lock cwd-lock (lambda () - (align-cwd!) (chdir-and-cache dir) (set-cwd! (unix-cwd))))) @@ -388,6 +378,12 @@ ;;; (define (exported-delete-file fname) ;;;; (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)) @@ -828,7 +824,9 @@ (flush-all-ports) (with-env-aligned* (lambda () - (%exec prog (cons prog arglist) env)))) + (with-cwd-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 +842,22 @@ (flush-all-ports) (with-env-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-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) (apply exec-path/env prog #t arglist)) diff --git a/scsh/syslog.scm b/scsh/syslog.scm index 466232d..e776b29 100644 --- a/scsh/syslog.scm +++ b/scsh/syslog.scm @@ -260,23 +260,6 @@ (make-syslog-channel ident options facility mask) thunk)) -;---------------- -; A record type whose only purpose is to run some code when we start up an -; image. - -(define-record-type reinitializer :reinitializer - (make-reinitializer thunk) - reinitializer? - (thunk reinitializer-thunk)) - -(define-record-discloser :reinitializer - (lambda (r) - (list 'reinitializer (reinitializer-thunk r)))) - -(define-record-resumer :reinitializer - (lambda (r) - ((reinitializer-thunk r)))) - (initialize-syslog) (define syslog-reinitializer diff --git a/scsh/utilities.scm b/scsh/utilities.scm index fbb4cab..2bb6ad8 100644 --- a/scsh/utilities.scm +++ b/scsh/utilities.scm @@ -251,3 +251,19 @@ (if (= i len) v (lp (f v (string-ref s i)) (+ i 1)))))) +;---------------- +; A record type whose only purpose is to run some code when we start up an +; image. + +(define-record-type reinitializer :reinitializer + (make-reinitializer thunk) + reinitializer? + (thunk reinitializer-thunk)) + +(define-record-discloser :reinitializer + (lambda (r) + (list 'reinitializer (reinitializer-thunk r)))) + +(define-record-resumer :reinitializer + (lambda (r) + ((reinitializer-thunk r))))