suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove old implementation of compute-size-increments

Browse Source 
The old implementation is replaced by the new mkgc.ss-based
implemented.

original commit: 7a8eaf81df0dd52cde58ed51f5210b9398cb8bb6
This commit is contained in:
Matthew Flatt 2020-04-04 10:18:54 -06:00
parent afebbdd6a9
commit 45b618c4c1
5 changed files with 41 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
s/Mf-base
View File

@ -164,7 +164,7 @@ macroobj =\
allsrc =\ allsrc =\
${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\ ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\
base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\ base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\
np-languages.ss bitset.ss fxmap.ss np-languages.ss fxmap.ss
# doit uses a different Scheme process to compile each target # doit uses a different Scheme process to compile each target
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision} doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cvfasl} ${Revision}
@ -580,7 +580,6 @@ setup.so: debug.ss
${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss
cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes} cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes}
5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss
inspect.$m: bitset.ss
${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss ${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
(if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi) (if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi)

73
s/bitset.ss
View File

@ -1,73 +0,0 @@
;; The eq-bitset implementation assumes that the addresses of an
;; object won't change, so only use an eq-bitset while interrupts are
;; disabled from start to end of the eq-bitset use. The eq-bitset
;; implementation also assumes that `$fxaddress` is a perfect hash for
;; a non-immediate object.
(define (make-eq-bitset)
(make-vector (fxsll 1 (constant eq-bitset-l1-bits)) #f))
(constant-case eq-bitset-l2-bits
[(0)
(define (get-l1 bm n)
(let* ([l1 (fxsrl n (constant eq-bitset-l1-shift))]
[bm1 (vector-ref bm l1)])
(or bm1
(let ([bm1 (make-fxvector (fxsll 1 (constant eq-bitset-l4-bits)) 0)])
(vector-set! bm l1 bm1)
bm1))))
(define (get-l2 bm1 n) bm1)
(define (get-l3 bm1 n) bm1)]
[else
(define (get-l1 bm n)
(let* ([l1 (fxsrl n (constant eq-bitset-l1-shift))]
[bm1 (vector-ref bm l1)])
(or bm1
(let ([bm1 (make-vector (fxsll 1 (constant eq-bitset-l2-bits)) #f)])
(vector-set! bm l1 bm1)
bm1))))
(define (get-l2 bm1 n)
(let* ([l2 (fxand (fxsrl n (constant eq-bitset-l2-shift))
(constant eq-bitset-l2-mask))]
[bm2 (vector-ref bm1 l2)])
(or bm2
(let ([bm2 (make-vector (fxsll 1 (constant eq-bitset-l3-bits)) #f)])
(vector-set! bm1 l2 bm2)
bm2))))
(define (get-l3 bm2 n)
(let* ([l3 (fxand (fxsrl n (constant eq-bitset-l3-shift))
(constant eq-bitset-l3-mask))]
[bm3 (vector-ref bm2 l3)])
(or bm3
(let ([bm3 (make-fxvector (fxsll 1 (constant eq-bitset-l4-bits)) 0)])
(vector-set! bm2 l3 bm3)
bm3))))])
(define (get-l4-index n)
(fxand (fxsrl n (constant eq-bitset-l4-shift)) (constant eq-bitset-l4-mask)))
(define (get-lo-index n)
(fxand (fxsrl n (constant eq-bitset-discard-bits))
(constant eq-bitset-lo-mask)))
(define (eq-bitset-member? bm p)
(let* ([n ($fxaddress p)]
[a (get-l3 (get-l2 (get-l1 bm n) n) n)]
[i (get-l4-index n)])
(fxbit-set? (fxvector-ref a i) (get-lo-index n))))
(define (eq-bitset-add! bm p)
(let* ([n ($fxaddress p)]
[a (get-l3 (get-l2 (get-l1 bm n) n) n)]
[i (get-l4-index n)])
(fxvector-set! a i (fxior (fxvector-ref a i)
(fxsll 1 (get-lo-index n))))))
(define (eq-bitset-remove! bm p)
(let* ([n ($fxaddress p)]
[a (get-l3 (get-l2 (get-l1 bm n) n) n)]
[i (get-l4-index n)])
(fxvector-set! a i (fxand (fxvector-ref a i)
(fxnot (fxsll 1 (get-lo-index n)))))))

44
s/cmacros.ss
View File

@ -1869,50 +1869,6 @@
(syntax-rules () (syntax-rules ()
((_ x) (let ((t x)) (and (pair? t) (symbol? (car t))))))) ((_ x) (let ((t x)) (and (pair? t) (symbol? (car t)))))))
;;; bitset constants
;; For a bitset ranging over all fixnum values, use an array of ...
;; array of fixnums, where the lo bits of a key fixnum are used to
;; index a bit within one bitset fixnum.
(define-constant eq-bitset-lo-bits (fx- (integer-length (constant fixnum-bits)) 1))
;; Using `$fxaddress` discards typemod bits, but we may be able to
;; discard additional bits due to allocation alignment:
(define-constant eq-bitset-discard-bits (fx- (log2 (constant byte-alignment))
(log2 (constant typemod))))
(constant-case ptr-bits
[(64)
;; Break fixnum into 5 levels: [l1:14] [l2:14] [l3:14] [l4:14-discard] [lo:5]
(define-constant eq-bitset-l1-bits 14)
(define-constant eq-bitset-l2-bits 14)
(define-constant eq-bitset-l3-bits 14)]
[(32)
;; Break fixnum into 3 levels: [l1:13] [l4:13-discard] [lo:4]
(define-constant eq-bitset-l1-bits 13)
(define-constant eq-bitset-l2-bits 0)
(define-constant eq-bitset-l3-bits 0)])
(define-constant eq-bitset-l4-bits (fx- (constant fixnum-bits)
(constant eq-bitset-l1-bits)
(constant eq-bitset-l2-bits)
(constant eq-bitset-l3-bits)
(constant eq-bitset-lo-bits)
(constant eq-bitset-discard-bits)))
(define-constant eq-bitset-l1-shift (fx- (constant fixnum-bits) (constant eq-bitset-l1-bits)))
(define-constant eq-bitset-l2-shift (fx- (constant fixnum-bits) (constant eq-bitset-l1-bits)
(constant eq-bitset-l2-bits)))
(define-constant eq-bitset-l3-shift (fx- (constant fixnum-bits) (constant eq-bitset-l1-bits)
(constant eq-bitset-l2-bits) (constant eq-bitset-l3-bits)))
(define-constant eq-bitset-l4-shift (fx+ (constant eq-bitset-lo-bits)
(constant eq-bitset-discard-bits)))
(define-constant eq-bitset-l2-mask (fx- (fxsll 1 (constant eq-bitset-l2-bits)) 1))
(define-constant eq-bitset-l3-mask (fx- (fxsll 1 (constant eq-bitset-l3-bits)) 1))
(define-constant eq-bitset-l4-mask (fx- (fxsll 1 (constant eq-bitset-l4-bits)) 1))
(define-constant eq-bitset-lo-mask (fx- (fxsll 1 (constant eq-bitset-lo-bits)) 1))
;;; heap/stack mangement constants ;;; heap/stack mangement constants
(define-constant collect-interrupt-index 1) (define-constant collect-interrupt-index 1)

110
s/inspect.ss
View File

@ -2489,7 +2489,6 @@
(define align (define align
(lambda (n) (lambda (n)
(fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment))))) (fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment)))))
(include "bitset.ss")
(define (thread->stack-objects thread) (define (thread->stack-objects thread)
(with-tc-mutex (with-tc-mutex
@ -2542,26 +2541,19 @@
(map (lambda (disp) ($object-ref 'scheme-object tc disp)) (map (lambda (disp) ($object-ref 'scheme-object tc disp))
tc-ptr-offsets)])))) tc-ptr-offsets)]))))
;; call with interrupts disabled if not `single-inspect-mode?` (set-who! $compute-size
(set-who! $compute-size-increments (rec $compute-size
(rec $compute-size-increments
(case-lambda (case-lambda
[(x* maxgen) ($compute-size-increments x* maxgen #f (make-eq-bitset))] [(x maxgen) ($compute-size x maxgen (make-eq-hashtable))]
[(x* maxgen single-inspect-mode? size-ht-or-bitset) [(x maxgen size-ht)
(define ephemeron-triggers #f) (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
(define ephemeron-triggers-bitset #f)
(define ephemeron-non-keys (and (not single-inspect-mode?) (make-eq-hashtable)))
(define cookie (and single-inspect-mode?
(cons 'date 'nut))) ; recreate on each call to $compute-size-increments
(define compute-size (define compute-size
(lambda (x) (lambda (x)
(let ([si ($maybe-seginfo x)]) (if (or ($immediate? x)
(cond (let ([g ($generation x)])
[(or (not si) (or (not g) (fx> g maxgen))))
(fx> ($seginfo-generation si) maxgen)) 0
0] (let ([a (eq-hashtable-cell size-ht x #f)])
[single-inspect-mode?
(let ([a (eq-hashtable-cell size-ht-or-bitset x #f)])
(cond (cond
[(cdr a) => [(cdr a) =>
(lambda (p) (lambda (p)
@ -2576,55 +2568,17 @@
[else [else
(let ([p (cons cookie 0)]) (let ([p (cons cookie 0)])
(set-cdr! a p) (set-cdr! a p)
(let ([size (really-compute-size x si)]) (let ([size (really-compute-size x)])
(set-cdr! p size) (set-cdr! p size)
size))]))] size))])))))
[else
(cond
[(eq-bitset-member? size-ht-or-bitset x) 0]
[else
(eq-bitset-add! size-ht-or-bitset x)
(let ([size (really-compute-size x si)])
(let ([ds (and ephemeron-triggers-bitset
(eq-bitset-member? ephemeron-triggers-bitset x)
(eq-hashtable-ref ephemeron-triggers x #f))])
(cond
[ds
(eq-hashtable-delete! ephemeron-triggers x)
(fold-left (lambda (size d) (fx+ size (compute-size d)))
size
ds)]
[else size])))])]))))
(define really-compute-size (define really-compute-size
(lambda (x si) (lambda (x)
(cond (cond
[(pair? x) [(pair? x)
(let ([space ($seginfo-space si)]) (let ([space ($seginfo-space ($maybe-seginfo x))])
(cond (cond
[(and (eqv? space (constant space-weakpair))
(not single-inspect-mode?))
(fx+ (constant size-pair) (compute-size (cdr x)))]
[(eqv? space (constant space-ephemeron)) [(eqv? space (constant space-ephemeron))
(cond (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))]
[(and (not single-inspect-mode?)
(let ([a (car x)])
(not (or ($immediate? a)
(let ([g ($generation a)])
(or (not g) (fx> g maxgen)))
(and (eq-bitset-member? size-ht-or-bitset a)
(not (eq-hashtable-ref ephemeron-non-keys a #f)))))))
(let ([d (cdr x)])
(unless ($immediate? d)
(unless ephemeron-triggers-bitset
(set! ephemeron-triggers-bitset (make-eq-bitset))
(set! ephemeron-triggers (make-eq-hashtable)))
(let ([v (car x)])
(eq-bitset-add! ephemeron-triggers-bitset v)
(let ([a (eq-hashtable-cell ephemeron-triggers v '())])
(set-cdr! a (cons d (cdr a)))))))
(constant size-ephemeron)]
[else
(fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))])]
[else [else
(fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))] (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))]
[(symbol? x) [(symbol? x)
@ -2755,35 +2709,9 @@
(fx+ (constant size-tlc) (fx+ (constant size-tlc)
(phantom-bytevector-length x))] (phantom-bytevector-length x))]
[else ($oops who "missing case for ~s" x)]))) [else ($oops who "missing case for ~s" x)])))
(cond
[single-inspect-mode?
; ensure size-ht isn't counted in the size of any object ; ensure size-ht isn't counted in the size of any object
(eq-hashtable-set! size-ht-or-bitset size-ht-or-bitset (cons cookie 0)) (eq-hashtable-set! size-ht size-ht (cons cookie 0))
(map compute-size x*)] (compute-size x)])))
[else
; ensure bitset isn't counted in the size of any object
(eq-bitset-add! size-ht-or-bitset size-ht-or-bitset)
;; Stop at each element of `x` when getting results for other elements,
;; but don't treat later elements as already-reached ephemeron keys:
(for-each (lambda (x)
(eq-bitset-add! size-ht-or-bitset x)
(eq-hashtable-set! ephemeron-non-keys x #t))
x*)
;; Traverse `x*` in order:
(let loop ([x* x*])
(cond
[(null? x*) '()]
[else
(let ([x (car x*)])
(eq-bitset-remove! size-ht-or-bitset x)
(eq-hashtable-delete! ephemeron-non-keys x)
(cons (compute-size x)
(loop (cdr x*))))]))])])))
(set-who! $compute-size
(case-lambda
[(x maxgen) (car ($compute-size-increments (list x) maxgen #t (make-eq-hashtable)))]
[(x maxgen size-ht) (car ($compute-size-increments (list x) maxgen #t size-ht))]))
(set-who! $compute-composition (set-who! $compute-composition
(lambda (x maxgen) (lambda (x maxgen)
@ -3120,14 +3048,14 @@
[(x g) ($compute-size x (filter-generation who g))])) [(x g) ($compute-size x (filter-generation who g))]))
(set-who! compute-size-increments (set-who! compute-size-increments
(let ([count_size_increments (foreign-procedure "(cs)count_size_increments" (ptr int) ptr)])
(rec compute-size-increments (rec compute-size-increments
(case-lambda (case-lambda
[(x*) (compute-size-increments x* (collect-maximum-generation))] [(x*) (compute-size-increments x* (collect-maximum-generation))]
[(x* g) [(x* g)
(unless (list? x*) ($oops who "~s is not a list" x*)) (unless (list? x*) ($oops who "~s is not a list" x*))
(let ([g (filter-generation who g)]) (let ([g (filter-generation who g)])
(with-interrupts-disabled (count_size_increments x* g))]))))
($compute-size-increments x* g)))])))
(set-who! compute-composition (set-who! compute-composition
(case-lambda (case-lambda

1
s/primdata.ss
View File

@ -1858,7 +1858,6 @@
($compound-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($compound-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
($compute-composition [flags single-valued]) ($compute-composition [flags single-valued])
($compute-size [flags single-valued]) ($compute-size [flags single-valued])
($compute-size-increments [flags single-valued])
($constituent? [sig [(char) -> (boolean)]] [flags pure mifoldable safeongoodargs]) ($constituent? [sig [(char) -> (boolean)]] [flags pure mifoldable safeongoodargs])
($constituent-ports [flags]) ($constituent-ports [flags])
($continuation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($continuation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])