remove old implementation of compute-size-increments
The old implementation is replaced by the new mkgc.ss-based implemented. original commit: 7a8eaf81df0dd52cde58ed51f5210b9398cb8bb6
This commit is contained in:
Matthew Flatt
parent
afebbdd6a9
commit
45b618c4c1
|
|
@ -164,7 +164,7 @@ macroobj =\
|
|||
allsrc =\
|
||||
${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\
|
||||
np-languages.ss bitset.ss fxmap.ss
|
||||
np-languages.ss fxmap.ss
|
||||
|
||||
# doit uses a different Scheme process to compile each target
|
||||
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
|
||||
cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes}
|
||||
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
|
||||
(if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi)
|
||||
|
|
|
|||
73
s/bitset.ss
73
s/bitset.ss
|
|
@ -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
44
s/cmacros.ss
|
|
@ -1869,50 +1869,6 @@
|
|||
(syntax-rules ()
|
||||
((_ 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
|
||||
|
||||
(define-constant collect-interrupt-index 1)
|
||||
|
|
|
|||
152
s/inspect.ss
152
s/inspect.ss
|
|
@ -2489,7 +2489,6 @@
|
|||
(define align
|
||||
(lambda (n)
|
||||
(fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment)))))
|
||||
(include "bitset.ss")
|
||||
|
||||
(define (thread->stack-objects thread)
|
||||
(with-tc-mutex
|
||||
|
|
@ -2542,89 +2541,44 @@
|
|||
(map (lambda (disp) ($object-ref 'scheme-object tc disp))
|
||||
tc-ptr-offsets)]))))
|
||||
|
||||
;; call with interrupts disabled if not `single-inspect-mode?`
|
||||
(set-who! $compute-size-increments
|
||||
(rec $compute-size-increments
|
||||
(set-who! $compute-size
|
||||
(rec $compute-size
|
||||
(case-lambda
|
||||
[(x* maxgen) ($compute-size-increments x* maxgen #f (make-eq-bitset))]
|
||||
[(x* maxgen single-inspect-mode? size-ht-or-bitset)
|
||||
(define ephemeron-triggers #f)
|
||||
(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
|
||||
[(x maxgen) ($compute-size x maxgen (make-eq-hashtable))]
|
||||
[(x maxgen size-ht)
|
||||
(define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
|
||||
(define compute-size
|
||||
(lambda (x)
|
||||
(let ([si ($maybe-seginfo x)])
|
||||
(cond
|
||||
[(or (not si)
|
||||
(fx> ($seginfo-generation si) maxgen))
|
||||
0]
|
||||
[single-inspect-mode?
|
||||
(let ([a (eq-hashtable-cell size-ht-or-bitset x #f)])
|
||||
(if (or ($immediate? x)
|
||||
(let ([g ($generation x)])
|
||||
(or (not g) (fx> g maxgen))))
|
||||
0
|
||||
(let ([a (eq-hashtable-cell size-ht x #f)])
|
||||
(cond
|
||||
[(cdr a) =>
|
||||
(lambda (p)
|
||||
; if we find our cookie, return 0 to avoid counting shared structure twice.
|
||||
; otherwise, (car p) must be a cookie from an earlier call to $compute-size,
|
||||
; so return the recorded size
|
||||
(if (eq? (car p) cookie)
|
||||
0
|
||||
(begin
|
||||
(set-car! p cookie)
|
||||
(cdr p))))]
|
||||
[else
|
||||
(let ([p (cons cookie 0)])
|
||||
(set-cdr! a p)
|
||||
(let ([size (really-compute-size x si)])
|
||||
(set-cdr! p 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])))])]))))
|
||||
[(cdr a) =>
|
||||
(lambda (p)
|
||||
; if we find our cookie, return 0 to avoid counting shared structure twice.
|
||||
; otherwise, (car p) must be a cookie from an earlier call to $compute-size,
|
||||
; so return the recorded size
|
||||
(if (eq? (car p) cookie)
|
||||
0
|
||||
(begin
|
||||
(set-car! p cookie)
|
||||
(cdr p))))]
|
||||
[else
|
||||
(let ([p (cons cookie 0)])
|
||||
(set-cdr! a p)
|
||||
(let ([size (really-compute-size x)])
|
||||
(set-cdr! p size)
|
||||
size))])))))
|
||||
(define really-compute-size
|
||||
(lambda (x si)
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(let ([space ($seginfo-space si)])
|
||||
(let ([space ($seginfo-space ($maybe-seginfo x))])
|
||||
(cond
|
||||
[(and (eqv? space (constant space-weakpair))
|
||||
(not single-inspect-mode?))
|
||||
(fx+ (constant size-pair) (compute-size (cdr x)))]
|
||||
[(eqv? space (constant space-ephemeron))
|
||||
(cond
|
||||
[(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)))])]
|
||||
(fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))]
|
||||
[else
|
||||
(fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))]
|
||||
[(symbol? x)
|
||||
|
|
@ -2755,35 +2709,9 @@
|
|||
(fx+ (constant size-tlc)
|
||||
(phantom-bytevector-length 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
|
||||
(eq-hashtable-set! size-ht-or-bitset size-ht-or-bitset (cons cookie 0))
|
||||
(map 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))]))
|
||||
; ensure size-ht isn't counted in the size of any object
|
||||
(eq-hashtable-set! size-ht size-ht (cons cookie 0))
|
||||
(compute-size x)])))
|
||||
|
||||
(set-who! $compute-composition
|
||||
(lambda (x maxgen)
|
||||
|
|
@ -3120,14 +3048,14 @@
|
|||
[(x g) ($compute-size x (filter-generation who g))]))
|
||||
|
||||
(set-who! compute-size-increments
|
||||
(rec compute-size-increments
|
||||
(case-lambda
|
||||
[(x*) (compute-size-increments x* (collect-maximum-generation))]
|
||||
[(x* g)
|
||||
(unless (list? x*) ($oops who "~s is not a list" x*))
|
||||
(let ([g (filter-generation who g)])
|
||||
(with-interrupts-disabled
|
||||
($compute-size-increments x* g)))])))
|
||||
(let ([count_size_increments (foreign-procedure "(cs)count_size_increments" (ptr int) ptr)])
|
||||
(rec compute-size-increments
|
||||
(case-lambda
|
||||
[(x*) (compute-size-increments x* (collect-maximum-generation))]
|
||||
[(x* g)
|
||||
(unless (list? x*) ($oops who "~s is not a list" x*))
|
||||
(let ([g (filter-generation who g)])
|
||||
(count_size_increments x* g))]))))
|
||||
|
||||
(set-who! compute-composition
|
||||
(case-lambda
|
||||
|
|
|
|||
|
|
@ -1858,7 +1858,6 @@
|
|||
($compound-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
|
||||
($compute-composition [flags single-valued])
|
||||
($compute-size [flags single-valued])
|
||||
($compute-size-increments [flags single-valued])
|
||||
($constituent? [sig [(char) -> (boolean)]] [flags pure mifoldable safeongoodargs])
|
||||
($constituent-ports [flags])
|
||||
($continuation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user