cs: avoid a leak due to prefab declarations

This commit is contained in:
Matthew Flatt 2019-05-26 11:56:25 -06:00
parent f0c39b1f81
commit fe708871bd
4 changed files with 29 additions and 7 deletions

View File

@ -155,6 +155,11 @@
(let ([v (getenv "PLT_SETUP_DMS_ARGS")]) (let ([v (getenv "PLT_SETUP_DMS_ARGS")])
(and v (read (open-input-string v))))) (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 ;; ;; Errors ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1069,8 +1074,10 @@
;; We keep timestamp information for all files that we try to compile. ;; 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, ;; 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. ;; and it makes a do-nothing setup complete much faster. But set the
(define caching-managed-compile-zo (make-caching-managed-compile-zo)) ;; `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?) (define (compile-cc cc gcs has-module-suffix?)
(parameterize ([current-namespace (make-base-empty-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])
@ -1090,7 +1097,8 @@
#:verbose (verbose) #:verbose (verbose)
#:has-module-suffix? has-module-suffix? #:has-module-suffix? has-module-suffix?
#:omit-root (cc-omit-root cc) #: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-path (and (avoid-main-installation) main-collects-dir)
#:skip-doc-sources? (not make-docs?)))))) #:skip-doc-sources? (not make-docs?))))))
(when post-collection-dms-args (when post-collection-dms-args

View File

@ -286,6 +286,14 @@
#%procedure?] #%procedure?]
[(eq? 'ephemeron (car args)) [(eq? 'ephemeron (car args))
ephemeron-pair?] ephemeron-pair?]
[(eq? 'bignum (car args))
bignum?]
[(eq? 'keyword (car args))
keyword?]
[(eq? 'string (car args))
string?]
[(eq? 'symbol (car args))
symbol?]
[(eq? '<ffi-lib> (car args)) [(eq? '<ffi-lib> (car args))
ffi-lib?] ffi-lib?]
[(eq? '<will-executor> (car args)) [(eq? '<will-executor> (car args))

View File

@ -303,7 +303,10 @@
'#())) '#()))
(define (encode-prefab-key+count-as-symbol prefab-key+count) (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) (define (immutables->mutables immutables init-count auto-count)
(vector->immutable-vector (vector->immutable-vector

View File

@ -571,7 +571,7 @@
(record-type-uid (record-type-uid
(prefab-key+count->rtd (cons prefab-key total*-count))))) (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 ;; 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 ;; 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 ;; global lock to access the table. Compute a hash code outside the
@ -581,7 +581,10 @@
;; Call with lock: ;; Call with lock:
(define (prefab-ref prefab-key+count code) (define (prefab-ref prefab-key+count code)
(and prefabs (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) (define (prefab-key+count->rtd prefab-key+count)
(let ([code (equal-hash-code prefab-key+count)]) (let ([code (equal-hash-code prefab-key+count)])
@ -615,7 +618,7 @@
[else [else
(putprop uid 'prefab-key+count prefab-key+count) (putprop uid 'prefab-key+count prefab-key+count)
(unless prefabs (set! prefabs (make-weak-hash-with-lock #f))) (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 (unless parent-rtd
(record-type-equal-procedure rtd default-struct-equal?) (record-type-equal-procedure rtd default-struct-equal?)
(record-type-hash-procedure rtd default-struct-hash)) (record-type-hash-procedure rtd default-struct-hash))