Added thread-cells structure for thread-local cells.

These can be used (together with fluids) to implement something akin
to PLT's and Chez's parameters for holding thread-local state such as
CWD, syslog channel, etc.

build/filenames.make

@@ -1,6 +1,6 @@
 #### This file was generated automatically. ####
 
-initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm 
+initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/thread-cell.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/sigevents.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm 
 
 usual-files = scheme/opt/analyze.scm scheme/env/disclosers.scm scheme/env/command-level.scm scheme/env/version-info.scm scheme/env/command.scm scheme/env/read-command.scm scheme/env/debuginfo.scm scheme/rts/xnum.scm scheme/rts/bignum.scm scheme/rts/ratnum.scm scheme/rts/recnum.scm scheme/rts/innum.scm scheme/env/basic-command.scm scheme/env/build.scm scheme/env/shadow.scm scheme/env/pedit.scm scheme/env/pacman.scm scheme/rts/time.scm scheme/env/debug.scm scheme/env/inspect.scm scheme/env/disasm.scm 
 

scheme/env/command-level.scm

@@ -168,8 +168,11 @@
 ; that when it is rescheduled after blocking it can be put on the correct
 ; run queue.
 
-(define (spawn-on-command-level level thunk id)    
+(define (spawn-on-command-level level thunk cell-values id)
-  (let ((thread (make-thread thunk (command-level-dynamic-env level) id)))
+  (let ((thread (make-thread thunk
+			     (command-level-dynamic-env level)
+			     cell-values
+			     id)))
     (set-thread-scheduler! thread (command-thread))
     (set-thread-data! thread level)
     (enqueue-thread! (command-level-queue level) thread)
@@ -181,6 +184,7 @@
 (define (spawn-repl-thread! level)
   (let ((thread (spawn-on-command-level level
 					(command-level-repl-thunk level)
+					(empty-cell-values)
 					'command-loop)))
     (set-command-level-repl-thread! level thread)))
 
@@ -353,7 +357,7 @@
     (lambda (event args)
       (enum-case event-type event
 	((spawned)
-	 (spawn-on-command-level level (car args) (cadr args))
+	 (spawn-on-command-level level (car args) (cadr args) (caddr args))
 	 #t)
 	((runnable)
 	 (let* ((thread (car args))

scheme/interfaces.scm

@@ -390,6 +390,16 @@
 	  really-string->number &really-string->number ;exactness argument
 	  string->integer))
 
+(define-interface thread-cells-interface
+  (export make-thread-cell
+	  thread-cell-ref
+	  thread-cell-set!))
+
+(define-interface thread-cells-internal-interface
+  (export get-cell-values
+	  empty-cell-values		; env/command-level.scm
+	  initialize-dynamic-state!))
+
 (define-interface fluids-interface
   (export make-fluid
 	  let-fluid
@@ -398,13 +408,13 @@
 	  set-fluid!))
 
 (define-interface fluids-internal-interface
-  (export initialize-dynamic-state!
+  (export current-thread
-	  current-thread
 	  set-current-thread!
 	  get-dynamic-env		; wind.scm, env/command-level.scm
 	  set-dynamic-env!		; wind.scm
 	  get-dynamic-point		; wind.scm
-	  set-dynamic-point!))		; wind.scm
+	  set-dynamic-point!		; wind.scm
+	  empty-dynamic-env))		; thread-cell.scm
 
 (define-interface enumerated-interface
   (export (define-enumeration :syntax)

scheme/more-packages.scm

@@ -72,6 +72,7 @@
 	util                    ; unspecific
 	channel-i/o             ; steal-channel-port
 	fluids-internal         ; get-dynamic-env, set-dynamic-env!
+	thread-cells-internal	; empty-cell-values
 	root-scheduler          ; call-when-deadlocked!
 	conditions)             ; define-condition-type
   (files (env command-level)))

scheme/packages.scm

@@ -272,6 +272,7 @@
 	    scheme-level-1
 	    scheme-level-2
 	    templates
+	    thread-cells
 	    threads
 	    threads-internal
 	    util
@@ -301,6 +302,7 @@
 	    records-internal
 	    root-scheduler
 	    session-data
+	    thread-cells-internal
 	    usual-resumer
 	    ;; silly
 	    ;; structure-refs

scheme/rts-packages.scm

@@ -53,6 +53,12 @@
   (files (rts fluid))
   (optimize auto-integrate))
 
+(define-structures ((thread-cells thread-cells-interface)
+		    (thread-cells-internal thread-cells-internal-interface))
+  (open scheme-level-1 define-record-types primitives fluids-internal)
+  (files (rts thread-cell))
+  (optimize auto-integrate))
+
 (define-structure wind wind-interface
   (open scheme-level-1 signals define-record-types
 	fluids fluids-internal
@@ -238,6 +244,7 @@
         wind
         fluids
 	fluids-internal         ;get-dynamic-env
+	thread-cells-internal	;get-cell-values
         escapes                 ;primitive-cwcc
         conditions              ;error?
         handle                  ;with-handler
@@ -252,7 +259,8 @@
   (files (rts thread) (rts sleep)))
 
 (define-structure scheduler scheduler-interface
-  (open scheme-level-1 threads threads-internal enumerated enum-case
+  (open scheme-level-1 threads threads-internal thread-cells-internal
+	enumerated enum-case
 	debug-messages
 	signals)       		;error
   (files (rts scheduler)))
@@ -270,6 +278,7 @@
 	writing			;display
 	i/o-internal            ;output-port-forcer, output-forcer-id
 	fluids-internal         ;get-dynamic-env
+	thread-cells-internal	;get-cell-values
 	interrupts              ;with-interrupts-inhibited
 	wind                    ;call-with-current-continuation
 	channel-i/o		;waiting-for-i/o?
@@ -318,7 +327,7 @@
 	i/o		 ;initialize-i/o, etc.
 	channel-i/o      ;{in,out}put-channel->port, initialize-channel-i/o
 	session-data     ;initialize-session-data!
-	fluids-internal	 ;initialize-dynamic-state!
+	thread-cells-internal	 ;initialize-dynamic-state!
 	exceptions	 ;initialize-exceptions!
 	interrupts	 ;initialize-interrupts!
 	sigevents-internal  ;initialize-sigevents!

scheme/rts/fluid.scm

@@ -27,6 +27,14 @@
   (dynamic-env thread-dynamic-env)
   (dynamic-point thread-dynamic-point))
 
+;; (define *dynamic-env* (make-thread-cell (empty-dynamic-env)))
+;; 
+;; (define (get-dynamic-env)
+;;   (thread-cell-ref *dynamic-env*))
+;; 
+;; (define (set-dynamic-env! env)
+;;   (thread-cell-set! *dynamic-env* env))
+
 (define (get-dynamic-env)
   (record-ref (current-thread) 1))
 
@@ -42,9 +50,6 @@
 (define (set-dynamic-point! point)
   (record-set! (current-thread) 2 point))
 
-(define (initialize-dynamic-state!)
-  (set-current-thread! (make-thread (empty-dynamic-env) #f)))
-
 ;----------------
 ; Dynamic environment
 ; A dynamic environment is an alist where the cars are fluid records.
@@ -87,8 +92,3 @@
 	(with-dynamic-env env (car args))
 	(loop (cddr args)
 	      (cons (cons (car args) (cadr args)) env)))))
-
-; Initialize
-
-(initialize-dynamic-state!)
-

scheme/rts/root-scheduler.scm

@@ -30,6 +30,7 @@
 	(safe-dynamic-env (with-handler root-handler get-dynamic-env))
 	(thread (make-thread thunk
 			     (get-dynamic-env)
+			     (get-cell-values)
 			     'scheduler-initial-thread)))
     (increment-counter! thread-count)
     (enqueue-thread! runnable thread)

scheme/rts/scheduler.scm

@@ -100,7 +100,8 @@
 	   (enqueue-thread! runnable
 			    (make-thread (car event-data)
 					 dynamic-env
-					 (cadr event-data))))
+					 (cadr event-data)
+					 (caddr event-data))))
 	  ((no-event)
 	   (values))
 	  (else

scheme/rts/thread-cell.scm

@@ -0,0 +1,74 @@
+; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define-record-type thread :thread
+  (make-thread dynamic-env dynamic-point
+	       cell-values own-cell-values?)
+  (dynamic-env   thread-dynamic-env)
+  (dynamic-point thread-dynamic-point)
+  (cell-values    thread-cell-values set-thread-cell-values!)
+  (own-cell-values? thread-own-cell-values? set-thread-own-values?!))
+
+(define (empty-cell-values) '())
+
+(define (get-cell-values)
+  (record-ref (current-thread) 3))
+
+(define (set-cell-values! values)
+  (record-set! (current-thread) 3 values))
+
+(define (get-own-cell-values?)
+  (record-ref (current-thread) 4))
+
+(define (set-own-cell-values? own-values?)
+  (record-set! (current-thread) 4 own-values?))
+
+(define-record-type thread-cell :thread-cell
+  (make-thread-cell top)
+  (top thread-cell-top-level-value set-thread-cell-top-level-value!))
+
+(define (thread-cell-ref thread-cell)
+  (cond
+   ((assq thread-cell (get-cell-values)) => cdr)
+   (else (thread-cell-top-level-value thread-cell))))
+
+(define (thread-cell-set! thread-cell val)
+  (cond
+   ;; This might benefit from reordering: if we don't have a binding
+   ;; here, it's safe to set cell-values regardless of the setting of
+   ;; OWN-CELL-VALUES?.  On the other hand, this may mean we copy too
+   ;; much when push comes to shove; probably best to store the
+   ;; original CELL-VALUES instead of OWN-CELL-VALUES?.
+   ((not (get-own-cell-values?))
+    (let loop ((values (get-cell-values))
+	       (rev-new-values '())
+	       (found? #f))
+      (cond
+       ((null? values)
+	(set-cell-values! (if found?
+			      (reverse rev-new-values)
+			      (cons (cons thread-cell val)
+				    (reverse rev-new-values))))
+	(set-own-cell-values? #t))
+       ((eq? thread-cell (caar values))
+	(loop (cdr values)
+	      (cons (cons (caar values) val)
+		    rev-new-values)
+	      #t))
+       (else
+	(loop (cdr values)
+	      (cons (cons (caar values) (cdar values))
+		    rev-new-values)
+	      found?)))))
+   ((assq thread-cell (get-cell-values))
+    => (lambda (pair)
+	 (set-cdr! pair val)))
+   (else
+    (set-cell-values! (cons (cons thread-cell val)
+			    (get-cell-values))))))
+
+(define (initialize-dynamic-state!)
+  (set-current-thread! (make-thread (empty-dynamic-env) #f
+				    (empty-cell-values) #t)))
+
+
+(initialize-dynamic-state!)

scheme/rts/thread.scm

@@ -39,13 +39,20 @@
 ; the list is spliced back together and eN's continuation is resumed.
 
 (define-record-type thread :thread
-  (really-make-thread dynamic-env dynamic-point continuation scheduler
+  (really-make-thread dynamic-env dynamic-point
+		      cell-values own-cell-values?
+		      continuation scheduler
 		      queue arguments
 		      events current-task uid name)
   thread?
   (dynamic-env    thread-dynamic-env)   ;Must be first!  (See fluid.scm)
   (dynamic-point  thread-dynamic-point set-thread-dynamic-point!)
   					;Must be second!  (See fluid.scm)
+
+					;Must be third! (See thread-cell.scm)
+  (cell-values    thread-cell-values set-thread-cell-values!)
+					;Must be fourth! (See thread-cell.scm)
+  (own-cell-values? thread-own-cell-values? set-thread-own-values?!)
   (continuation   thread-continuation set-thread-continuation!)
   (queue          thread-queue set-thread-queue!)
   (arguments      thread-arguments set-thread-arguments!)
@@ -68,9 +75,11 @@
 
 (define *thread-uid* 0)
 
-(define (make-thread thunk dynamic-env name)
+(define (make-thread thunk dynamic-env cell-values name)
   (let ((thread (really-make-thread dynamic-env
 				    #f               ; dynamic-point root
+				    cell-values
+				    #f		     ; own-cell-values?
 				    (thunk->continuation
 				     (thread-top-level thunk))
 				    (current-thread) ; scheduler
@@ -540,20 +549,26 @@
 ; scheduler.
 
 (define (spawn thunk . id)
-  (apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id))
+  (apply spawn-on-scheduler
+	 (thread-scheduler (current-thread))
+	 thunk
+	 (thread-cell-values (current-thread))
+	 id))
 
 (define (spawn-on-root thunk . id)
   (if (root-scheduler)
       (apply spawn-on-scheduler
 	     (root-scheduler)
 	     thunk
+	     (thread-cell-values (current-thread))
 	     id)
       (thunk)))
 
-(define (spawn-on-scheduler scheduler thunk . id)
+(define (spawn-on-scheduler scheduler thunk cell-values . id)
   (schedule-event scheduler
 		  (enum event-type spawned)
 		  thunk
+		  cell-values
 		  (if (null? id) #f (car id))))
 
 ; Enqueue a RUNNABLE for THREAD's scheduler.
@@ -621,6 +636,7 @@
 		 (set! *thread-uid* 0)
 		 (let ((thread (make-thread #f    ; thunk
 					    (get-dynamic-env)
+					    (get-cell-values)
 					    'initial-thread)))
 		   (set-thread-scheduler! thread #f)
 		   (set-thread-time! thread #f)