+ 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)))
     (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)))))

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)))))
+     fd 0)))
 
 (define (open-input-file fname . maybe-flags)
   (let ((flags (:optional maybe-flags 0)))
@@ -694,8 +692,6 @@
 
 (define (call-with-mumble-file open close)
   (lambda (string proc)
-    (with-cwd-aligned
-     (with-umask-aligned
     (let ((port #f))
       (dynamic-wind (lambda ()
 		      (if port
@@ -705,7 +701,7 @@
 		    (lambda () (proc port))
 		    (lambda ()
 		      (if port
-			    (close 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,9 +935,6 @@
 	     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?
@@ -966,7 +955,11 @@
 
        (((structure-ref interrupts with-interrupts-inhibited)
 	 (lambda ()
-	      (let ((pid (%%fork)))
+	   ;; 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.
@@ -980,7 +973,7 @@
 		   (set! proc (new-child-proc pid))
 		   (lambda ()
 		     (values))))))))))
-       proc))))
+    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)))
-     (%file-info fd/port/fname chase?))))
+    (%file-info fd/port/fname chase?)))
 
 
 (define file-attributes