suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs & thread: enforce custodian limit on immediate allocations

Browse Source 
For large vector, string, and byte string allocations, check
for limits on the current custodian.
This commit is contained in:
Matthew Flatt 2019-01-19 17:23:25 -07:00
parent e93088dd2c
commit dc047d8922
21 changed files with 128 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
racket/src/cs/chezpart.sls
View File

@ -38,7 +38,8 @@
get-thread-id
threaded?
map for-each andmap ormap
char-general-category)
char-general-category
make-vector make-string)
[make-parameter chez:make-parameter]
[date-second chez:date-second]
[date-minute chez:date-minute]

3
racket/src/cs/rumble.sls
View File

@ -293,6 +293,7 @@
bytes-append
subbytes
make-string
string-copy!
substring
@ -321,6 +322,7 @@
vector?
mutable-vector?
make-vector
(rename [inline:vector-length vector-length]
[inline:vector-ref vector-ref]
[inline:vector-set! vector-set!])
@ -464,6 +466,7 @@
set-garbage-collect-notify! ; not exported to Racket
set-reachable-size-increments-callback! ; not exported to Racket
set-custodian-memory-use-proc! ; not exported to Racket
set-immediate-allocation-check-proc! ; not exported to Racket
unsafe-add-collect-callbacks
unsafe-remove-collect-callbacks

3
racket/src/cs/rumble/bytes.ss
View File

