1;;; 5_6.ss
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16;;; vector and sorting functions
17
18(let ()
19(define ($vector->list v n)
20  (let loop ([i (fx- n 1)] [ls '()])
21    (if (fx> i 0)
22        (loop
23          (fx- i 2)
24          (list* (vector-ref v (fx- i 1)) (vector-ref v i) ls))
25        (if (fx= i 0) (cons (vector-ref v 0) ls) ls))))
26
27(define ($list->vector ls n)
28  (let ([v (make-vector n)])
29    (let loop ([ls ls] [i 0])
30      (unless (null? ls)
31        (vector-set! v i (car ls))
32        (let ([ls (cdr ls)])
33          (unless (null? ls)
34            (vector-set! v (fx+ i 1) (car ls))
35            (loop (cdr ls) (fx+ i 2))))))
36    v))
37
38(define ($vector-copy! v1 v2 n)
39  (if (fx<= n 10)
40      (let loop ([i (fx- n 1)])
41        (cond
42          [(fx> i 0)
43           (vector-set! v2 i (vector-ref v1 i))
44           (let ([i (fx- i 1)]) (vector-set! v2 i (vector-ref v1 i)))
45           (loop (fx- i 2))]
46          [(fx= i 0) (vector-set! v2 i (vector-ref v1 i))]))
47      ($ptr-copy! v1 (constant vector-data-disp) v2
48        (constant vector-data-disp) n)))
49
50(define ($vector-copy v1 n)
51  (let ([v2 (make-vector n)])
52    ($vector-copy! v1 v2 n)
53    v2))
54
55(set! vector->list
56  (lambda (v)
57    (unless (vector? v)
58      ($oops 'vector->list "~s is not a vector" v))
59    ($vector->list v (vector-length v))))
60
61(set! list->vector
62  (lambda (ls)
63    ($list->vector ls ($list-length ls 'list->vector))))
64
65(set! vector-copy
66  (lambda (v)
67    (unless (vector? v)
68      ($oops 'vector-copy "~s is not a vector" v))
69    ($vector-copy v (vector-length v))))
70
71(set-who! vector->immutable-vector
72  (lambda (v)
73    (cond
74      [(immutable-vector? v) v]
75      [(eqv? v '#()) (vector->immutable-vector '#())]
76      [else
77       (unless (vector? v) ($oops who "~s is not a vector" v))
78       (let ([v2 (vector-copy v)])
79         ($vector-set-immutable! v2)
80         v2)])))
81
82(set-who! vector-fill!
83  (lambda (v obj)
84    (unless (mutable-vector? v) ($oops who "~s is not a mutable vector" v))
85    (let ([n (vector-length v)])
86      (do ([i 0 (fx+ i 1)])
87          ((fx= i n))
88        (vector-set! v i obj)))))
89
90(set! fxvector->list
91  (lambda (v)
92    (unless (fxvector? v)
93      ($oops 'fxvector->list "~s is not an fxvector" v))
94    (let loop ([i (fx- (fxvector-length v) 1)] [l '()])
95      (if (fx> i 0)
96          (loop
97            (fx- i 2)
98            (list* (fxvector-ref v (fx- i 1)) (fxvector-ref v i) l))
99          (if (fx= i 0) (cons (fxvector-ref v 0) l) l)))))
100
101(set! list->fxvector
102  (lambda (x)
103    (let ([v (make-fxvector ($list-length x 'list->fxvector))])
104      (do ([ls x (cdr ls)] [i 0 (fx+ i 1)])
105          ((null? ls) v)
106        (let ([n (car ls)])
107          (unless (fixnum? n)
108            ($oops 'list->fxvector "~s is not a fixnum" n))
109          (fxvector-set! v i n))))))
110
111(set! fxvector-copy
112  (lambda (fxv1)
113    (unless (fxvector? fxv1)
114      ($oops 'fxvector-copy "~s is not an fxvector" fxv1))
115    (let ([n (fxvector-length fxv1)])
116      (let ([fxv2 (make-fxvector n)])
117        (if (fx<= n 10)
118            (let loop ([i (fx- n 1)])
119              (cond
120                [(fx> i 0)
121                 (fxvector-set! fxv2 i (fxvector-ref fxv1 i))
122                 (let ([i (fx- i 1)]) (fxvector-set! fxv2 i (fxvector-ref fxv1 i)))
123                 (loop (fx- i 2))]
124                [(fx= i 0) (fxvector-set! fxv2 i (fxvector-ref fxv1 i))]))
125            ($ptr-copy! fxv1 (constant fxvector-data-disp) fxv2
126              (constant fxvector-data-disp) n))
127        fxv2))))
128
129(set! flvector->list
130  (lambda (v)
131    (unless (flvector? v)
132      ($oops 'flvector->list "~s is not an flvector" v))
133    (let loop ([i (fx- (flvector-length v) 1)] [l '()])
134      (if (fx> i 0)
135          (loop
136            (fx- i 2)
137            (list* (flvector-ref v (fx- i 1)) (flvector-ref v i) l))
138          (if (fx= i 0) (cons (flvector-ref v 0) l) l)))))
139
140(set! list->flvector
141  (lambda (x)
142    (let ([v (make-flvector ($list-length x 'list->flvector))])
143      (do ([ls x (cdr ls)] [i 0 (fx+ i 1)])
144          ((null? ls) v)
145        (let ([n (car ls)])
146          (unless (flonum? n)
147            ($oops 'list->flvector "~s is not a flonum" n))
148          (flvector-set! v i n))))))
149
150(set! flvector-copy
151  (lambda (flv1)
152    (unless (flvector? flv1)
153      ($oops 'flvector-copy "~s is not an flvector" flv1))
154    (let ([n (flvector-length flv1)])
155      (let ([flv2 (make-flvector n)])
156        (if (fx<= n 10)
157            (let loop ([i (fx- n 1)])
158              (cond
159                [(fx> i 0)
160                 (flvector-set! flv2 i (flvector-ref flv1 i))
161                 (let ([i (fx- i 1)]) (flvector-set! flv2 i (flvector-ref flv1 i)))
162                 (loop (fx- i 2))]
163                [(fx= i 0) (flvector-set! flv2 i (flvector-ref flv1 i))]))
164            ($byte-copy! flv1 (constant flvector-data-disp) flv2
165              (constant flvector-data-disp) (fx* n (constant flonum-bytes))))
166        flv2))))
167
168(set! vector-map
169  (case-lambda
170    [(p v)
171     (unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
172     (unless (vector? v) ($oops 'vector-map "~s is not a vector" v))
173     (#3%vector-map p v)]
174    [(p u v)
175     (unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
176     (unless (vector? u) ($oops 'vector-map "~s is not a vector" u))
177     (unless (vector? v) ($oops 'vector-map "~s is not a vector" v))
178     (let ([n (vector-length u)])
179       (unless (fx= (vector-length v) n)
180         ($oops 'vector-map "lengths of input vectors ~s and ~s differ" u v))
181       (let f ([i (fx- n 1)])
182         (if (fx> i 0)
183             (let ([x1 (p (vector-ref u i) (vector-ref v i))]
184                   [x2 (let ([j (fx- i 1)])
185                         (p (vector-ref u j) (vector-ref v j)))])
186               (let ([vout (f (fx- i 2))])
187                 (vector-set! vout i x1)
188                 (vector-set! vout (fx- i 1) x2)
189                 vout))
190             (make-vector n
191               (if (fx= i 0)
192                   (p (vector-ref u 0) (vector-ref v 0))
193                   0)))))]
194    [(p u . v*)
195     (unless (procedure? p) ($oops 'vector-map "~s is not a procedure" p))
196     (unless (vector? u) ($oops 'vector-map "~s is not a vector" u))
197     (for-each (lambda (v) (unless (vector? v) ($oops 'vector-map "~s is not a vector" v))) v*)
198     (let ([n (vector-length u)])
199       (for-each
200         (lambda (v)
201           (unless (fx= (vector-length v) n)
202             ($oops 'vector-map "lengths of input vectors ~s and ~s differ" u v)))
203         v*)
204       (let f ([i (fx- n 1)])
205         (if (fx> i 0)
206             (let ([x1 (apply p
207                         (vector-ref u i)
208                         (map (lambda (v) (vector-ref v i)) v*))]
209                   [x2 (let ([j (fx- i 1)])
210                         (apply p
211                           (vector-ref u j)
212                           (map (lambda (v) (vector-ref v j)) v*)))])
213               (let ([vout (f (fx- i 2))])
214                 (vector-set! vout i x1)
215                 (vector-set! vout (fx- i 1) x2)
216                 vout))
217             (make-vector n
218               (if (fx= i 0)
219                   (apply p
220                     (vector-ref u 0)
221                     (map (lambda (v) (vector-ref v 0)) v*))
222                   0)))))]))
223
224(set! vector-for-each
225  (case-lambda
226    [(p v)
227     (unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
228     (unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))
229     (#3%vector-for-each p v)]
230    [(p u v)
231     (unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
232     (unless (vector? u) ($oops 'vector-for-each "~s is not a vector" u))
233     (unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))
234     (let ([n (vector-length u)])
235       (unless (fx= (vector-length v) n)
236         ($oops 'vector-for-each "lengths of input vectors ~s and ~s differ" u v))
237       (unless (fx= n 0)
238         (let loop ([i 0])
239           (let ([j (fx+ i 1)])
240             (if (fx= j n)
241                 (p (vector-ref u i) (vector-ref v i))
242                 (begin
243                   (p (vector-ref u i) (vector-ref v i))
244                   (loop j)))))))]
245    [(p u . v*)
246     (unless (procedure? p) ($oops 'vector-for-each "~s is not a procedure" p))
247     (unless (vector? u) ($oops 'vector-for-each "~s is not a vector" u))
248     (for-each (lambda (v) (unless (vector? v) ($oops 'vector-for-each "~s is not a vector" v))) v*)
249     (let ([n (vector-length u)])
250       (for-each
251         (lambda (v)
252           (unless (fx= (vector-length v) n)
253             ($oops 'vector-for-each "lengths of input vectors ~s and ~s differ" u v)))
254         v*)
255       (unless (fx= n 0)
256         (let loop ([i 0])
257           (let ([j (fx+ i 1)])
258             (if (fx= j n)
259                 (apply p (vector-ref u i) (map (lambda (v) (vector-ref v i)) v*))
260                 (begin
261                   (apply p (vector-ref u i) (map (lambda (v) (vector-ref v i)) v*))
262                   (loop j)))))))]))
263
264(let ()
265  (module (dovsort!)
266   ;; dovsort! is a modified version of Olin Shiver's code for opportunistic
267   ;; vector merge sort, based on a version found in the MzScheme Version 360
268   ;; source code, which contains the following copyright notice.
269
270   ;; This code is
271   ;;     Copyright (c) 1998 by Olin Shivers.
272   ;; The terms are: You may do as you please with this code, as long as
273   ;; you do not delete this notice or hold me responsible for any outcome
274   ;; related to its use.
275   ;;
276   ;; Blah blah blah. Don't you think source files should contain more lines
277   ;; of code than copyright notice?
278
279   ;; This merge sort is "opportunistic" -- the leaves of the merge tree are
280   ;; contiguous runs of already sorted elements in the vector. In the best
281   ;; case -- an already sorted vector -- it runs in linear time. Worst case
282   ;; is still O(n lg n) time.
283
284   ;; RKD: performance is a bit worse on average than a straightforward
285   ;; merge-sort for random input vectors, but speed for sorted or mostly
286   ;; sorted vectors is much better.
287
288   ;; RKD: The following issues with the original code have been addressed:
289   ;;  - tail-len is bound but not used.
290   ;;  - len is computed before it is known to be needed; it would be
291   ;;    (marginally) better to remove the binding for len and replace
292   ;;    (= pfxlen len) with (= pfxlen (- r l)).
293   ;;  - In the %vector-merge-sort! loop computing pfxlen2, (fx<= j pfxlen)
294   ;;    should be (fx<= j*2 pfxlen); otherwise pfxlen2 is actually the first
295   ;;    power of two greater than pfxlen.  Fixing this improved performance by
296   ;;    about 20% for sort using predicate < for a list of 10^6 random
297   ;;    integers between 0 and 1000.  (pfxlen2 computation later flushed
298   ;;    entirely; just using pfxlen, which is simpler and usually faster.)
299   ;;  - The temp need not be a copy of the input vector, just a vector of
300   ;;    the appropriate length.
301    (define (merge elt< target v1 v2 l len1 len2)
302     ; assumes target != v1, but v2 may be v1 or target
303     ; merge v1[l,l+len1-1] and v2[l+len1,l+len1+len2-1] into target[l,l+len1+len2-1]
304      (let* ([r1 (fx+ l len1)] [r2 (fx+ r1 len2)])
305        (let lp ([i l] [j l] [x (vector-ref v1 l)] [k r1] [y (vector-ref v2 r1)])
306          (if (elt< y x)
307              (let ([k (fx+ k 1)])
308                (vector-set! target i y)
309                (if (fx< k r2)
310                    (lp (fx+ i 1) j x k (vector-ref v2 k))
311                    (vblit v1 j target (fx+ i 1) r1)))
312              (let ([j (fx+ j 1)])
313                (vector-set! target i x)
314                (if (fx< j r1)
315                    (lp (fx+ i 1) j (vector-ref v1 j) k y)
316                    (unless (eq? v2 target)
317                      (vblit v2 k target (fx+ i 1) r2))))))))
318    (define (vblit fromv j tov i n)
319      (let lp ([j j] [i i])
320        (vector-set! tov i (vector-ref fromv j))
321        (let ([j (fx+ j 1)])
322          (unless (fx= j n) (lp j (fx+ i 1))))))
323    (define (getrun elt< v l r) ; assumes l < r
324      (let lp ([i (fx+ l 1)] [x (vector-ref v l)])
325        (if (fx= i r)
326            (fx- i l)
327            (let ([y (vector-ref v i)])
328              (if (elt< y x) (fx- i l) (lp (fx+ i 1) y))))))
329    (define (dovsort! elt< v0 n)
330      (let ([temp0 (make-vector n)])
331        (define (recur l want)
332         ; sort v0[l,l+len-1] for some len where 0 < want <= len <= (n-l).
333         ; that is, sort *at least* want elements in v0 starting at index l.
334         ; may put the result into either v0[l,l+len-1] or temp0[l,l+len-1].
335         ; does not alter either vector outside this range.  returns two
336         ; values: the number of values sorted and the vector holding the
337         ; sorted values.
338          (let lp ([pfxlen (getrun elt< v0 l n)] [v v0] [temp temp0])
339           ; v[l,l+pfxlen-1] holds a sorted version of v0[l,l+pfxlen-1]
340            (if (or (fx>= pfxlen want) (fx= pfxlen (fx- n l)))
341                (values pfxlen v)
342                (let-values ([(outlen outvec) (recur (fx+ l pfxlen) pfxlen)])
343                  (merge elt< temp v outvec l pfxlen outlen)
344                  (lp (fx+ pfxlen outlen) temp v)))))
345       ; return v0 or temp0 containing sorted values
346        (let-values ([(outlen outvec) (recur 0 n)]) outvec))))
347
348  (define (dolsort elt< ls n)
349    (cond
350      [(fx= n 1) (cons (car ls) '())]
351      [(fx= n 2)
352       (let ([x (car ls)] [y (cadr ls)])
353         (if (elt< y x) (list y x) (list x y)))]
354      [else
355       (let ([i (fxsrl n 1)])
356         (dolmerge elt<
357           (dolsort elt< ls i)
358           (dolsort elt< (list-tail ls i) (fx- n i))))]))
359
360  (define (dolmerge elt< ls1 ls2)
361    (cond
362      [(null? ls1) ls2]
363      [(null? ls2) ls1]
364      [(elt< (car ls2) (car ls1))
365       (cons (car ls2) (dolmerge elt< ls1 (cdr ls2)))]
366      [else (cons (car ls1) (dolmerge elt< (cdr ls1) ls2))]))
367
368   (define (dolsort! elt< ls n loc)
369     (if (fx= n 1)
370         (begin (set-cdr! ls '()) ls)
371         (let ([i (fxsrl n 1)])
372           (let ([tail (list-tail ls i)])
373             (dolmerge! elt<
374               (dolsort! elt< ls i loc)
375               (dolsort! elt< tail (fx- n i) loc)
376               loc)))))
377
378   (define (dolmerge! elt< ls1 ls2 loc)
379     (let loop ([ls1 ls1] [ls2 ls2] [loc loc])
380       (cond
381         [(null? ls1) (set-cdr! loc ls2)]
382         [(null? ls2) (set-cdr! loc ls1)]
383         [(elt< (car ls2) (car ls1))
384          (set-cdr! loc ls2)
385          (loop ls1 (cdr ls2) ls2)]
386         [else (set-cdr! loc ls1) (loop (cdr ls1) ls2 ls1)]))
387     (cdr loc))
388
389  (set-who! vector-sort
390    (lambda (elt< v)
391      (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
392      (unless (vector? v) ($oops who "~s is not a vector" v))
393      (let ([n (vector-length v)])
394        (if (fx<= n 1) v (dovsort! elt< ($vector-copy v n) n)))))
395
396  (set-who! vector-sort!
397    (lambda (elt< v)
398      (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
399      (unless (mutable-vector? v) ($oops who "~s is not a mutable vector" v))
400      (let ([n (vector-length v)])
401        (unless (fx<= n 1)
402          (let ([outvec (dovsort! elt< v n)])
403            (unless (eq? outvec v)
404              ($vector-copy! outvec v n)))))))
405
406  (set-who! list-sort
407    (lambda (elt< ls)
408      (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
409      (let ([n ($list-length ls who)])
410        (if (fx< n 25)
411            (if (fx<= n 1) ls (dolsort elt< ls n))
412            ($vector->list (dovsort! elt< ($list->vector ls n) n) n)))))
413
414  (set-who! sort
415    (lambda (elt< ls)
416      (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
417      (let ([n ($list-length ls who)])
418        (if (fx< n 25)
419            (if (fx<= n 1) ls (dolsort elt< ls n))
420            ($vector->list (dovsort! elt< ($list->vector ls n) n) n)))))
421
422  (set-who! merge
423    (lambda (elt< ls1 ls2)
424      (unless (procedure? elt<)
425        ($oops who "~s is not a procedure" elt<))
426      ($list-length ls1 who)
427      ($list-length ls2 who)
428      (dolmerge elt< ls1 ls2)))
429
430  (set-who! sort!
431    (lambda (elt< ls)
432      (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
433      (let ([n ($list-length ls who)])
434        (if (fx< n 25)
435            (if (fx<= n 1) ls (dolsort! elt< ls n (list '())))
436            (let ([v (dovsort! elt< ($list->vector ls n) n)])
437              (let loop ([ls ls] [i 0])
438                (unless (null? ls)
439                  (set-car! ls (vector-ref v i))
440                  (let ([ls (cdr ls)])
441                    (unless (null? ls)
442                      (set-car! ls (vector-ref v (fx+ i 1)))
443                      (loop (cdr ls) (fx+ i 2))))))
444              ls)))))
445
446  (set-who! merge!
447    (lambda (elt< ls1 ls2)
448      (unless (procedure? elt<)
449        ($oops who "~s is not a procedure" elt<))
450      ($list-length ls1 who)
451      ($list-length ls2 who)
452      (dolmerge! elt< ls1 ls2 (list '())))))
453)
454
455;; compiled with generate-interrupt-trap #f and optimize-level 3 so
456;; that stencil updates won't be interrupted by a GC while a newly
457;; allocated stencil is filled in
458(eval-when (compile)
459  (generate-interrupt-trap #f)
460  (optimize-level 3))
461
462(let ()
463  ;; Call with non-zero n
464  (define (stencil-vector-copy! to-v to-i from-v from-i n)
465    (cond
466     [(fx= n 1)
467      ($stencil-vector-set! to-v to-i (stencil-vector-ref from-v from-i))]
468     [else
469      ($stencil-vector-set! to-v to-i (stencil-vector-ref from-v from-i))
470      ($stencil-vector-set! to-v (fx+ to-i 1) (stencil-vector-ref from-v (fx+ from-i 1)))
471      (let ([n (fx- n 2)])
472        (unless (fx= n 0)
473          (stencil-vector-copy! to-v (fx+ to-i 2) from-v (fx+ from-i 2) n)))]))
474
475  (define (do-stencil-vector-update v mask remove-bits add-bits vals)
476    (let* ([new-n (fxpopcount (fxior (fx- mask remove-bits) add-bits))]
477           [new-v ($make-stencil-vector new-n (fxior (fx- mask remove-bits) add-bits))])
478      ;; `new-v` is not initialized, so don't let a GC happen until we're done filling it in
479      (let loop ([to-i 0] [from-i 0] [mask mask] [remove-bits remove-bits] [add-bits add-bits] [vals vals])
480        (unless (fx= to-i new-n)
481          (let* ([pre-remove-mask (fx- (fxxor remove-bits (fxand remove-bits (fx- remove-bits 1))) 1)]
482                 [pre-add-mask (fx- (fxxor add-bits (fxand add-bits (fx- add-bits 1))) 1)]
483                 [keep-mask (fxand mask pre-remove-mask pre-add-mask)]
484                 [kept-n (cond
485                          [(fx= 0 keep-mask) 0]
486                          [else
487                           (let ([keep-n (fxpopcount keep-mask)])
488                             (stencil-vector-copy! new-v to-i v from-i keep-n)
489                             keep-n)])])
490            (let ([to-i (fx+ to-i kept-n)]
491                  [from-i (fx+ from-i kept-n)]
492                  [mask (fx- mask keep-mask)])
493              (cond
494               [($fxu< pre-add-mask pre-remove-mask)
495                ;; an add bit happens before a remove bit
496                ($stencil-vector-set! new-v to-i (car vals))
497                (loop (fx+ to-i 1) from-i mask remove-bits (fx- add-bits (fx+ pre-add-mask 1)) (cdr vals))]
498               [else
499                ;; a remove bit happens before an add bit (or we're at the end)
500                (let ([remove-bit (fx+ pre-remove-mask 1)])
501                  (loop to-i (fx+ from-i 1) (fx- mask remove-bit) (fx- remove-bits remove-bit) add-bits vals))])))))
502      new-v))
503
504  (define (stencil-vector-replace-one v bit val)
505    (let* ([mask (stencil-vector-mask v)]
506           [n (fxpopcount mask)]
507           [new-v ($make-stencil-vector n mask)])
508      ;; `new-v` is not initialized, so don't let a GC happen until we're done filling it in
509      (stencil-vector-copy! new-v 0 v 0 n)
510      (let ([i (fxpopcount (fxand mask (fx- bit 1)))])
511        ($stencil-vector-set! new-v i val))
512      new-v))
513
514  (define (stencil-vector-replace-two v bits val1 val2)
515    (let* ([mask (stencil-vector-mask v)]
516           [n (fxpopcount mask)]
517           [new-v ($make-stencil-vector n mask)])
518      ;; `new-v` is not initialized, so don't let a GC happen until we're done filling it in
519      (stencil-vector-copy! new-v 0 v 0 n)
520      (let ([i1 (fxpopcount (fxand mask (fx- (fxxor bits (fxand bits (fx- bits 1))) 1)))])
521        ($stencil-vector-set! new-v i1 val1)
522        (let ([i2 (fxpopcount (fxand mask (fx- (fxand bits (fx- bits 1)) 1)))])
523          ($stencil-vector-set! new-v i2 val2)))
524      new-v))
525
526  (set-who! stencil-vector-mask-width (lambda () (constant stencil-vector-mask-bits)))
527
528  (set-who! stencil-vector-length
529    (lambda (v)
530      (unless (stencil-vector? v)
531        ($oops who "~s is not a stencil vector" v))
532      (fxpopcount (stencil-vector-mask v))))
533
534  (set-who! stencil-vector-ref
535    (lambda (v i)
536      (unless (stencil-vector? v)
537        ($oops who "~s is not a stencil vector" v))
538      (unless (and (fixnum? i)
539                   (fx< -1 i (fxpopcount (stencil-vector-mask v))))
540        ($oops who "invalid index ~s" i))
541      (#3%stencil-vector-ref v i)))
542
543  (set-who! stencil-vector-set!
544    (lambda (v i val)
545      (unless (stencil-vector? v)
546        ($oops who "~s is not a stencil vector" v))
547      (unless (and (fixnum? i)
548                   (fx< -1 i (fxpopcount (stencil-vector-mask v))))
549        ($oops who "invalid index ~s" i))
550      (#3%stencil-vector-set! v i val)))
551
552  (set-who! stencil-vector
553    (lambda (mask . vals)
554      (unless (and (fixnum? mask)
555                   (fx< -1 mask (fxsll 1 (constant stencil-vector-mask-bits))))
556        ($oops who "invalid mask ~s" mask))
557      (let ([n (fxpopcount mask)])
558        (unless (fx= (length vals) n)
559          ($oops who "mask ~s does not match given number of items ~s" mask (length vals)))
560        (let ([v ($make-stencil-vector n mask)])
561          ;; `new-v` is not initialized, so don't let a GC happen until we're done filling it in
562          (let loop ([i 0] [vals vals])
563            (unless (fx= i n)
564              ($stencil-vector-set! v i (car vals))
565              (loop (fx+ i 1) (cdr vals))))
566          v))))
567
568  (set-who! stencil-vector-update
569    (lambda (v remove-bits add-bits . vals)
570      (unless (stencil-vector? v)
571        ($oops who "~s is not a stencil vector" v))
572      (let ([mask (stencil-vector-mask v)])
573        (unless (and (fixnum? remove-bits)
574                     (fx< -1 remove-bits (fxsll 1 (constant stencil-vector-mask-bits))))
575          ($oops who "invalid removal mask ~s" remove-bits))
576        (unless (fx= remove-bits (fxand remove-bits mask))
577          ($oops who "stencil does not have all bits in ~s" remove-bits))
578        (unless (and (fixnum? add-bits)
579                     (fx< -1 add-bits (fxsll 1 (constant stencil-vector-mask-bits))))
580          ($oops who "invalid addition mask ~s" add-bits))
581        (unless (fx= 0 (fxand add-bits (fx- mask remove-bits)))
582          ($oops who "stencil already has bits in ~s" add-bits))
583        (unless (fx= (fxpopcount add-bits) (length vals))
584          ($oops who "addition mask ~s does not match given number of items ~s" add-bits (length vals)))
585        (do-stencil-vector-update v mask remove-bits add-bits vals))))
586
587  (set-who! stencil-vector-truncate!
588    (lambda (v new-mask)
589      (unless (stencil-vector? v)
590        ($oops who "~s is not a stencil vector" v))
591      (unless (and (fixnum? new-mask)
592                   (fx< -1 new-mask (fxsll 1 (constant stencil-vector-mask-bits))))
593        ($oops who "invalid mask ~s" new-mask))
594      (let ([old-mask (stencil-vector-mask v)])
595        (unless (fx<= (fxpopcount new-mask) (fxpopcount old-mask))
596          ($oops who "new mask ~s is larger than old mask ~s" new-mask old-mask))
597        (stencil-vector-truncate! v new-mask))))
598
599  ;; unsafe variant, which assumes that the arguments are consistent;
600  ;; recognize the case where all slots are replaced
601  (set-who! $stencil-vector-update
602    (case-lambda
603     [(v remove-bits add-bits x)
604      (let ([mask (stencil-vector-mask v)])
605        (cond
606         [(fx= 0 (fx- mask remove-bits))
607          ;; not using any data from `v`
608          (stencil-vector add-bits x)]
609         [(fx= add-bits remove-bits)
610          ;; updating one element of `v`:
611          (stencil-vector-replace-one v add-bits x)]
612         [else
613          (do-stencil-vector-update v mask remove-bits add-bits (list x))]))]
614     [(v remove-bits add-bits x y)
615      (let ([mask (stencil-vector-mask v)])
616        (cond
617         [(fx= 0 (fx- mask remove-bits))
618          ;; not using any data from `v`
619          (stencil-vector add-bits x y)]
620         [(fx= add-bits remove-bits)
621          ;; updating two elements of `v`:
622          (stencil-vector-replace-two v add-bits x y)]
623         [else
624          (do-stencil-vector-update v mask remove-bits add-bits (list x y))]))]
625     [(v remove-bits add-bits x y z)
626      (let ([mask (stencil-vector-mask v)])
627        (if (fx= 0 (fx- mask remove-bits))
628            (stencil-vector add-bits x y z)
629            (do-stencil-vector-update v mask remove-bits add-bits (list x y z))))]
630     [(v remove-bits add-bits . vals)
631      (do-stencil-vector-update v (stencil-vector-mask v) remove-bits add-bits vals)])))
632