diff --git a/scsh/filesys.scm b/scsh/filesys.scm index 9c37c3a..b2ed9fa 100644 --- a/scsh/filesys.scm +++ b/scsh/filesys.scm @@ -37,8 +37,6 @@ ;;; Abstract out common code for create-{directory,fifo,hard-link,symlink}: (define (create-file-thing fname makeit override? op-name syscall) - (with-cwd-aligned - (with-umask-aligned (let ((query (lambda () (y-or-n? (string-append op-name ": " fname " already exists. Delete"))))) @@ -55,11 +53,13 @@ ;;; raising an error here won't work due to S48's ;;; broken exception system (else (list err syscall fname))))) - (makeit fname) + (with-cwd-aligned + (with-umask-aligned + (makeit fname))) #f)))) (if (list? result) (apply errno-error result) - (if #f #f))))))) + (if #f #f))))) ;;;;;;; @@ -108,11 +108,11 @@ ;;; us not to. That's life in the food chain. (define (rename-file old-fname new-fname . maybe-override?) - (with-cwd-aligned - (let ((override? (:optional maybe-override? #f))) - (if (or (and override? (not (eq? override? 'query))) - (file-not-exists? new-fname) - (and override? - (y-or-n? (string-append "rename-file:" new-fname - " already exists. Delete")))) + (let ((override? (:optional maybe-override? #f))) + (if (or (and override? (not (eq? override? 'query))) + (file-not-exists? new-fname) + (and override? + (y-or-n? (string-append "rename-file:" new-fname + " already exists. Delete")))) + (with-cwd-aligned (%rename-file old-fname new-fname))))) diff --git a/scsh/newports.scm b/scsh/newports.scm index b1aa51e..b6bee55 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -335,14 +335,12 @@ ;;; replace rts/channel-port.scm begin (define (open-file fname flags . maybe-mode) - (with-cwd-aligned - (with-umask-aligned - (let ((fd (apply open-fdes fname flags maybe-mode)) - (access (bitwise-and flags open/access-mask))) - ((if (or (= access open/read) (= access open/read+write)) - make-input-fdport - make-output-fdport) - fd 0))))) + (let ((fd (apply open-fdes fname flags maybe-mode)) + (access (bitwise-and flags open/access-mask))) + ((if (or (= access open/read) (= access open/read+write)) + make-input-fdport + make-output-fdport) + fd 0))) (define (open-input-file fname . maybe-flags) (let ((flags (:optional maybe-flags 0))) @@ -694,18 +692,16 @@ (define (call-with-mumble-file open close) (lambda (string proc) - (with-cwd-aligned - (with-umask-aligned - (let ((port #f)) - (dynamic-wind (lambda () - (if port - (warn "throwing back into a call-with-...put-file" - string) - (set! port (open string)))) - (lambda () (proc port)) - (lambda () - (if port - (close port))))))))) + (let ((port #f)) + (dynamic-wind (lambda () + (if port + (warn "throwing back into a call-with-...put-file" + string) + (set! port (open string)))) + (lambda () (proc port)) + (lambda () + (if port + (close port))))))) ;;; replace rts/channel-port.scm begin (define call-with-input-file diff --git a/scsh/scsh.scm b/scsh/scsh.scm index dea863c..4940faa 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -170,8 +170,8 @@ ;; Actually do the syscall and update the cache ;; assumes the resource lock obtained - (define (change-and-cache dir) - (process-set-resource dir) + (define (change-and-cache res) + (process-set-resource res) (set! *resource-cache* (process-read-resource))) ;; The thread-specific resource: A thread fluid @@ -179,18 +179,18 @@ (define $resource 'empty-resource-value) (define (thread-read-resource) (thread-fluid $resource)) - (define (thread-set-resource! dir) (set-thread-fluid! $resource dir)) - (define (let-resource dir thunk) - (let-thread-fluid $resource dir thunk)) + (define (thread-set-resource! res) (set-thread-fluid! $resource res)) + (define (let-resource res thunk) + (let-thread-fluid $resource res thunk)) - (define (with-resource* dir thunk) - (let ((changed-dir #f)) + (define (with-resource* res thunk) + (let ((changed-res #f)) (with-lock resource-lock (lambda () (align-resource!) - (change-and-cache dir) - (set! changed-dir (cache-value)))) - (let-resource changed-dir thunk))) + (change-and-cache res) + (set! changed-res (cache-value)))) + (let-resource changed-res thunk))) ;; Align the value of the Unix resource with scsh's value. ;; Since another thread could disalign, this call and @@ -198,41 +198,33 @@ ;; be "glued together" with the resource lock. (define (align-resource!) - (let ((dir (thread-read-resource))) - (if (not (resource-eq? dir (cache-value))) - (change-and-cache dir)))) + (let ((res (thread-read-resource))) + (if (not (resource-eq? res (cache-value))) + (change-and-cache res)))) - (define (thread-change-resource dir) + (define (thread-change-resource res) (with-lock resource-lock (lambda () (align-resource!) - (change-and-cache dir) + (change-and-cache res) (thread-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 - ;; resource, do the syscall, turn them back on. - (define (with-resource-aligned* thunk) - (dynamic-wind (lambda () - (with-lock resource-lock - align-resource!)) - thunk - values)) + (obtain-lock resource-lock) + (align-resource!) + (with-handler + (lambda (cond more) + (release-lock resource-lock) + (more)) + (lambda () + (let ((ret (thunk))) + (release-lock resource-lock) + ret)))) ;; example syscall ;; (define (exported-delete-file fname) ;; (with-cwd-aligned (really-delete-file fname))) - (define resource-reinitializer (make-reinitializer (lambda () (warn "calling resumer") (initialize-resource)))))))) @@ -943,44 +935,45 @@ thunk)))))))) (define (really-fork clear-interactive? narrow? maybe-thunk) - (with-env-aligned* ; not neccessary here but doing it on exec - ; genereates no cache in the parent - (lambda () - (let ((proc #f) - (maybe-narrow - (if narrow? - (lambda (thunk) - ;; narrow loses the thread fluids and the dynamic environment - (narrow (preserve-ports (preserve-thread-fluids thunk)) - 'forking)) - (lambda (thunk) (thunk))))) - (maybe-narrow - (lambda () - ;; There was an atomicity problem/race condition -- if a child - ;; process died after it was forked, but before the scsh fork - ;; procedure could register the child's procobj in the - ;; pid/procobj table, then when the SIGCHLD signal-handler reaped - ;; the process, there would be no procobj for it. We now lock - ;; out interrupts across the %%FORK and NEW-CHILD-PROC - ;; operations. + (let ((proc #f) + (maybe-narrow + (if narrow? + (lambda (thunk) + ;; narrow loses the thread fluids and the dynamic environment + (narrow (preserve-ports (preserve-thread-fluids thunk)) + 'forking)) + (lambda (thunk) (thunk))))) + (maybe-narrow + (lambda () + ;; There was an atomicity problem/race condition -- if a child + ;; process died after it was forked, but before the scsh fork + ;; procedure could register the child's procobj in the + ;; pid/procobj table, then when the SIGCHLD signal-handler reaped + ;; the process, there would be no procobj for it. We now lock + ;; out interrupts across the %%FORK and NEW-CHILD-PROC + ;; operations. - (((structure-ref interrupts with-interrupts-inhibited) - (lambda () - (let ((pid (%%fork))) - (if (zero? pid) - ;; Child - (lambda () ; Do all this outside the WITH-INTERRUPTS. - ;; There is no session if parent was started in batch-mode - (if (and (session-started?) clear-interactive?) - (set-batch-mode?! #t)) ; Children are non-interactive. - (if maybe-thunk - (call-terminally maybe-thunk))) - ;; Parent - (begin - (set! proc (new-child-proc pid)) - (lambda () - (values)))))))))) - proc)))) + (((structure-ref interrupts with-interrupts-inhibited) + (lambda () + ;; with-env-aligned is not neccessary here but it will + ;; create the environ object in the parent process which + ;; could reuse it on further forks + (let ((pid (with-env-aligned* + %%fork))) + (if (zero? pid) + ;; Child + (lambda () ; Do all this outside the WITH-INTERRUPTS. + ;; There is no session if parent was started in batch-mode + (if (and (session-started?) clear-interactive?) + (set-batch-mode?! #t)) ; Children are non-interactive. + (if maybe-thunk + (call-terminally maybe-thunk))) + ;; Parent + (begin + (set! proc (new-child-proc pid)) + (lambda () + (values)))))))))) + proc)) (define (exit . maybe-status) (flush-all-ports) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index c0fa537..0ae3a58 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -312,9 +312,8 @@ (define (file-info fd/port/fname . maybe-chase?) - (with-cwd-aligned - (let ((chase? (:optional maybe-chase? #t))) - (%file-info fd/port/fname chase?)))) + (let ((chase? (:optional maybe-chase? #t))) + (%file-info fd/port/fname chase?))) (define file-attributes