diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index 3286341c57..79911df43f 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -155,6 +155,11 @@ (let ([v (getenv "PLT_SETUP_DMS_ARGS")]) (and v (read (open-input-string v))))) + ;; Also help to check for leaks: set `PLT_SETUP_LIMIT_CACHE` to + ;; avoid caching compile-file information across different collections: + (define limit-cross-collection-cache? + (getenv "PLT_SETUP_LIMIT_CACHE")) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Errors ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1069,8 +1074,10 @@ ;; We keep timestamp information for all files that we try to compile. ;; That's O(N) for an installation of size N, but the constant is small, - ;; and it makes a do-nothing setup complete much faster. - (define caching-managed-compile-zo (make-caching-managed-compile-zo)) + ;; and it makes a do-nothing setup complete much faster. But set the + ;; `PLT_SETUP_LIMIT_CACHE` environment variable to disable it. + (define caching-managed-compile-zo (and (not limit-cross-collection-cache?) + (make-caching-managed-compile-zo))) (define (compile-cc cc gcs has-module-suffix?) (parameterize ([current-namespace (make-base-empty-namespace)]) @@ -1090,7 +1097,8 @@ #:verbose (verbose) #:has-module-suffix? has-module-suffix? #:omit-root (cc-omit-root cc) - #:managed-compile-zo caching-managed-compile-zo + #:managed-compile-zo (or caching-managed-compile-zo + (make-caching-managed-compile-zo)) #:skip-path (and (avoid-main-installation) main-collects-dir) #:skip-doc-sources? (not make-docs?)))))) (when post-collection-dms-args diff --git a/racket/src/cs/rumble/memory.ss b/racket/src/cs/rumble/memory.ss index a8b6854489..6eca4439a0 100644 --- a/racket/src/cs/rumble/memory.ss +++ b/racket/src/cs/rumble/memory.ss @@ -286,6 +286,14 @@ #%procedure?] [(eq? 'ephemeron (car args)) ephemeron-pair?] + [(eq? 'bignum (car args)) + bignum?] + [(eq? 'keyword (car args)) + keyword?] + [(eq? 'string (car args)) + string?] + [(eq? 'symbol (car args)) + symbol?] [(eq? ' (car args)) ffi-lib?] [(eq? ' (car args)) diff --git a/racket/src/cs/rumble/prefab.ss b/racket/src/cs/rumble/prefab.ss index d878e35a04..cdc698a570 100644 --- a/racket/src/cs/rumble/prefab.ss +++ b/racket/src/cs/rumble/prefab.ss @@ -303,7 +303,10 @@ '#())) (define (encode-prefab-key+count-as-symbol prefab-key+count) - (string->symbol (chez:format "~a" 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))) (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 af51062ffa..44d04eb8b4 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -571,7 +571,7 @@ (record-type-uid (prefab-key+count->rtd (cons prefab-key total*-count))))) -;; A weak, `equal?`-based hash table that maps (cons prefab-key +;; An emphemeron-weak, `equal?`-based hash table that maps (cons prefab-key ;; total-field-count) to rtd. We'll create a table without a lock, and ;; we'll use it for all places, which means that we need to use a ;; global lock to access the table. Compute a hash code outside the @@ -581,7 +581,10 @@ ;; Call with lock: (define (prefab-ref prefab-key+count code) (and prefabs - (weak-hash-ref prefabs prefab-key+count #f code equal?))) + (let ([e (weak-hash-ref prefabs prefab-key+count #f code equal?)]) + (and e + (not (eq? (car e) #!bwp)) + (cdr e))))) (define (prefab-key+count->rtd prefab-key+count) (let ([code (equal-hash-code prefab-key+count)]) @@ -615,7 +618,7 @@ [else (putprop uid 'prefab-key+count prefab-key+count) (unless prefabs (set! prefabs (make-weak-hash-with-lock #f))) - (weak-hash-set! prefabs prefab-key+count rtd code equal?) + (weak-hash-set! prefabs prefab-key+count (ephemeron-cons prefab-key+count rtd) code equal?) (unless parent-rtd (record-type-equal-procedure rtd default-struct-equal?) (record-type-hash-procedure rtd default-struct-hash))