cs: avoid a leak due to prefab declarations
This commit is contained in:
parent
f0c39b1f81
commit
fe708871bd
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user