From 45b618c4c15cfd153be88b8fc83babf02433f77d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 4 Apr 2020 10:18:54 -0600 Subject: [PATCH] remove old implementation of `compute-size-increments` The old implementation is replaced by the new mkgc.ss-based implemented. original commit: 7a8eaf81df0dd52cde58ed51f5210b9398cb8bb6 --- s/Mf-base | 3 +- s/bitset.ss | 73 ------------------------ s/cmacros.ss | 44 --------------- s/inspect.ss | 152 +++++++++++++------------------------------------- s/primdata.ss | 1 - 5 files changed, 41 insertions(+), 232 deletions(-) delete mode 100644 s/bitset.ss diff --git a/s/Mf-base b/s/Mf-base index 1a6c03b3ab..375fd02cf6 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -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) diff --git a/s/bitset.ss b/s/bitset.ss deleted file mode 100644 index 3da4ae7bf1..0000000000 --- a/s/bitset.ss +++ /dev/null @@ -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))))))) diff --git a/s/cmacros.ss b/s/cmacros.ss index 2aeaf0f003..6f2ed48373 100644 --- a/s/cmacros.ss +++ b/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) diff --git a/s/inspect.ss b/s/inspect.ss index 08112b28ec..ebf0ad714f 100644 --- a/s/inspect.ss +++ b/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 diff --git a/s/primdata.ss b/s/primdata.ss index 6a2452ecb4..520fbf9f0c 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -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])