+ Let WITH-HANDLER take care of the resource lock.

+ Removed some duplicate alignments of process resources and moved
other closer the the actual system call

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)))
-   (let ((override? (:optional maybe-override? #f)))
+    (if (or (and override? (not (eq? override? 'query)))
-     (if (or (and override? (not (eq? override? 'query)))
+	    (file-not-exists? new-fname)
-	     (file-not-exists? new-fname)
+	    (and override?
-	     (and override?
+		 (y-or-n? (string-append "rename-file:" new-fname
-		  (y-or-n? (string-append "rename-file:" new-fname
+					 " already exists. Delete"))))
-					  " already exists. Delete"))))
+	(with-cwd-aligned
 	 (%rename-file old-fname new-fname)))))

scsh/newports.scm

@@ -335,14 +335,12 @@
 
 ;;; replace rts/channel-port.scm begin
 (define (open-file fname flags . maybe-mode)
-  (with-cwd-aligned
+  (let ((fd (apply open-fdes fname flags maybe-mode))
-   (with-umask-aligned
+	(access (bitwise-and flags open/access-mask)))
-    (let ((fd (apply open-fdes fname flags maybe-mode))
+    ((if (or (= access open/read) (= access open/read+write))
-	  (access (bitwise-and flags open/access-mask)))
+	 make-input-fdport
-      ((if (or (= access open/read) (= access open/read+write))
+	 make-output-fdport)
-	   make-input-fdport
+     fd 0)))
-	   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
+    (let ((port #f))
-     (with-umask-aligned
+      (dynamic-wind (lambda ()
-      (let ((port #f))
+		      (if port
-	(dynamic-wind (lambda ()
+			  (warn "throwing back into a call-with-...put-file"
-			(if port
+				string)
-			    (warn "throwing back into a call-with-...put-file"
+			  (set! port (open string))))
-				  string)
+		    (lambda () (proc port))
-			    (set! port (open string))))
+		    (lambda ()
-		      (lambda () (proc port))
+		      (if port
-		      (lambda ()
+			  (close port)))))))
-			(if port
-			    (close port)))))))))
 
 ;;; replace rts/channel-port.scm begin
 (define call-with-input-file

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)
+      (define (change-and-cache res)
-	(process-set-resource dir)
+	(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 (thread-set-resource! res) (set-thread-fluid! $resource res))
-      (define (let-resource dir thunk)
+      (define (let-resource res thunk)
-	(let-thread-fluid $resource dir thunk))
+	(let-thread-fluid $resource res thunk))
        
-      (define (with-resource* dir thunk)
+      (define (with-resource* res thunk)
-	(let ((changed-dir #f))		
+	(let ((changed-res #f))		
 	  (with-lock resource-lock
 		     (lambda ()
 		       (align-resource!)
-		       (change-and-cache dir)
+		       (change-and-cache res)
-		       (set! changed-dir (cache-value))))
+		       (set! changed-res (cache-value))))
-	  (let-resource changed-dir thunk)))
+	  (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)))
+	(let ((res (thread-read-resource)))
-	  (if (not (resource-eq? dir (cache-value)))
+	  (if (not (resource-eq? res (cache-value)))
-	      (change-and-cache dir))))
+	      (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 ()
+	(obtain-lock resource-lock)
-			(with-lock resource-lock
+	(align-resource!)
-				   align-resource!)) 
+	(with-handler
-		      thunk 
+	 (lambda (cond more)
-		      values))
+	   (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
+  (let ((proc #f)
-					; genereates no cache in the parent
+	(maybe-narrow
-   (lambda ()
+	 (if narrow?
-     (let ((proc #f)
+	     (lambda (thunk)
-	   (maybe-narrow
+	       ;; narrow loses the thread fluids and the dynamic environment
-	    (if narrow?
+	       (narrow (preserve-ports (preserve-thread-fluids thunk))
-		(lambda (thunk)
+		       'forking))
-		  ;; narrow loses the thread fluids and the dynamic environment
+	     (lambda (thunk) (thunk)))))
-		  (narrow (preserve-ports (preserve-thread-fluids thunk))
+    (maybe-narrow
-			  'forking))
+     (lambda ()
-		(lambda (thunk) (thunk)))))
+       ;; There was an atomicity problem/race condition -- if a child
-       (maybe-narrow
+       ;; process died after it was forked, but before the scsh fork
-	(lambda ()
+       ;; procedure could register the child's procobj in the
-	  ;; There was an atomicity problem/race condition -- if a child
+       ;; pid/procobj table, then when the SIGCHLD signal-handler reaped
-	  ;; process died after it was forked, but before the scsh fork
+       ;; the process, there would be no procobj for it.  We now lock
-	  ;; procedure could register the child's procobj in the
+       ;; out interrupts across the %%FORK and NEW-CHILD-PROC
-	  ;; pid/procobj table, then when the SIGCHLD signal-handler reaped
+       ;; operations.
-	  ;; 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)
+       (((structure-ref interrupts with-interrupts-inhibited)
-	    (lambda ()
+	 (lambda ()
-	      (let ((pid (%%fork)))
+	   ;; with-env-aligned is not neccessary here but it will
-		(if (zero? pid)				
+	   ;; create the environ object in the parent process which
-		    ;; Child
+	   ;; could reuse it on further forks
-		    (lambda ()		; Do all this outside the WITH-INTERRUPTS.
+	   (let ((pid (with-env-aligned* 
-		      ;; There is no session if parent was started in batch-mode
+		       %%fork)))
-		      (if (and (session-started?) clear-interactive?)
+	     (if (zero? pid)				
-			  (set-batch-mode?! #t)) ; Children are non-interactive.
+		 ;; Child
-		      (if maybe-thunk
+		 (lambda ()		; Do all this outside the WITH-INTERRUPTS.
-			  (call-terminally maybe-thunk)))
+		   ;; There is no session if parent was started in batch-mode
-		    ;; Parent
+		   (if (and (session-started?) clear-interactive?)
-		    (begin
+		       (set-batch-mode?! #t)) ; Children are non-interactive.
-		      (set! proc (new-child-proc pid))
+		   (if maybe-thunk
-		      (lambda ()
+		       (call-terminally maybe-thunk)))
-			(values))))))))))
+		 ;; Parent
-       proc))))
+		 (begin
+		   (set! proc (new-child-proc pid))
+		   (lambda ()
+		     (values))))))))))
+    proc))
 
 (define (exit . maybe-status)
   (flush-all-ports)

scsh/syscalls.scm

@@ -312,9 +312,8 @@
 						      
 		
 (define (file-info fd/port/fname . maybe-chase?)
- (with-cwd-aligned
+  (let ((chase? (:optional maybe-chase? #t)))
-   (let ((chase? (:optional maybe-chase? #t)))
+    (%file-info fd/port/fname chase?)))
-     (%file-info fd/port/fname chase?))))
 
 
 (define file-attributes