added env and cwd per thread

scsh/scsh.scm

@@ -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)
+;(define (with-env* alist-delta thunk)
-  (let* ((old-env #f)
+;  (let* ((old-env #f)
-	 (new-env (fold (lambda (key/val alist)
+;	 (new-env (fold (lambda (key/val alist)
-			  (alist-update (car key/val) (cdr key/val) alist))
+;			  (alist-update (car key/val) (cdr key/val) alist))
-			(env->alist)
+;			(env->alist)
-			alist-delta)))
+;			alist-delta)))
-    (dynamic-wind
+;    (dynamic-wind
-      (lambda ()
+;      (lambda ()
-	(set! old-env (env->alist))
+;	(set! old-env (env->alist))
-	(alist->env new-env))
+;	(alist->env new-env))
-      thunk
+;      thunk
-      (lambda ()
+;      (lambda ()
-	(set! new-env (env->alist))
+;	(set! new-env (env->alist))
-	(alist->env old-env)))))
+;	(alist->env old-env)))))
 
-(define (with-total-env* alist thunk)
+;(define (with-total-env* alist thunk)
-  (let ((old-env (env->alist)))
+;  (let ((old-env (env->alist)))
-    (dynamic-wind
+;    (dynamic-wind
-      (lambda ()
+;      (lambda ()
-	(set! old-env (env->alist))
+;	(set! old-env (env->alist))
-	(alist->env alist))
+;	(alist->env alist))
-      thunk
+;      thunk
-      (lambda ()
+;      (lambda ()
-	(set! alist (env->alist))
+;	(set! alist (env->alist))
-	(alist->env old-env)))))
+;	(alist->env old-env)))))
 
 
-(define (with-cwd* dir thunk)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  (let ((old-wd #f))
+;;; working directory per thread
-    (dynamic-wind
+(define unix-cwd "")   ; Initialise the cache to an impossible filename.
-      (lambda ()
-	(set! old-wd (cwd))
-	(chdir dir))
-      thunk
-      (lambda ()
-	(set! dir (cwd))
-	(chdir old-wd)))))
 
+(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,21 +783,23 @@
 
 (define (exec-path/env prog env . arglist)
   (flush-all-ports)
-  (let ((prog (stringify prog)))
+  (with-env-aligned*
-    (if (string-index prog #\/)
+   (lambda ()
-
+     (let ((prog (stringify prog)))
-	;; Contains a slash -- no path search.
+       (if (string-index prog #\/)
-	(%exec prog (cons prog arglist) env)
+	   
-
+	   ;; Contains a slash -- no path search.
+	   (%exec prog (cons prog arglist) env)
+	   
 	;; Try each directory in PATH-LIST.
-	(let ((argv (list->vector (cons prog (map stringify arglist)))))
+	   (let ((argv (list->vector (cons prog (map stringify arglist)))))
-	  (for-each (lambda (dir)
+	     (for-each (lambda (dir)
-		      (let ((binary (string-append dir "/" prog)))
+			 (let ((binary (string-append dir "/" prog)))
-			(%%exec/errno binary argv env)))
+			   (%%exec/errno binary argv env)))
-		    exec-path-list))))
+		       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!)
+;  (init-fdports!)
-  (%install-unix-scsh-handlers))
+;  (%install-unix-scsh-handlers)
+)
 
 
 ;;; Some globals:
@@ -763,3 +876,4 @@
 
 ; SIGTSTP blows s48 away. ???
 (define (suspend) (signal-process 0 signal/stop))
+