@ -22,6 +22,9 @@
[(n b)
(check who exact-nonnegative-integer? n)
(check who byte? b)
(unless (and (fixnum? n)
(fx<? n 4096))
(guard-large-allocation who "byte string" n 1))
(#2%make-bytevector n b)]))
(define/who make-shared-bytes

2
racket/src/cs/rumble/control.ss
View File

@ -1187,7 +1187,7 @@
(extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list* k))
keys)])
(let* ([n (length all-keys)]
[tmp (make-vector n)])
[tmp (#%make-vector n)])
(let chain-loop ([mark-chain (or (and marks
(continuation-mark-set-mark-chain marks))
(current-mark-chain))])

24
racket/src/cs/rumble/engine.ss
View File

@ -30,14 +30,22 @@
(current-parameterization))])
(create-engine empty-metacontinuation
(lambda (prefix)
(call-with-continuation-prompt
(lambda ()
(with-continuation-mark
parameterization-key paramz
(begin
(prefix)
(call-with-values (lambda () (|#%app| thunk)) engine-return))))
prompt-tag))
;; Set parameterize for `prefix` to use:
(with-continuation-mark
parameterization-key paramz
(begin
(prefix)
(call-with-values (lambda ()
(call-with-continuation-prompt
(lambda ()
;; Set parameterization again inside
;; the prompt tag, so it goes along with
;; a captured continuation:
(with-continuation-mark
parameterization-key paramz
(|#%app| thunk)))
prompt-tag))
engine-return))))
(if empty-config?
(make-empty-thread-cell-values)
(new-engine-thread-cell-values))

2
racket/src/cs/rumble/error.ss
View File

@ -173,7 +173,7 @@
[(eqv? #\newline (string-ref s i))
(string-append
(loop i s (fx1+ i))
(make-string amt #\space)
(#%make-string amt #\space)
(substring s (fx1+ i) end))]
[else
(loop i s end)]))])))

2
racket/src/cs/rumble/foreign.ss
View File

@ -1338,7 +1338,7 @@
[(eq? mode 'atomic)
(make-cpointer (make-bytevector size) #f)]
[(eq? mode 'nonatomic)
(make-cpointer (make-vector (quotient size 8) 0) #f)]
(make-cpointer (#%make-vector (quotient size 8) 0) #f)]
[(eq? mode 'atomic-interior)
;; This is not quite the same as traditional Racket, because
;; a finalizer is associated with the cpointer (as opposed to

2
racket/src/cs/rumble/graph.ss
View File

@ -66,7 +66,7 @@
[else p]))]
[(vector? v)
(let* ([len (vector-length v)]
[p (make-vector len)])
[p (#%make-vector len)])
(hashtable-set! ht v p)
(let vloop ([i 0] [diff? #f])
(cond

18
racket/src/cs/rumble/hamt.ss
View File

@ -290,7 +290,7 @@
;; vector operations
(define (vector-insert v i x)
(let* ([len (#%vector-length v)]
[new (make-vector (fx1+ len))])
[new (#%make-vector (fx1+ len))])
(vector*-copy! new 0 v 0 i)
(#%vector-set! new i x)
(vector*-copy! new (fx1+ i) v i len)
@ -298,7 +298,7 @@
(define (vector-remove v i)
(let* ([len (#%vector-length v)]
[new (make-vector (fx1- len))])
[new (#%make-vector (fx1- len))])
(vector*-copy! new 0 v 0 i)
(vector*-copy! new i v (fx1+ i) len)
new))
@ -589,7 +589,7 @@
[else ; reify values
(pariah
(let* ([pop (popcount (bnode-keymap node))]
[v (make-vector (fx1+ pop) #t)])
[v (#%make-vector (fx1+ pop) #t)])
(#%vector-set! v ki val)
v))])])
@ -620,7 +620,7 @@
(#%vector-copy vals)
(pariah ; reify values
(let ([pop (popcount (bnode-keymap node))])
(make-vector pop #t))))])
(#%make-vector pop #t))))])
(#%vector-set! new-vals ki val)
@ -637,7 +637,7 @@
(let* ([keys (hnode-keys node)]
[vals (hnode-vals node)]
[len (#%vector-length keys)]
[new-keys (make-vector len)]
[new-keys (#%make-vector len)]
[ci (fx- len 1 (bnode-child-index node bit))])
(vector*-copy! new-keys 0 keys 0 ki)
@ -664,7 +664,7 @@
[v (val-ref child 0)]
[new-keys
(let ([cpy (make-vector len)])
(let ([cpy (#%make-vector len)])
(vector*-copy! cpy 0 keys 0 ki)
(#%vector-set! cpy ki k)
(vector*-copy! cpy (fx1+ ki) keys ki ci)
@ -678,7 +678,7 @@
[else ; reify values
(pariah
(let* ([pop (popcount (bnode-keymap node))]
[cpy (make-vector (fx1+ pop) #t)])
[cpy (#%make-vector (fx1+ pop) #t)])
(#%vector-set! cpy ki v)
cpy))])])
@ -896,7 +896,7 @@
[new-vals
(if vals
(#%vector-copy vals)
(make-vector len #t))])
(#%make-vector len #t))])
(#%vector-set! new-vals i val)
(make-cnode (hnode-eqtype node)
@ -914,7 +914,7 @@
[vals (vector-insert vals len val)]
[(eq? val #t) #f]
[else
(let ([vec (make-vector (fx1+ len) #t)])
(let ([vec (#%make-vector (fx1+ len) #t)])
(#%vector-set! vec len val)
vec)])])

6
racket/src/cs/rumble/hash.ss
View File

@ -538,7 +538,7 @@
(let ([new-ht (make-eq-hashtable)])
(vector-for-each (lambda (p) (hashtable-set! new-ht (if weak? (cdr p) p) #t)) new-vec)
(vector-for-each (lambda (p) (hashtable-delete! new-ht (if weak? (cdr p) p))) vec)
(let ([merge-vec (make-vector (fx+ (#%vector-length vec) (hashtable-size new-ht)))])
(let ([merge-vec (#%make-vector (fx+ (#%vector-length vec) (hashtable-size new-ht)))])
(let loop ([i (#%vector-length vec)])
(unless (fx= i 0)
(let ([i (fx- i 1)])
@ -912,7 +912,7 @@
(hashtable-size (weak-equal-hash-fl-vals-ht t))))
(define (weak-equal-hash-cells ht len)
(let ([vec (make-vector len #f)]
(let ([vec (#%make-vector len #f)]
[pos (box 0)])
(call/cc
(lambda (esc)
@ -937,7 +937,7 @@
(cond
[(< (unbox pos) len)
(let* ([len (unbox pos)]
[compact-vec (make-vector len)])
[compact-vec (#%make-vector len)])
(let loop ([i 0])
(unless (fx= i len)
(#%vector-set! compact-vec i (#%vector-ref vec i))

20
racket/src/cs/rumble/memory.ss
View File

@ -109,6 +109,20 @@
(define custodian-memory-use (lambda (mode all) all))
(define (set-custodian-memory-use-proc! proc) (set! custodian-memory-use proc))
(define immediate-allocation-check (lambda (n) (void)))
(define (set-immediate-allocation-check-proc! proc) (set! immediate-allocation-check proc))
(define (guard-large-allocation who what len size)
(when (exact-nonnegative-integer? len)
(let ([n (* len size)])
(unless (fixnum? n)
(raise (|#%app|
exn:fail:out-of-memory
(#%format "out of memory making ~a\n length: ~a"
what len)
(current-continuation-marks))))
(immediate-allocation-check n))))
(define prev-stats-objects #f)
(define (dump-memory-stats . args)
@ -125,9 +139,9 @@
[get-count (lambda (static?) (lambda (e) (apply + (map (extract static? cadr) (cdr e)))))]
[get-bytes (lambda (static?) (lambda (e) (apply + (map (extract static? cddr) (cdr e)))))]
[pad (lambda (s n)
(string-append (make-string (max 0 (- n (string-length s))) #\space) s))]
(string-append (#%make-string (max 0 (- n (string-length s))) #\space) s))]
[pad-right (lambda (s n)
(string-append s (make-string (max 0 (- n (string-length s))) #\space)))]
(string-append s (#%make-string (max 0 (- n (string-length s))) #\space)))]
[commas (lambda (n)
(let* ([l (string->list (number->string n))]
[len (length l)])
@ -165,7 +179,7 @@
(cond
[(null? args) "\n"]
[(< actual-col want-col)
(string-append (make-string (- want-col actual-col) #\space)
(string-append (#%make-string (- want-col actual-col) #\space)
(loop args want-col want-col))]
[(integer? (car args))
(loop (cons (pad (commas (car args))

4
racket/src/cs/rumble/place.ss
View File

@ -9,8 +9,8 @@
(define NUM-PLACE-REGISTERS 128)
(define-virtual-register place-registers (make-vector NUM-PLACE-REGISTERS 0))
(define place-register-inits (make-vector NUM-PLACE-REGISTERS 0))
(define-virtual-register place-registers (#%make-vector NUM-PLACE-REGISTERS 0))
(define place-register-inits (#%make-vector NUM-PLACE-REGISTERS 0))
(define (init-place-locals!)
(#%vector-set! (place-registers) 0 (make-weak-hasheq)))

12
racket/src/cs/rumble/string.ss
View File

@ -1,3 +1,15 @@
(define/who make-string
(case-lambda
[(n) (make-string n (integer->char 0))]
[(n ch)
(unless (or (and (fixnum? n)
(fx<? n 1000))
(not (char? ch)))
(guard-large-allocation who 'string n 4))
(#2%make-string n ch)]))
;; ----------------------------------------
(define/who string-copy!
(case-lambda
[(dest d-start src)

2
racket/src/cs/rumble/struct.ss
View File

@ -1108,7 +1108,7 @@
;; The start of opaque regions
(loop (add1 vec-len) (+ rec-len len) (record-type-parent rtd) #t)]))]))])
;; Walk though the record's types again, this time filling in the vector
(let ([vec (make-vector vec-len dots)])
(let ([vec (#%make-vector vec-len dots)])
(vector-set! vec 0 (string->symbol (format "struct:~a" (record-type-name rtd))))
(let loop ([vec-pos vec-len] [rec-pos rec-len] [rtd rtd] [dots-already? #f])
(when rtd

11
racket/src/cs/rumble/vector.ss
View File

@ -1,3 +1,14 @@
(define/who make-vector
(case-lambda
[(n) (make-vector n 0)]
[(n v)
(unless (and (fixnum? n)
(fx< n 1000))
(guard-large-allocation who 'vector n (foreign-sizeof 'void*)))
(#2%make-vector n v)]))
;; ----------------------------------------
(define (vector-immutable . args)
(if (null? args)
(vector->immutable-vector '#())

4
racket/src/cs/thread.sls
View File

@ -33,7 +33,8 @@
[unsafe-root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag]
[set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!]
[set-reachable-size-increments-callback! rumble:set-reachable-size-increments-callback!]
[set-custodian-memory-use-proc! rumble:set-custodian-memory-use-proc!]))
[set-custodian-memory-use-proc! rumble:set-custodian-memory-use-proc!]
[set-immediate-allocation-check-proc! rumble:set-immediate-allocation-check-proc!]))
(include "place-register.ss")
(define-place-register-define place:define thread-register-start thread-register-count)
@ -129,6 +130,7 @@
'continuation-marks rumble:continuation-marks
'set-reachable-size-increments-callback! rumble:set-reachable-size-increments-callback!
'set-custodian-memory-use-proc! rumble:set-custodian-memory-use-proc!
'set-immediate-allocation-check-proc! rumble:set-immediate-allocation-check-proc!
'exn:break/non-engine exn:break
'exn:break:hang-up/non-engine exn:break:hang-up
'exn:break:terminate/non-engine exn:break:terminate

10
racket/src/thread/bootstrap.rkt
View File

@ -13,7 +13,7 @@
(provide register-place-symbol!
set-io-place-init!)
(define (make-engine thunk init-break-enabled-cell empty-config?)
(define (make-engine thunk prompt-tag init-break-enabled-cell empty-config?)
(define ready-s (make-semaphore))
(define s (make-semaphore))
(define prefix void)
@ -50,7 +50,12 @@
(semaphore-wait s)
(run-prefix)
(set! results
(call-with-values thunk list)))))
(call-with-continuation-prompt
(lambda ()
(call-with-values thunk list))
prompt-tag
(lambda (proc)
(abort-current-continuation prompt-tag proc)))))))
the-root-continuation-prompt-tag
(lambda (exn)
((error-display-handler) (exn-message exn) exn))))))))
@ -238,6 +243,7 @@
'will-try-execute will-try-execute/notify
'set-reachable-size-increments-callback! (lambda (proc) (void))
'set-custodian-memory-use-proc! (lambda (proc) (void))
'set-immediate-allocation-check-proc! (lambda (proc) (void))
'exn:break/non-engine exn:break/non-engine
'exn:break:hang-up/non-engine exn:break:hang-up/non-engine
'exn:break:terminate/non-engine exn:break:terminate/non-engine

6
racket/src/thread/custodian-object.rkt
View File

@ -14,7 +14,8 @@
[place #:mutable] ; place containing the custodian
[memory-use #:mutable] ; set after a major GC
[gc-roots #:mutable] ; weak references to charge to custodian; access without interrupts
[memory-limits #:mutable]) ; list of (cons limit cust)
[memory-limits #:mutable] ; list of (cons limit cust)
[immediate-limit #:mutable]) ; limit on immediate allocation
#:authentic)
(define (create-custodian)
@ -26,7 +27,8 @@
#f ; place
0 ; memory use
#f ; GC roots
null)) ; memory limits
null ; memory limits
#f)) ; immediate limit
(define initial-place-root-custodian (create-custodian))

19
racket/src/thread/custodian.rkt
View File

@ -32,7 +32,8 @@
raise-custodian-is-shut-down
set-post-shutdown-action!
check-queued-custodian-shutdown
set-place-custodian-procs!)
set-place-custodian-procs!
custodian-check-immediate-limit)
(module+ scheduling
(provide do-custodian-shutdown-all
@ -266,6 +267,10 @@
(set-custodian-memory-limits! limit-cust
(cons (cons need-amt stop-cust)
(custodian-memory-limits limit-cust)))
(when (eq? stop-cust limit-cust)
(define old-limit (custodian-immediate-limit limit-cust))
(when (or (not old-limit) (old-limit . > . need-amt))
(set-custodian-immediate-limit! limit-cust need-amt)))
(host:mutex-acquire memory-limit-lock)
(set! compute-memory-sizes (max compute-memory-sizes 1))
(host:mutex-release memory-limit-lock)))
@ -411,3 +416,15 @@
#f]))
(collect-garbage))
(custodian-memory-use c)]))))
(define (custodian-check-immediate-limit mref n)
(let loop ([mref mref])
(when mref
(define c (custodian-reference->custodian mref))
(when c
(define limit (custodian-immediate-limit c))
(when (and limit (n . >= . limit))
(raise (exn:fail:out-of-memory
"out of memory"
(current-continuation-marks))))
(loop (custodian-parent-reference c))))))

1
racket/src/thread/host.rkt
View File

@ -51,6 +51,7 @@
set-reachable-size-increments-callback!
set-custodian-memory-use-proc!
set-immediate-allocation-check-proc!
;; Just `exn:break`, etc., but the host may need
;; to distinguish breaks raised by the thread

11
racket/src/thread/thread.rkt
View File

@ -1000,3 +1000,14 @@
(define/who (thread-receive-evt)
(thread-receiver-evt))
;; ----------------------------------------
(void (set-immediate-allocation-check-proc!
;; Called to check large vector, string, and byte-string allocations
(lambda (n)
(define t (current-thread))
(when t
(define mrefs (thread-custodian-references t))
(unless (null? mrefs)
(custodian-check-immediate-limit (car mrefs) n))))))