diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index c1871fed89..aa72d9c3f8 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -1273,6 +1273,12 @@ (expand-omit-library-invocations #t) (enable-error-source-expression #f) + ;; Avoid gensyms for generated record-tyope UIDs. Otherwise, + ;; printing one of those gensyms --- perhaps when producing a trace + ;; via `dump-memory-stats` --- causes the gensym to be permanent + ;; (since it has properties). + (current-generate-id (lambda (sym) (gensym sym))) + ;; Since the schemify layer inserts `|#%app|` any time the rator of ;; an application might not be a procedure, we can avoid redundant ;; checks for other applications by enabling unsafe mode. Ditto for diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps index ac265acfaa..9c8d81f3f7 100644 --- a/racket/src/cs/main.sps +++ b/racket/src/cs/main.sps @@ -634,7 +634,8 @@ (let ([root-logger (current-logger)]) ;; This function can be called in any Chez Scheme thread (lambda (gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time - post-allocated post-allocated+overhead post-time post-cpu-time) + post-allocated post-allocated+overhead proper-post-time proper-post-cpu-time + post-time post-cpu-time) (let ([minor? (< gen (collect-maximum-generation))]) (if minor? (set! minor-gcs (add1 minor-gcs)) @@ -644,14 +645,23 @@ (when (or debug-GC? (and (not minor?) (log-level?* root-logger 'debug 'GC:major))) - (let ([delta (- pre-allocated post-allocated)]) + (let ([delta (- pre-allocated post-allocated)] + [account-str (let ([proper (if (= post-cpu-time pre-cpu-time) + 100 + (quotient (* 100 (- proper-post-cpu-time pre-cpu-time)) + (- post-cpu-time pre-cpu-time)))]) + (if (fx>= proper 99) + "" + (string-append "[" (number->string (fx- 100 proper)) "%]")))]) (log-message* root-logger 'debug (if debug-GC? 'GC 'GC:major) - (chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams @ ~a" + (chez:format "GC: 0:~a~a @ ~a(~a); free ~a(~a) ~ams~a @ ~a" (if minor? "min" "MAJ") gen (K "" pre-allocated) (K "+" (- pre-allocated+overhead pre-allocated)) (K "" delta) (K "+" (- (- pre-allocated+overhead post-allocated+overhead) delta)) - (- post-cpu-time pre-cpu-time) pre-cpu-time) + (- post-cpu-time pre-cpu-time) + account-str + pre-cpu-time) (make-gc-info (if minor? 'minor 'major) pre-allocated pre-allocated+overhead 0 post-allocated post-allocated+overhead pre-cpu-time post-cpu-time diff --git a/racket/src/cs/rumble/define.ss b/racket/src/cs/rumble/define.ss index 045b2fda6c..1e928f8c1f 100644 --- a/racket/src/cs/rumble/define.ss +++ b/racket/src/cs/rumble/define.ss @@ -241,7 +241,7 @@ [(called-var ...) called-vars] [new-name (datum->syntax name - (chez:gensym (chez:symbol->string (syntax->datum name))))] + (#%gensym (#%symbol->string (syntax->datum name))))] [body (let loop ([body body] [binds binds]) (cond diff --git a/racket/src/cs/rumble/impersonator.ss b/racket/src/cs/rumble/impersonator.ss index 60ceb551bf..7f3422f8e5 100644 --- a/racket/src/cs/rumble/impersonator.ss +++ b/racket/src/cs/rumble/impersonator.ss @@ -596,7 +596,7 @@ (lambda (v info) (check 'guard-for-prop:impersonator-of (procedure-arity-includes/c 1) v) ;; Add a tag to track origin of the `prop:impersonator-of` value - (cons (gensym "tag") v)))) + (cons (box 'impersonator-of) v)))) (define (extract-impersonator-of who a) (and (impersonator-of-redirect? a) diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss index 022730ea5f..cecb64dd78 100644 --- a/racket/src/cs/rumble/memory.ss +++ b/racket/src/cs/rumble/memory.ss @@ -16,7 +16,9 @@ (define garbage-collect-notify (lambda (gen pre-allocated pre-allocated+overhead pre-time re-cpu-time - post-allocated post-allocated+overhead post-time post-cpu-time) + post-allocated post-allocated+overhead + proper-post-time proper-post-cpu-time + post-time post-cpu-time) (void))) ;; #f or a procedure that accepts `compute-size-increments` to be @@ -76,7 +78,9 @@ (run-collect-callbacks car) (collect gen) (let ([post-allocated (bytes-allocated)] - [post-allocated+overhead (current-memory-bytes)]) + [post-allocated+overhead (current-memory-bytes)] + [post-time (real-time)] + [post-cpu-time (cpu-time)]) (when (= gen (collect-maximum-generation)) ;; Trigger a major GC when twice as much memory is used. Twice ;; `post-allocated+overhead` seems to be too long a wait, because @@ -85,15 +89,16 @@ ;; immediate major GC too soon. Split the difference. (set! trigger-major-gc-allocated (* GC-TRIGGER-FACTOR post-allocated)) (set! trigger-major-gc-allocated+overhead (* GC-TRIGGER-FACTOR post-allocated+overhead))) + (update-eq-hash-code-table-size!) + (poll-foreign-guardian) + (when (and reachable-size-increments-callback + (fx= gen (collect-maximum-generation))) + (reachable-size-increments-callback compute-size-increments)) + (run-collect-callbacks cdr) (garbage-collect-notify gen pre-allocated pre-allocated+overhead pre-time pre-cpu-time - post-allocated post-allocated+overhead (real-time) (cpu-time))) - (update-eq-hash-code-table-size!) - (poll-foreign-guardian) - (run-collect-callbacks cdr) - (when (and reachable-size-increments-callback - (fx= gen (collect-maximum-generation))) - (reachable-size-increments-callback compute-size-increments)) + post-allocated post-allocated+overhead post-time post-cpu-time + (real-time) (cpu-time))) (when (and (= gen (collect-maximum-generation)) (currently-in-engine?)) ;; This `set-timer` doesn't necessarily penalize the right thread, diff --git a/racket/src/cs/rumble/prefab.ss b/racket/src/cs/rumble/prefab.ss index cdc698a570..14cddc6629 100644 --- a/racket/src/cs/rumble/prefab.ss +++ b/racket/src/cs/rumble/prefab.ss @@ -305,8 +305,9 @@ (define (encode-prefab-key+count-as-symbol prefab-key+count) ;; The symbol has to be uninterned, because we're going to attach ;; properties to it, and an interned symbol with properties is never - ;; reclaimed by the garbage collector - (#%gensym (#%format "~s" prefab-key+count))) + ;; reclaimed by the garbage collector. Beware that a gensym is + ;; retained, too, if its unique name is forced. + (#%string->uninterned-symbol (#%format "~s" prefab-key+count))) (define (immutables->mutables immutables init-count auto-count) (vector->immutable-vector diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index b4c9fc58fd..0cc07f20be 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -1070,7 +1070,7 @@ " (procedure-arity-includes/c 2)\n" " (procedure-arity-includes/c 2))") val) - (cons (#%gensym) val)))) + (cons (box 'equal+hash) val)))) (define-values (prop:authentic authentic? authentic-ref) (make-struct-type-property 'authentic (lambda (val info) #t))) diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt index c6aeb5777c..3b33ab7523 100644 --- a/racket/src/thread/custodian.rkt +++ b/racket/src/thread/custodian.rkt @@ -450,9 +450,9 @@ (unless (zero? compute-memory-sizes) (host:call-with-current-place-continuation (lambda (starting-k) - ;; A place may have future pthreads, and each ptherad may + ;; A place may have future pthreads, and each pthread may ;; be running a future that becomes to a particular custodian; - ;; build up a custodian-to-pthtread mapping in this table: + ;; build up a custodian-to-pthread mapping in this table: (define custodian-future-threads (make-hasheq)) (future-scheduler-add-thread-custodian-mapping! (place-future-scheduler initial-place) custodian-future-threads)