1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
; 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!)
|
