Deadlock-free resource locking.

scsh/filesys.scm

@@ -53,8 +53,9 @@
 		      ;;; raising an error here won't work due to S48's
 		      ;;; broken exception system
 			(else (list err syscall fname)))))
-		(with-cwd-aligned
+		(with-resources-aligned 
-		 (with-umask-aligned
+		 (list cwd-resource umask-resource)
+		 (lambda ()
 		   (makeit fname)))
 		#f))))
 	(if (list? result)
@@ -114,5 +115,7 @@
 	    (and override?
 		 (y-or-n? (string-append "rename-file:" new-fname
 					 " already exists. Delete"))))
-	(with-cwd-aligned
+	(with-resources-aligned 
-	 (%rename-file old-fname new-fname)))))
+	 (list cwd-resource)
+	 (lambda ()
+	   (%rename-file old-fname new-fname))))))

scsh/scsh-interfaces.scm

@@ -341,12 +341,13 @@
 
 
 (define-interface scsh-process-state-interface
-  (export umask
+  (export with-resources-aligned
+	  
+	  umask
 	  set-umask
 	  with-umask*
 	  (with-umask :syntax)
-	  with-umask-aligned*
+	  umask-resource
-	  (with-umask-aligned :syntax)
 	  
 	  process-chdir
 	  process-cwd
@@ -354,8 +355,7 @@
 	  cwd
 	  with-cwd*
 	  (with-cwd :syntax)
-	  with-cwd-aligned*
+	  cwd-resource
-	  (with-cwd-aligned :syntax)
 
 	  pid
 	  parent-pid
@@ -429,7 +429,8 @@
 	  (with-env :syntax)
 	  (with-total-env :syntax)
 	  add-before
-	  add-after))
+	  add-after
+	  environ-resource))
 
 
 (define-interface scsh-home-interface
@@ -590,9 +591,9 @@
 
 
 (define-interface scsh-utilities-interface
-  (export del delete filter first first? nth
+  (export del first? filter fold-right
-	  fold fold-right
+	  fold
-	  any every
+	  any every nth
 	  mapv mapv! vector-every? copy-vector initialize-vector vector-append
 	  vfold vfold-right
 	  check-arg conjoin disjoin negate compose reverse! call/cc
@@ -600,7 +601,8 @@
 	  deposit-bit-field
 	  real->exact-integer
 	  make-reinitializer
-	  run-as-long-as))
+	  run-as-long-as
+	  obtain-all-or-none))
 
 (define-interface weak-tables-interface
   (export make-weak-table weak-table-set! weak-table-ref weak-table-walk

scsh/scsh-package.scm

@@ -35,7 +35,7 @@
 (define-structure scsh-utilities scsh-utilities-interface
   (open bitwise error-package loopholes let-opt scheme define-record-types 
 	records
-	threads threads-internal placeholders)
+	threads threads-internal placeholders locks srfi-1)
   (files utilities)
 ;  (optimize auto-integrate)
   )
@@ -333,7 +333,7 @@
 
 (define-structure field-reader-package scsh-field-reader-interface
   (open receiving             ; receive
-	scsh-utilities          ; nth
+	scsh-utilities          ; deprecated-proc
 	error-package		; error
 	string-lib		; string-join for obsolete join-strings
 	scsh-level-0		; delimited readers

scsh/scsh.scm

@@ -129,132 +129,228 @@
      (release-lock lock))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; working directory per thread
 
+(define *cwd-cache* 'uninitialized)
+(define cwd-lock (make-lock))
 
-;;; A resource is a part of the process state for which every thread
+(define (initialize-cwd)
-;;; has its own value
+  (set! *cwd-cache* (process-cwd))
-;;; uses the procedures:
+  (set! $cwd ;;; TODO The old thread-fluid will remain
-;;; (process-read-resource (-> 'X))
-;;; (process-set-resource ('X -> unspec))
-;;; (resource-eq? ('X 'X -> bool))
-
-;;; defines the procedures:
-;;; (initialize-resource  (-> unspec)) ; call on startup
-;;; (with-resource* ((-> 'X) -> 'X))
-;;; (with-resource-aligned* ((-> 'X) -> 'X))
-;;; (thread-read-resource (-> 'X))
-;;; (thread-set-resource ('X -> unspec))
-
-(define-syntax  make-process-resource
-  (syntax-rules 
-   ()
-   ((make-process-resource 
-     initialize-resource 
-     thread-read-resource thread-set-resource! thread-change-resource 
-     with-resource* with-resource-aligned* 
-     process-read-resource process-set-resource resource-eq?)
-    (begin 
-      (define *resource-cache* 'uninitialized)
-      (define resource-lock 'uninitialized)
-       
-      (define (initialize-resource)
-	(set! *resource-cache* (process-read-resource))
-	(set! $resource ;;; TODO The old thread-fluid will remain
 	(make-preserved-thread-fluid
-	       (process-read-resource)))
+	 (cwd-cache))))
-	(set! resource-lock (make-lock)))
+;  (set! cwd-lock (make-lock)))
 
-      (define (cache-value)
+(define (cwd-cache)
-	*resource-cache*)
+  *cwd-cache*)
 
 ;; Actually do the syscall and update the cache
-      ;; assumes the resource lock obtained
+;; assumes the cwd lock obtained
-      (define (change-and-cache res)
+(define (change-and-cache-cwd new-cwd)
-	(process-set-resource res)
+  (if (not (file-name-absolute? new-cwd))
-	(set! *resource-cache* (process-read-resource)))
+      (process-chdir (string-append (cwd) "/" new-cwd))
+      (process-chdir new-cwd))
+  (set! *cwd-cache* (process-cwd)))
 
-      ;; The thread-specific resource: A thread fluid
+;; The thread-specific cwd: A thread fluid
 
-      (define $resource 'empty-resource-value)
+(define $cwd 'empty-cwd-value)
 
-      (define (thread-read-resource) (thread-fluid $resource))
+(define (cwd) (thread-fluid $cwd))
-      (define (thread-set-resource! res) (set-thread-fluid! $resource res))
+(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd))
-      (define (let-resource res thunk)
+(define (let-cwd cwd thunk)
-	(let-thread-fluid $resource res thunk))
+  (let-thread-fluid $cwd cwd thunk))
 
-      (define (with-resource* res thunk)
+(define (with-cwd* new-cwd thunk)
-	(let ((changed-res #f))		
+  (let ((changed-cwd
-	  (with-lock resource-lock
+	 (with-lock cwd-lock
 	   (lambda ()
-		       (align-resource!)
+	     (change-and-cache-cwd new-cwd)
-		       (change-and-cache res)
+	     (cwd-cache)))))
-		       (set! changed-res (cache-value))))
+    (let-cwd changed-cwd thunk)))
-	  (let-resource changed-res thunk)))
 
-      ;; Align the value of the Unix resource with scsh's value.
+;; Align the value of the Unix cwd with scsh's value.
 ;; Since another thread could disalign, this call and
 ;; any ensuring syscall that relies upon it should
-      ;; be "glued together" with the resource lock.
+;; be "glued together" with the cwd lock.
 
-      (define (align-resource!)
+(define (align-cwd!)
-	(let ((res (thread-read-resource)))
+  (let ((thread-cwd (cwd)))
-	  (if (not (resource-eq? res (cache-value)))
+    (if (not (string=? thread-cwd (cwd-cache)))
-	      (change-and-cache res))))
+	(change-and-cache-cwd thread-cwd))))
 
-      (define (thread-change-resource res)
+(define (chdir cwd)
-	(with-lock resource-lock
+  (with-lock cwd-lock
     (lambda ()
-		     (align-resource!)
+      (change-and-cache-cwd cwd)
-		     (change-and-cache res)
+      (thread-set-cwd! (cwd-cache)))))
-		     (thread-set-resource! (cache-value)))))
 
-      (define (with-resource-aligned* thunk)
+(define-record-type resource :resource
-	(obtain-lock resource-lock)
+  (make-resource align! lock)
-	(align-resource!)
+  resource?
-	(with-handler
+  (align! resource-align!)
+  (lock resource-lock))
+
+(define (with-resources-aligned resources thunk)
+   (let ((locks (map resource-lock resources)))
+     (apply obtain-all-or-none locks)
+     (for-each
+      (lambda (align!) (align!))
+      (map resource-align! resources))
+     (let ((val (with-handler
 		 (lambda (cond more)
-	   (release-lock resource-lock)
+		   (for-each release-lock locks)
 		   (more))
-	 (lambda ()
+		 thunk)))
-	   (let ((ret (thunk)))
+       (for-each release-lock locks)
-	     (release-lock resource-lock)
+       val)))
-	     ret))))
+
+(define cwd-resource (make-resource align-cwd! cwd-lock))
 
 ;; example syscall
 ;; (define (exported-delete-file fname)
 ;;  (with-cwd-aligned (really-delete-file fname)))
 
-      (define resource-reinitializer
+(define cwd-reinitializer
-	(make-reinitializer (lambda () (warn "calling resumer") (initialize-resource))))))))
+  (make-reinitializer (lambda () (warn "calling resumer") (initialize-cwd))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; working directory per thread
-(make-process-resource 
- initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned*
- process-cwd process-chdir string=?)
 
 (initialize-cwd)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; umask per thread
+(define *umask-cache* 'uninitialized)
+(define umask-lock (make-lock))
+
+(define (initialize-umask)
+  (set! *umask-cache* (process-umask))
+  (set! $umask ;;; TODO The old thread-fluid will remain
+	(make-preserved-thread-fluid
+	 (umask-cache))))
+;  (set! umask-lock (make-lock)))
+
+(define (umask-cache)
+  *umask-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the resource lock obtained
+(define (change-and-cache-umask new-umask)
+  (set-process-umask new-umask)
+  (set! *umask-cache* (process-umask)))
+
+;; The thread-specific umask: A thread fluid
+
+(define $umask 'empty-umask-value)
+
+(define (umask) (thread-fluid $umask))
+(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask))
+(define (let-umask new-umask thunk)
+  (let-thread-fluid $umask new-umask thunk))
+
+(define (with-umask* new-umask thunk)
+  (let ((changed-umask
+	 (with-lock umask-lock
+	   (lambda ()
+	     (change-and-cache-umask new-umask)
+	     (umask-cache)))))
+    (let-umask changed-umask thunk)))
+
+;; Align the value of the Unix umask with scsh's value.
+;; Since another thread could disalign, this call and
+;; any ensuring syscall that relies upon it should
+;; be "glued together" with the umask lock.
+
+(define (align-umask!)
+  (let ((thread-umask (umask)))
+    (if (not (= thread-umask (umask-cache)))
+	(change-and-cache-umask thread-umask))))
+
+(define (set-umask new-umask)
+  (with-lock umask-lock
+    (lambda ()
+      (change-and-cache-umask new-umask)
+      (thread-set-umask! (umask-cache)))))
+
+(define umask-resource (make-resource align-umask! umask-lock))
+
+;; example syscall
+;; (define (exported-delete-file fname)
+;;  (with-cwd-aligned (really-delete-file fname)))
+
+(define umask-reinitializer
+  (make-reinitializer (lambda () (warn "calling resumer") (initialize-umask))))
 
-(make-process-resource 
- initialize-umask umask thread-set-umask set-umask 
- with-umask* with-umask-aligned*
- process-umask set-process-umask =)
 
 (initialize-umask)
 
-(set-with-fs-context-aligned*! ; ensure S48 is aligned too
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ensure S48 is aligned too
+
+(set-with-fs-context-aligned*! 
  (lambda (thunk)
-   (with-cwd-aligned*
+   (with-resources-aligned (list cwd-resource umask-resource) thunk)))
-    (lambda ()
-      (with-umask-aligned*
-       thunk)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Environment per thread
+(define *env-cache* 'uninitialized)
+(define env-lock (make-lock))
+
+(define (install-env)
+  (set! *env-cache* (environ**-read))
+  (set! $env ;;; TODO The old thread-fluid will remain
+	(make-preserved-thread-fluid
+	 (env-cache))))
+;  (set! env-lock (make-lock)))
+
+(define (env-cache)
+  *env-cache*)
+
+;; Actually do the syscall and update the cache
+;; assumes the env lock obtained
+(define (change-and-cache-env env)
+  (environ**-set env)
+  (set! *env-cache* env))
+
+;; The thread-specific env: A thread fluid
+
+(define $env 'empty-env-value)
+
+(define (thread-read-env) (thread-fluid $env))
+(define (thread-set-env! res) (set-thread-fluid! $env res))
+(define (let-env res thunk)
+  (let-thread-fluid $env res thunk))
+
+(define (really-with-env* env thunk)
+  (with-lock env-lock
+    (lambda ()
+      (change-and-cache-env env)))
+  (let-env env thunk))
+
+;; Align the value of the Unix env with scsh's value.
+;; Since another thread could disalign, this call and
+;; any ensuring syscall that relies upon it should
+;; be "glued together" with the env lock.
+
+(define (align-env!)
+  (let ((res (thread-read-env)))
+    (if (not (env=? res (env-cache)))
+	(change-and-cache-env res))))
+
+(define (thread-change-env res)
+  (with-lock env-lock
+    (lambda ()
+      (change-and-cache-env res)
+      (thread-set-env! (env-cache)))))
+
+(define environ-resource (make-resource align-env! env-lock))
+
+;; example syscall
+;; (define (exported-delete-file fname)
+;;  (with-cwd-aligned (really-delete-file fname)))
+
+(define env-reinitializer
+  (make-reinitializer (lambda () (warn "calling resumer") (install-env))))
+
 
 (define-record env
       envvec
@@ -328,12 +424,8 @@
     (with-total-env* new-env thunk)))
 
 (define (with-total-env* alist thunk)
-  (with-env-internal* (make-env #f alist) thunk))
+  (really-with-env* (make-env #f alist) thunk))
 
-(make-process-resource install-env thread-read-env thread-set-env! 
-		       useless-set-env
-		       with-env-internal* with-env-aligned* 
-		       environ**-read environ**-set env=?)
 
 ;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
 ;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
@@ -418,12 +510,6 @@
 (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-aligned body ...)
-  (with-umask-aligned* (lambda () body ...)))
-
 (define-simple-syntax (with-umask mask . body)
   (with-umask* mask (lambda () . body)))
 
@@ -487,7 +573,7 @@
 	  (let ((fname (format #f template (number->string i))))
 	    (receive retvals (with-errno-handler
 			       ((errno data)
-				((errno/exist) #f))
+				((errno/exist errno/acces) #f))
 			       (maker fname))
 	      (if (car retvals) (apply values retvals)
 		  (loop (+ i 1)))))))))
@@ -855,13 +941,9 @@
 		    
 (define (exec/env prog env . arglist)
   (flush-all-ports)
-  (with-env-aligned* 
+  (with-resources-aligned (list environ-resource cwd-resource umask-resource)
    (lambda ()
-     (with-cwd-aligned*
+     (%exec prog (cons prog arglist) env))))
-      (lambda ()
-	(with-umask-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)) =>
@@ -875,11 +957,8 @@
 
 (define (exec-path/env prog env . arglist)
   (flush-all-ports)
-  (with-env-aligned*
+  (with-resources-aligned 
-   (lambda ()
+   (list environ-resource cwd-resource umask-resource)
-     (with-cwd-aligned*
-      (lambda ()
-	(with-umask-aligned*
    (lambda ()
      (let ((prog (stringify prog)))
        (if (string-index prog #\/)
@@ -894,7 +973,7 @@
 			   (%%exec binary argv env)))
 		       (thread-fluid 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))
@@ -958,7 +1037,8 @@
 	   ;; 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* 
+	   (let ((pid (with-resources-aligned 
+		       (list environ-resource)
 		       %%fork)))
 	     (if (zero? pid)				
 		 ;; Child

scsh/syscalls.scm

@@ -183,7 +183,8 @@
 ;;; ports.
 
 (define (generic-file-op thing fd-op fname-op)
-  (if (string? thing) (with-cwd-aligned (fname-op thing))
+  (if (string? thing) 
+      (with-resources-aligned (list cwd-resource) (lambda () (fname-op thing)))
       (call/fdes thing fd-op)))
 
 
@@ -340,7 +341,7 @@
 (import-os-error-syscall %delete-file (path) "scsh_unlink")
 
 (define (delete-file path)
-  (with-cwd-aligned (%delete-file path)))
+  (with-resources-aligned (list cwd-resource) (lambda () (%delete-file path))))
 
 (import-os-error-syscall %sync-file (fd) "scsh_fsync")
 
@@ -382,8 +383,9 @@
 (import-os-error-syscall %open (path flags mode) "scsh_open")
 
 (define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
-    (with-cwd-aligned
+    (with-resources-aligned 
-     (with-umask-aligned
+     (list cwd-resource umask-resource)
+     (lambda ()
       (%open path flags (:optional maybe-mode #o666)))))
 
 
@@ -532,7 +534,9 @@
 (import-os-error-syscall %open-dir (dir-name) "open_dir")
 
 (define (directory-files . args)
-  (with-cwd-aligned
+  (with-resources-aligned
+   (list cwd-resource)
+   (lambda ()
      (let-optionals args ((dir       ".")
 			  (dotfiles? #f))
        (check-arg string? dir directory-files)
@@ -540,7 +544,7 @@
 	      (files-sorted ((structure-ref sort sort-list!) files filename<=)))
 	 (if dotfiles? files-sorted
 	     (filter (lambda (f) (not (dotfile? f)))
-		  files-sorted))))))
+		     files-sorted)))))))
 
 (define (dotfile? f)
   (char=? (string-ref f 0) #\.))

scsh/utilities.scm

@@ -13,9 +13,6 @@
 		      '()))))
     (del lis)))
 
-(define (delete pred lis)
-  (filter (lambda (x) (not (pred x))) lis))
-
 (define (index str c . maybe-start)
   (let ((start (max 0 (:optional maybe-start 0)))
 	(len (string-length str)))
@@ -33,50 +30,6 @@
 	     (char=? c (string-ref str i)))
 	 (and (>= i 0) i)))))
 
-;;; (f (f (f zero x1) x2) x3)
-;;; [Richard's does (f x3 (f x2 (f x1 zero)))
-(define (reduce f zero l)
-  (letrec ((lp (lambda (val rest)
-		 (if (pair? rest) (lp (f val (car rest)) (cdr rest))
-		     val))))
-    (lp zero l)))
-
-(define (fold kons knil lis)
-  (let lp ((lis lis) (ans knil))
-    (if (pair? lis)
-	(lp (cdr lis) (kons (car lis) ans))
-	ans)))
-
-(define (fold-right kons knil lis)
-  (let recur ((lis lis))
-    (if (pair? lis)
-	(let ((head (car lis)))		; Won't need LIS after RECUR call. 
-	  (kons head (recur (cdr lis))))
-	knil)))
-				      
-(define (filter pred list)
-  (letrec ((filter (lambda (list)
-		     (if (pair? list)
-			 (let* ((head (car list))
-				(tail (cdr list))
-				(new-tail (filter tail)))
-			   (if (pred head)
-			       (if (eq? tail new-tail) list
-				   (cons head new-tail))
-			       new-tail))
-			 '()))))
-    (filter list)))
-
-(define (first pred list)
-  (letrec ((lp (lambda (list)
-		 (and (pair? list)
-		      (let ((head (car list)))
-			(if (pred head) head
-			    (lp (cdr list))))))))
-    (lp list)))
-
-(define any first)
-
 ;;; Returns the first true value produced by PRED, not the list element
 ;;; that satisfied PRED.
 
@@ -89,15 +42,6 @@
 
 (define any? first?)
 
-
-(define (every pred list)
-  (or (not (pair? list))	
-      (let lp ((head (car list))  (tail (cdr list)))
-	(if (pair? tail)
-	    (and (pred head) (lp (car tail) (cdr tail)))
-	    (pred head)))))		; Tail-call the last PRED call.
-
-
 (define (every? pred list)
   (letrec ((lp (lambda (list)
 		 (or (not (pair? list))
@@ -291,6 +235,16 @@
   (kill-thread! thread)
   (make-ready thread))
 
-  
+(define (obtain-all-or-none . locks)
+  (let lp ((obtained '()) (needed locks))
+    (if (not (null? needed))
+	(let ((next (car needed)))
+	  (if (maybe-obtain-lock next)
+	      (lp (cons next obtained)
+		  (cdr needed))
+	      (begin
+		(for-each release-lock obtained)
+		(obtain-lock next)
+		(lp (list next) (delete next locks eq?))))))))