added env and cwd per thread

This commit is contained in:
marting 1999-11-04 21:40:50 +00:00
parent 6734b0520f
commit 07a9816153
1 changed files with 180 additions and 66 deletions

View File

@ -115,6 +115,79 @@
;;; Environment stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record env
c-struct ; An alien -- pointer to an envvec struct
alist) ; Corresponding alist
;;; TODO Give it a finaliser that uses free() to release the envvec struct.
;;; TODO Maintain alist
(define env-lock (make-lock))
(define (obtain-env-lock) (obtain-lock env-lock)) ; Thunks for
(define (release-env-lock) (release-lock env-lock)) ; DYNAMIC-WINDs.
(define current-process-env #f)
(define $current-env #f)
(define (install-env)
(set! current-process-env
(make-threads-env (environ-env->alist)))
(set! $current-env (make-fluid current-process-env))
(%align-env (env:c-struct (current-env))))
(define (make-threads-env alist)
(make-env (alist->envvec alist) alist))
(define (current-env) (fluid $current-env))
(define (align-env!)
(let ((current-env-val (current-env)))
(if (not (eq? current-env-val current-process-env))
(begin (%align-env (env:c-struct current-env-val))
(set! current-process-env current-env-val)))))
(define (with-env-aligned* thunk)
(dynamic-wind obtain-env-lock
(lambda () (dynamic-wind align-env! thunk values))
release-env-lock))
(define (with-total-env* alist thunk)
(let-fluid $current-env (make-threads-env alist) thunk))
(define (with-env* alist-delta thunk)
(let ((new-env (fold (lambda (key/val alist)
(alist-update (car key/val) (cdr key/val) alist))
(env->alist)
alist-delta)))
(let-fluid $current-env (make-threads-env new-env) thunk)))
;(define (lp) (display (getenv "BLA")) (sleep 2000) (lp))
(define (env->alist)
(with-env-aligned*
(lambda ()
(environ-env->alist))))
(define (alist->env alist)
(with-env-aligned*
(lambda ()
(envvec-alist->env alist))))
(define (delete-env name)
(with-env-aligned*
(lambda ()
(envvec-delete-env name))))
(define (setenv name value)
(with-env-aligned*
(lambda ()
(if name
(envvec-setenv name value)
(envvec-delete-env name)))))
(define (getenv name)
(with-env-aligned*
(lambda ()
(envvec-getenv name))))
;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
@ -168,16 +241,6 @@
(cons key/val ans))))
ans))))
;; Tail-recursive loops suck.
;; (define (alist-compress alist)
;; (loop (initial (ans '()))
;; (for key/val in alist)
;;
;; (when (not (assoc (car key/val) ans)))
;; (next (ans (cons key/val ans)))
;;
;; (result (reverse ans))))
(define (add-before elt before list)
(let rec ((list list))
(if (pair? list)
@ -204,47 +267,87 @@
#f)) ; AFTER doesn't appear in LIST.
(cons elt list)))
;;; Or, just say...
;;; (reverse (add-before elt after (reverse list)))
(define (with-env* alist-delta thunk)
(let* ((old-env #f)
(new-env (fold (lambda (key/val alist)
(alist-update (car key/val) (cdr key/val) alist))
(env->alist)
alist-delta)))
(dynamic-wind
(lambda ()
(set! old-env (env->alist))
(alist->env new-env))
thunk
(lambda ()
(set! new-env (env->alist))
(alist->env old-env)))))
;(define (with-env* alist-delta thunk)
; (let* ((old-env #f)
; (new-env (fold (lambda (key/val alist)
; (alist-update (car key/val) (cdr key/val) alist))
; (env->alist)
; alist-delta)))
; (dynamic-wind
; (lambda ()
; (set! old-env (env->alist))
; (alist->env new-env))
; thunk
; (lambda ()
; (set! new-env (env->alist))
; (alist->env old-env)))))
(define (with-total-env* alist thunk)
(let ((old-env (env->alist)))
(dynamic-wind
(lambda ()
(set! old-env (env->alist))
(alist->env alist))
thunk
(lambda ()
(set! alist (env->alist))
(alist->env old-env)))))
;(define (with-total-env* alist thunk)
; (let ((old-env (env->alist)))
; (dynamic-wind
; (lambda ()
; (set! old-env (env->alist))
; (alist->env alist))
; thunk
; (lambda ()
; (set! alist (env->alist))
; (alist->env old-env)))))
(define (with-cwd* dir thunk)
(let ((old-wd #f))
(dynamic-wind
(lambda ()
(set! old-wd (cwd))
(chdir dir))
thunk
(lambda ()
(set! dir (cwd))
(chdir old-wd)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; working directory per thread
(define unix-cwd "") ; Initialise the cache to an impossible filename.
(define cwd-lock (make-lock))
(define (obtain-cwd-lock) (obtain-lock cwd-lock)) ; Thunks for
(define (release-cwd-lock) (release-lock cwd-lock)) ; DYNAMIC-WINDs.
;;; The thread-specific CWD.
(define $cwd (make-fluid (process-cwd)))
(define (cwd) (fluid $cwd))
(define (with-cwd* dir thunk) (let-fluid $cwd dir thunk))
(define (set-cwd! dir) (set-fluid! $cwd dir))
;; Align the Unix CWD with the scsh CWD.
;; Since another thread could disalign, this call and
;; any ensuing syscall that relies upon it should
;; be "glued together" with the cwd lock.
(define (align-cwd!)
(let ((dir (cwd)))
(if (not (string=? (cwd) unix-cwd))
(begin (process-chdir dir)
(set! unix-cwd dir)))))
(define (chdir dir)
(dynamic-wind obtain-cwd-lock
(lambda ()
(process-chdir dir)
(set-cwd! (process-cwd)))
release-cwd-lock))
;;; 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.
(define (with-cwd-aligned* thunk)
(dynamic-wind obtain-cwd-lock
(lambda () (dynamic-wind align-cwd! thunk values))
release-cwd-lock))
;;; example syscall
;;; (define (exported-delete-file fname)
;;;; (with-cwd-aligned (really-delete-file fname)))
;;; umask
(define (with-umask* mask thunk)
(let ((old-mask #f))
(dynamic-wind
@ -261,6 +364,9 @@
(define-simple-syntax (with-cwd dir . body)
(with-cwd* dir (lambda () . body)))
(define-simple-syntax (with-cwd-aligned body ...)
(with-cwd-aligned* (lambda () body ...)))
(define-simple-syntax (with-umask mask . body)
(with-umask* mask (lambda () . body)))
@ -270,7 +376,7 @@
(define-simple-syntax (with-total-env env . body)
(with-total-env* `env (lambda () . body)))
(define (call/temp-file writer user)
(let ((fname #f))
(dynamic-wind
@ -661,7 +767,9 @@
(define (exec/env prog env . arglist)
(flush-all-ports)
(%exec prog (cons prog arglist) env))
(with-env-aligned*
(lambda ()
(%exec prog (cons prog arglist) env))))
;(define (exec-path/env prog env . arglist)
; (cond ((exec-path-search (stringify prog) exec-path-list) =>
@ -675,6 +783,8 @@
(define (exec-path/env prog env . arglist)
(flush-all-ports)
(with-env-aligned*
(lambda ()
(let ((prog (stringify prog)))
(if (string-index prog #\/)
@ -688,7 +798,7 @@
(%%exec/errno binary argv env)))
exec-path-list))))
(error "No executable found." prog arglist))
(error "No executable found." prog arglist))))
(define (exec-path prog . arglist)
(apply exec-path/env prog #t arglist))
@ -706,8 +816,9 @@
(define (%fork . maybe-thunk)
(really-fork #f maybe-thunk))
(define (really-fork clear-interactive? maybe-thunk)
((with-enabled-interrupts 0
(((structure-ref interrupts with-interrupts-inhibited) (lambda ()
(let ((pid (%%fork)))
(if (zero? pid)
@ -721,7 +832,7 @@
;; Parent
(let ((proc (new-child-proc pid)))
(lambda () proc)))))))
(lambda () proc))))))))
(define (exit . maybe-status)
@ -739,9 +850,11 @@
;;; Low-level init absolutely required for any scsh program.
(define (init-scsh-hindbrain relink-ff?)
(error "call to init-scsh-hindbrain which is dead")
; (if relink-ff? (lookup-all-externals)) ; Re-link C calls.
(init-fdports!)
(%install-unix-scsh-handlers))
; (init-fdports!)
; (%install-unix-scsh-handlers)
)
;;; Some globals:
@ -763,3 +876,4 @@
; SIGTSTP blows s48 away. ???
(define (suspend) (signal-process 0 signal/stop))