scsh-0.6/scheme/rts/thread-env.scm

; 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)))))

; Handy utilities.

(define (fluid-cell-ref f)
  (cell-ref (fluid f)))

(define (fluid-cell-set! f value)
  (cell-set! (fluid f) value))

; 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!)