Update of /cvsroot/scsh/scsh-0.6/scheme/rts
In directory usw-pr-cvs1:/tmp/cvs-serv3825/scheme/rts
Modified Files:
root-scheduler.scm scheduler.scm thread.scm
Added Files:
thread-env.scm
Removed Files:
fluid.scm
Log Message:
New implementation of (no-inheritance) thread-local cells and thread
fluids.
New implementation of syslog.
Both are to be compatible with what's actually probably going into
Scheme 48.
--- NEW FILE ---
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file fluid.scm.
; Fluid (dynamic) variables.
; Fluid variables are implemented using deep binding. This allows
; each thread in a multiprocessor system to have its own fluid
; environment, and allows for fast thread switching in a multitasking
; one.
; CURRENT-THREAD and SET-CURRENT-THREAD! access a special virtual
; machine register. On a multiprocessor, each processor would have
; its own current-thread register. The run-time system stores the
; current thread in this register.
; Here we define a particular thread record, but a different one is
; defined by the (uniprocessor) threads package. The current thread
; may actually be any kind of record as long as its first component
; can be used by the fluid variable implementation to maintain the
; deep-binding dynamic environment and its second component can be
; used by DYNAMIC-WIND. This is kind of gross but it is motivated by
; efficiency concerns.
(define-record-type thread :thread
(make-thread dynamic-env dynamic-point cell-env)
(dynamic-env thread-dynamic-env)
(dynamic-point thread-dynamic-point)
(cell-env thread-cell-env))
(define (get-dynamic-env)
(record-ref (current-thread) 1))
(define (set-dynamic-env! env)
(record-set! (current-thread) 1 env))
; The dynamic-wind point used to be just an ordinary fluid variable, but that
; doesn't work well with threads.
(define (get-dynamic-point)
(record-ref (current-thread) 2))
(define (set-dynamic-point! point)
(record-set! (current-thread) 2 point))
;----------------
; Dynamic environment
; A dynamic environment is an alist where the cars are fluid records.
(define (with-dynamic-env env thunk)
(let ((saved-env (get-dynamic-env)))
(set-dynamic-env! env)
(set! env #f) ;For GC and debugger
(call-with-values
;; thunk
(let ((x thunk)) (set! thunk #f) x) ;For GC
(lambda results
(set-dynamic-env! saved-env)
(apply values results)))))
(define (empty-dynamic-env) '())
; Each fluid has a top-level value that is used when the fluid is unbound
; in the current dynamic environment.
(define-record-type fluid :fluid
(make-fluid top)
(top fluid-top-level-value set-fluid-top-level-value!))
(define (fluid f)
(let ((probe (assq f (get-dynamic-env))))
(if probe (cdr probe) (fluid-top-level-value f))))
; Deprecated.
(define (set-fluid! f val)
(let ((probe (assq f (get-dynamic-env))))
(if probe (set-cdr! probe val) (set-fluid-top-level-value! f val))))
(define (let-fluid f val thunk)
(with-dynamic-env (cons (cons f val) (get-dynamic-env)) thunk))
(define (let-fluids . args)
(let loop ((args args)
(env (get-dynamic-env)))
(if (null? (cdr args))
(with-dynamic-env env (car args))
(loop (cddr args)
(cons (cons (car args) (cadr args)) env)))))
; Thread cells
(define-record-type thread-cell :thread-cell
(make-thread-cell default)
(default thread-cell-default))
(define (get-thread-cell-env)
(record-ref (current-thread) 3))
(define (set-thread-cell-env! value)
(record-set! (current-thread) 3 value))
(define (empty-thread-cell-env) '())
(define (thread-cell-ref thread-cell)
(let ((probe (assq thread-cell (get-thread-cell-env))))
(if probe
(cdr probe)
(thread-cell-default thread-cell))))
(define (thread-cell-set! thread-cell value)
(let ((probe (assq thread-cell (get-thread-cell-env))))
(if probe
(set-cdr! probe value)
(set-thread-cell-env! (cons (cons thread-cell
value)
(get-thread-cell-env))))))
; Initialize
(define (initialize-dynamic-state!)
(set-current-thread!
(make-thread (empty-dynamic-env) #f (empty-thread-cell-env))))
(initialize-dynamic-state!)
Index: root-scheduler.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/rts/root-scheduler.scm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -r1.4 -r1.5
*** root-scheduler.scm 2001/05/22 14:58:15 1.4
--- root-scheduler.scm 2001/12/03 15:21:45 1.5
***************
*** 31,35 ****
(thread (make-thread thunk
(get-dynamic-env)
- (get-cell-values)
'scheduler-initial-thread)))
(increment-counter! thread-count)
--- 31,34 ----
Index: scheduler.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/rts/scheduler.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** scheduler.scm 2001/05/22 14:58:15 1.2
--- scheduler.scm 2001/12/03 15:21:45 1.3
***************
*** 101,106 ****
(make-thread (car event-data)
dynamic-env
! (cadr event-data)
! (caddr event-data))))
((no-event)
(values))
--- 101,105 ----
(make-thread (car event-data)
dynamic-env
! (cadr event-data))))
((no-event)
(values))
Index: thread.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scheme/rts/thread.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** thread.scm 2001/11/08 10:24:41 1.5
--- thread.scm 2001/12/03 15:21:45 1.6
***************
*** 40,45 ****
(define-record-type thread :thread
! (really-make-thread dynamic-env dynamic-point
! cell-values own-cell-values?
continuation scheduler
queues arguments
--- 40,44 ----
(define-record-type thread :thread
! (really-make-thread dynamic-env dynamic-point cell-env
continuation scheduler
queues arguments
***************
*** 49,57 ****
(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!)
(queues thread-queues set-thread-queues!)
--- 48,52 ----
(dynamic-point thread-dynamic-point set-thread-dynamic-point!)
;Must be second! (See fluid.scm)
! (cell-env thread-cell-env) ;Must be fourth! (See thread-env.scm)
(continuation thread-continuation set-thread-continuation!)
(queues thread-queues set-thread-queues!)
***************
*** 76,84 ****
(define *thread-uid* 0)
! (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))
--- 71,78 ----
(define *thread-uid* 0)
! (define (make-thread thunk dynamic-env name)
(let ((thread (really-make-thread dynamic-env
#f ; dynamic-point root
! (empty-thread-cell-env)
(thunk->continuation
(thread-top-level thunk))
***************
*** 577,603 ****
(define (spawn thunk . id)
! (set-thread-own-values?! (current-thread) #f)
! (apply spawn-on-scheduler
! (thread-scheduler (current-thread))
! thunk
! (thread-cell-values (current-thread))
! id))
(define (spawn-on-root thunk . id)
(if (root-scheduler)
! (begin
! (set-thread-own-values?! (current-thread) #f)
! (apply spawn-on-scheduler
! (root-scheduler)
! thunk
! (thread-cell-values (current-thread))
! id))
(thunk)))
! (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))))
--- 571,588 ----
(define (spawn thunk . id)
! (apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id))
(define (spawn-on-root thunk . id)
(if (root-scheduler)
! (apply spawn-on-scheduler
! (root-scheduler)
! thunk
! id)
(thunk)))
! (define (spawn-on-scheduler scheduler thunk . id)
(schedule-event scheduler
(enum event-type spawned)
thunk
(if (null? id) #f (car id))))
***************
*** 667,671 ****
(let ((thread (make-thread #f ; thunk
(get-dynamic-env)
- (get-cell-values)
'initial-thread)))
(set-thread-scheduler! thread #f)
--- 652,655 ----
--- fluid.scm DELETED ---
|