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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, David Frese, Mike Sperber
; String hash tables for managing three tables:
; the symbol table : string -> symbol
; exported-bindings : string -> shared-binding
; imported-bindings : string -> shared-binding
;
; The hash buckets are linked throught the symbol-next and shared-binding-next
; fields. The values in the links are converted to fixnums to prevent the GC
; from tracing them.
; Size of the hash vectors (is this a reasonable size?).
(define hash-table-slots 1024)
(define hash-table-size (vm-vector-size hash-table-slots))
; The various hash-table values all have their own link fields.
(define hash-table-entry-size 0)
(define (value->link value)
(assert (not (fixnum? value)))
(if (stob? value)
(descriptor->fixnum value)
value))
(define (link->value link)
(assert (or (false? link)
(fixnum? link)))
(if (fixnum? link)
(fixnum->stob link)
link))
(define (hash-table-ref table i)
(link->value (vm-vector-ref table i)))
(define (hash-table-index string)
(bitwise-and (vm-string-hash string)
(- hash-table-slots 1)))
; All buckets are initially false.
(define (make-hash-table+gc)
(let ((table (vm-make-vector+gc hash-table-slots)))
(natural-for-each (lambda (index)
(vm-vector-set! table index false))
hash-table-slots)
table))
; Return a procedure for adding FOO's to tables.
(define (table-adder foo-string set-foo-next!)
(lambda (table foo)
(let ((index (hash-table-index (foo-string foo))))
(set-foo-next! foo (vm-vector-ref table index))
(vm-vector-set! table index (value->link foo)))))
; Return a function for looking up strings in a Foo table. A new Foo is
; made if none is found.
(define (table-searcher foo-string foo-next make-foo)
(lambda (table string key)
(let* ((index (hash-table-index string))
(bucket (hash-table-ref table index)))
(let loop ((foo bucket))
(cond ((vm-eq? foo false)
(let ((new (make-foo string (value->link bucket) key)))
(vm-vector-set! table index (value->link new))
new))
((vm-string=? string (foo-string foo))
foo)
(else
(loop (link->value (foo-next foo)))))))))
; Same thing, except we remove the entry if it is found.
(define (table-remover foo-string foo-next set-foo-next!)
(lambda (table string)
(let* ((index (hash-table-index string))
(bucket (hash-table-ref table index)))
(let loop ((previous-foo false) (foo bucket))
(cond ((vm-eq? foo false)
(unspecific))
((not (vm-string=? string (foo-string foo)))
(loop foo (link->value (foo-next foo))))
((vm-eq? previous-foo false)
(vm-vector-set! table index (foo-next foo)))
(else
(set-foo-next! previous-foo (foo-next foo))))))))
; Return a procedure that will apply PROC to every element of TABLE.
(define (table-walker foo-next)
(lambda (proc table)
(natural-for-each (lambda (index)
(let loop ((entry (hash-table-ref table index)))
(if (not (vm-eq? entry false))
(begin
(proc entry)
(loop (link->value (foo-next entry)))))))
hash-table-slots)))
; Return a procedure that will apply PROC to every element of TABLE
; until PROC returns #f.
(define (table-while-walker foo-next)
(lambda (proc table)
(natural-for-each-while (lambda (index)
(let loop ((entry (hash-table-ref table index)))
(cond
((vm-eq? entry false) #t)
((not (proc entry)) #f)
(else
(loop (link->value (foo-next entry)))))))
hash-table-slots)))
; Copy a table, retaining all entries.
(define (table-tracer foo-next set-foo-next! trace-value)
(make-table-copier trace-value
(entry-tracer foo-next
set-foo-next!
trace-value)))
; Copy a table, dropping unreferenced entries.
(define (table-cleaner foo-next set-foo-next! extant? trace-value)
(make-table-copier trace-value
(entry-cleaner foo-next
set-foo-next!
extant?
trace-value)))
; Copy a table.
(define (make-table-copier trace-value entry-tracer)
(lambda (table)
(let ((table (trace-value table)))
(natural-for-each
(lambda (index)
(vm-vector-set! table
index
(entry-tracer (vm-vector-ref table index))))
hash-table-slots)
table)))
; Loop down a list of foos tracing all of them. We reverse the
; list in doing so.
(define (entry-tracer foo-next set-foo-next! trace-value)
(lambda (foo-link)
(let loop ((foo-link foo-link) (done-link false))
(let ((foo (link->value foo-link)))
(if (false? foo)
done-link
(let* ((new-foo (trace-value foo))
(next-link (foo-next new-foo)))
(set-foo-next! new-foo done-link)
(loop next-link
(value->link new-foo))))))))
; Loop down a list of foos removing any untraced ones. We reverse the
; list in doing so.
(define (entry-cleaner foo-next set-foo-next! extant? trace-value)
(lambda (foo-link)
(let loop ((foo-link foo-link) (okay-link false))
(let ((foo (link->value foo-link)))
(cond ((false? foo)
okay-link)
((extant? foo)
(let* ((new-foo (trace-value foo))
(next-link (foo-next new-foo)))
(set-foo-next! new-foo okay-link)
(loop next-link
(value->link new-foo))))
(else
(loop (foo-next foo)
okay-link)))))))
(define (relocate-table table relocate foo-next set-foo-next!)
(if (vm-vector? table)
(begin
(natural-for-each
(lambda (index)
(let ((bucket (hash-table-ref table index)))
(if (not (false? bucket))
(let ((bucket (relocate bucket)))
(vm-vector-set! table index (value->link bucket))
(let loop ((entry bucket))
(let ((next (link->value (foo-next entry))))
(if (not (false? next))
(let ((next (relocate next)))
(set-foo-next! entry (value->link next))
(loop next)))))))))
hash-table-slots)
(unspecific))))
|
