cs: limit debugging context in continuation marks
In CS, if you interrupt an especially tight non-tail recursion, such as (let loop () (cons 1 (loop))) then the "context" view of the continuation (as recorded in a continuation mark set) can take space that is a multiple of the size of the continuation itself. That's a particular problem if the too-deep recursion triggers the memory limit in DrRacket, because DrRacket will then need a multiple of its current heap space to report "out of memory". (Note: Just keeping the continuation itself is not a good option, because that may retain other data referenced by the continuation.) This commit reduces the heap space used to gather a continuation context, relying in part on new Chez Scheme support, but mostly it limits the context length to roughly the same maximum as in BC. The BC limit is an implementation artifact, but it turns out to have good properties; informaiton on more than 64k continuation frames is rarely useful. The limit could be a parameter, but a large built-in limit seems likely good enough. (Another note: Adding a limit argument to `continuation-mark-set->context` doesn't help enough, because it's too late by that point; too much memory has been used to repersent the information that's in the mark set.) The commit also tightens tracking of continuations for memory accounting, reducing the chance that a thread's large continuation will be charged to the wrong custodian.
This commit is contained in:
Matthew Flatt
parent
7c7f16ba02
commit
c40a7ae2fc
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "7.7.0.9")
|
||||
(define version "7.7.0.10")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
;; Check to make we're using a build of Chez Scheme
|
||||
;; that has all the features we need.
|
||||
(define-values (need-maj need-min need-sub need-dev)
|
||||
(values 9 5 3 30))
|
||||
(values 9 5 3 31))
|
||||
|
||||
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
|
||||
(error 'compile-file
|
||||
|
|
|
|||
|
|
@ -49,11 +49,14 @@
|
|||
chaperone-continuation-mark-key
|
||||
call-with-system-wind ; not exported to Racket
|
||||
|
||||
call-with-current-continuation-roots ; not exported to Racket
|
||||
|
||||
;; not exported to Racket:
|
||||
make-engine
|
||||
engine-block
|
||||
engine-timeout
|
||||
engine-return
|
||||
engine-roots
|
||||
call-with-engine-completion
|
||||
set-ctl-c-handler!
|
||||
get-ctl-c-handler
|
||||
|
|
|
|||
|
|
@ -343,13 +343,14 @@
|
|||
#f)])
|
||||
(current-winders '())
|
||||
(current-mark-splice empty-mark-frame)
|
||||
(current-metacontinuation (cons mf (current-metacontinuation)))
|
||||
(let ([r (proc (current-metacontinuation))])
|
||||
(let ([mf (pop-metacontinuation-frame)])
|
||||
(#%call-in-continuation
|
||||
(metacontinuation-frame-resume-k mf)
|
||||
(metacontinuation-frame-marks mf)
|
||||
(lambda () r)))))))))))
|
||||
(let ([mc (cons mf (current-metacontinuation))])
|
||||
(current-metacontinuation '())
|
||||
(let ([r (proc mc)])
|
||||
(let ([mf (pop-metacontinuation-frame)])
|
||||
(#%call-in-continuation
|
||||
(metacontinuation-frame-resume-k mf)
|
||||
(metacontinuation-frame-marks mf)
|
||||
(lambda () r))))))))))))
|
||||
|
||||
(define (call-in-empty-metacontinuation-frame-for-compose proc)
|
||||
(call-getting-continuation-attachment
|
||||
|
|
@ -2058,3 +2059,10 @@
|
|||
(CHECK-uninterrupted
|
||||
(when (current-system-wind-start-k)
|
||||
(internal-error 'not-in-system-wind "assertion failed"))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (call-with-current-continuation-roots proc)
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(proc (cons k (current-metacontinuation))))))
|
||||
|
|
|
|||
|
|
@ -77,10 +77,10 @@
|
|||
init-break-enabled-cell))))
|
||||
|
||||
;; Internal: creates an engine procedure to be called within `call-with-engine-completion`
|
||||
;; or from an enginer procedure's `complete-or-expire` callback
|
||||
;; or from an engine procedure's `complete-or-expire` callback
|
||||
(define (create-engine to-saves proc cell-state)
|
||||
(case-lambda
|
||||
;; For `continuation-marks`:
|
||||
;; For `continuation-marks` and `engine-roots`:
|
||||
[() to-saves]
|
||||
;; Normal engine case:
|
||||
[(ticks prefix complete-or-expire)
|
||||
|
|
@ -185,6 +185,10 @@
|
|||
(current-engine-cell-state empty-engine-cell-state)
|
||||
(complete-or-expire #f results remain-ticks))))))
|
||||
|
||||
(define (engine-roots e)
|
||||
(let ([mc (e)])
|
||||
(cons e mc)))
|
||||
|
||||
(define (make-empty-thread-cell-values)
|
||||
(make-ephemeron-eq-hashtable))
|
||||
|
||||
|
|
|
|||
|
|
@ -524,58 +524,97 @@
|
|||
;; For `instantiate-linklet` to help report which linklet is being run:
|
||||
(define linklet-instantiate-key '#{linklet o9xm0uula3d2mbq9wueixh79r-1})
|
||||
|
||||
;; Limit on length of a context extracted from a continuation. This is
|
||||
;; not a hard limit on the total length, because it only applied to an
|
||||
;; individual frame in a metacontinuation, and it only applies to an
|
||||
;; extension of a cached context. But it keeps from tunrning an
|
||||
;; out-of-memory situation due to a deep continuation into one that
|
||||
;; uses even more memory.
|
||||
(define trace-length-limit 65535)
|
||||
|
||||
;; Convert a continuation to a list of function-name and
|
||||
;; source information. Cache the result half-way up the
|
||||
;; traversal, so that it's amortized constant time.
|
||||
(define-thread-local cached-traces (make-ephemeron-eq-hashtable))
|
||||
(define (continuation->trace k)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(let loop ([k k] [slow-k k] [move? #f] [attachments (continuation-next-attachments k)])
|
||||
(cond
|
||||
[(or (not (#%$continuation? k))
|
||||
(eq? k #%$null-continuation))
|
||||
(values slow-k '())]
|
||||
[(hashtable-ref cached-traces k #f)
|
||||
=> (lambda (l)
|
||||
(values slow-k l))]
|
||||
[else
|
||||
(let* ([next-attachments (continuation-next-attachments k)]
|
||||
[name (or (let ([n (and (not (eq? attachments next-attachments))
|
||||
(pair? attachments)
|
||||
(extract-mark-from-frame (car attachments) linklet-instantiate-key #f))])
|
||||
(and n
|
||||
(string->symbol (format "body of ~a" n))))
|
||||
(let* ([c (#%$continuation-return-code k)]
|
||||
[n (#%$code-name c)])
|
||||
(if (path-or-empty-procedure-name-string? n)
|
||||
#f
|
||||
(procedure-name-string->visible-name-string n))))]
|
||||
[desc
|
||||
(let* ([ci (#%$code-info (#%$continuation-return-code k))]
|
||||
[src (and
|
||||
(code-info? ci)
|
||||
(or
|
||||
;; when per-expression inspector info is available:
|
||||
(find-rpi (#%$continuation-return-offset k) ci)
|
||||
;; when only per-function source location is available:
|
||||
(code-info-src ci)))])
|
||||
(and (or name src)
|
||||
(cons name src)))])
|
||||
(#%$split-continuation k 0)
|
||||
(call-with-values
|
||||
(lambda () (loop (#%$continuation-link k)
|
||||
(if move? (#%$continuation-link slow-k) slow-k) (not move?)
|
||||
next-attachments))
|
||||
(lambda (slow-k l)
|
||||
(let ([l (if desc
|
||||
(cons desc l)
|
||||
l)])
|
||||
(when (eq? k slow-k)
|
||||
(hashtable-set! cached-traces k l))
|
||||
(values slow-k l)))))])))
|
||||
(lambda (slow-k l)
|
||||
l)))
|
||||
(let loop ([k k] [offset #f] [n 0] [accum '()] [accums '()] [slow-k k] [move? #f])
|
||||
(cond
|
||||
[(or (not (#%$continuation? k))
|
||||
(eq? k #%$null-continuation)
|
||||
(fx= n trace-length-limit))
|
||||
(finish-continuation-trace slow-k '() accum accums)]
|
||||
[(and (not offset)
|
||||
(hashtable-ref cached-traces k #f))
|
||||
=> (lambda (l)
|
||||
(finish-continuation-trace slow-k l accum accums))]
|
||||
[else
|
||||
(let* ([name (or (and (not offset)
|
||||
(let ([attachments (continuation-next-attachments k)])
|
||||
(and (pair? attachments)
|
||||
(not (eq? attachments (continuation-next-attachments (#%$continuation-link k))))
|
||||
(let ([n (extract-mark-from-frame (car attachments) linklet-instantiate-key #f)])
|
||||
(and n
|
||||
(string->symbol (format "body of ~a" n)))))))
|
||||
(let* ([c (if offset
|
||||
(#%$continuation-stack-return-code k offset)
|
||||
(#%$continuation-return-code k))]
|
||||
[n (#%$code-name c)])
|
||||
(if (path-or-empty-procedure-name-string? n)
|
||||
#f
|
||||
n)))]
|
||||
[desc
|
||||
(let* ([ci (#%$code-info (if offset
|
||||
(#%$continuation-stack-return-code k offset)
|
||||
(#%$continuation-return-code k)))]
|
||||
[src (and
|
||||
(code-info? ci)
|
||||
(or
|
||||
;; when per-expression inspector info is available:
|
||||
(find-rpi (if offset
|
||||
(#%$continuation-stack-return-offset k offset)
|
||||
(#%$continuation-return-offset k))
|
||||
ci)
|
||||
;; when only per-function source location is available:
|
||||
(code-info-src ci)))])
|
||||
(and (or name src)
|
||||
(cons name src)))])
|
||||
(let* ([offset (if offset
|
||||
(fx- offset (#%$continuation-stack-return-frame-words k offset))
|
||||
(fx- (#%$continuation-stack-clength k)
|
||||
(#%$continuation-return-frame-words k)))]
|
||||
[offset (if (fx= offset 0) #f offset)]
|
||||
[move? (and move? (not offset) (not (eq? k slow-k)))]
|
||||
[next-k (if offset k (#%$continuation-link k))]
|
||||
[accum (if desc (cons desc accum) accum)]
|
||||
[accums (if offset accums (cons (cons k accum) accums))]
|
||||
[accum (if offset accum '())])
|
||||
(loop next-k
|
||||
offset
|
||||
(fx+ n 1)
|
||||
accum accums
|
||||
(if move? (#%$continuation-link slow-k) slow-k) (not move?))))])))
|
||||
|
||||
;; `slow-k` is the place to cache, `l` is the tail of the result,
|
||||
;; `accum` is a list in reverse order to add to `l`, and `accums`
|
||||
;; is a list of `(cons k accum)` of `accum`s to add in reverse
|
||||
;; order, caching the result so far if `k` is `slow-k`
|
||||
(define (finish-continuation-trace slow-k l accum accums)
|
||||
(let ([reverse-onto
|
||||
(lambda (rev l)
|
||||
(let loop ([l l] [rev rev])
|
||||
(cond
|
||||
[(null? rev) l]
|
||||
[else (loop (cons (car rev) l)
|
||||
(cdr rev))])))])
|
||||
(let loop ([l (reverse-onto accum l)] [accums accums])
|
||||
(cond
|
||||
[(null? accums) l]
|
||||
[else
|
||||
(let* ([a (car accums)]
|
||||
[l (reverse-onto (cdr a) l)])
|
||||
(when (eq? (car a) slow-k)
|
||||
(hashtable-set! cached-traces slow-k l))
|
||||
(loop l (cdr accums)))]))))
|
||||
|
||||
(define primitive-names #f)
|
||||
(define (install-primitives-table! primitives)
|
||||
|
|
@ -614,7 +653,8 @@
|
|||
(loop (car ls) (cdr ls)))]
|
||||
[else
|
||||
(let* ([p (car l)]
|
||||
[name (car p)]
|
||||
[name (and (car p)
|
||||
(procedure-name-string->visible-name-string (car p)))]
|
||||
[loc (and (cdr p)
|
||||
(call-with-values (lambda ()
|
||||
(let* ([src (cdr p)]
|
||||
|
|
|
|||
|
|
@ -12,7 +12,9 @@
|
|||
[make-engine rumble:make-engine]
|
||||
[engine-timeout rumble:engine-timeout]
|
||||
[engine-return rumble:engine-return]
|
||||
[engine-roots rumble:engine-roots]
|
||||
[call-with-engine-completion rumble:call-with-engine-completion]
|
||||
[call-with-current-continuation-roots rumble:call-with-current-continuation-roots]
|
||||
[make-condition rumble:make-condition]
|
||||
[condition-wait rumble:condition-wait]
|
||||
[condition-signal rumble:condition-signal]
|
||||
|
|
@ -133,6 +135,7 @@
|
|||
'make-engine rumble:make-engine
|
||||
'engine-timeout rumble:engine-timeout
|
||||
'engine-return rumble:engine-return
|
||||
'engine-roots rumble:engine-roots
|
||||
'call-with-engine-completion rumble:call-with-engine-completion
|
||||
'set-ctl-c-handler! rumble:set-ctl-c-handler!
|
||||
'poll-will-executors poll-will-executors
|
||||
|
|
@ -161,7 +164,7 @@
|
|||
'fork-pthread rumble:fork-thread
|
||||
'get-initial-place rumble:get-initial-pthread
|
||||
'current-place-roots rumble:current-place-roots
|
||||
'call-with-current-pthread-continuation call/cc
|
||||
'call-with-current-continuation-roots rumble:call-with-current-continuation-roots
|
||||
'exit place-exit
|
||||
'pthread? rumble:thread?
|
||||
'call-as-asynchronous-callback rumble:call-as-asynchronous-callback
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 7
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 9
|
||||
#define MZSCHEME_VERSION_W 10
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ GLOBALS = --no-global \
|
|||
++global-ok "logging-future-events?" \
|
||||
++global-ok log-future-event \
|
||||
++global-ok "logging-place-events?" \
|
||||
++global-ok log-place-event
|
||||
|
||||
++global-ok log-place-event \
|
||||
++global-ok thread-engine-for-roots
|
||||
|
||||
GENERATE_ARGS = -t main.rkt \
|
||||
--check-depends $(BUILDDIR)compiled/thread-dep.rktd \
|
||||
|
|
|
|||
|
|
@ -239,6 +239,7 @@
|
|||
'engine-timeout engine-timeout
|
||||
'engine-return (lambda args
|
||||
(error "engine-return: not ready"))
|
||||
'engine-roots (lambda (e) '()) ; used only for memory accounting
|
||||
'call-with-engine-completion call-with-engine-completion
|
||||
'current-process-milliseconds current-process-milliseconds
|
||||
'set-ctl-c-handler! set-ctl-c-handler!
|
||||
|
|
@ -272,7 +273,7 @@
|
|||
'get-thread-id (lambda () 0)
|
||||
'current-place-roots (lambda () '())
|
||||
'get-initial-place (lambda () #f)
|
||||
'call-with-current-place-continuation call/cc
|
||||
'call-with-current-continuation-roots (lambda (proc) (proc null))
|
||||
'make-condition (lambda () (make-semaphore))
|
||||
'condition-wait (lambda (c s)
|
||||
(semaphore-post s)
|
||||
|
|
|
|||
|
|
@ -38,7 +38,8 @@
|
|||
check-queued-custodian-shutdown
|
||||
set-place-custodian-procs!
|
||||
set-post-shutdown-action!
|
||||
custodian-check-immediate-limit)
|
||||
custodian-check-immediate-limit
|
||||
set-thread-engine-for-roots!)
|
||||
|
||||
(module+ scheduling
|
||||
(provide do-custodian-shutdown-all
|
||||
|
|
@ -448,6 +449,13 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define thread-engine-for-roots (lambda (t) #f))
|
||||
|
||||
(define (set-thread-engine-for-roots! thread-engine)
|
||||
(set! thread-engine-for-roots thread-engine))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define futures-sync-for-custodian-shutdown (lambda () (void)))
|
||||
(define future-scheduler-add-thread-custodian-mapping! (lambda (s ht) (void)))
|
||||
|
||||
|
|
@ -471,8 +479,8 @@
|
|||
(lambda (call-with-size-increments)
|
||||
(if (zero? compute-memory-sizes)
|
||||
(call-with-size-increments null null (lambda (sizes custs) (void)))
|
||||
(host:call-with-current-place-continuation
|
||||
(lambda (starting-k)
|
||||
(host:call-with-current-continuation-roots
|
||||
(lambda (k-roots)
|
||||
;; 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-pthread mapping in this table:
|
||||
|
|
@ -527,10 +535,17 @@
|
|||
(define more-local-roots (cons (place-host-thread pl)
|
||||
new-local-roots))
|
||||
(if (eq? pl current-place) ; assuming host thread is place main thread
|
||||
(cons starting-k more-local-roots)
|
||||
(append k-roots more-local-roots)
|
||||
more-local-roots)]
|
||||
[else new-local-roots]))
|
||||
(loop (cdr roots) more-local-roots accum-roots accum-custs)]))))
|
||||
(define even-more-local-roots
|
||||
(cond
|
||||
[(thread-engine-for-roots root)
|
||||
;; scheduler runs in some thread's continuation, so
|
||||
;; gather a thread's continuation, just in case it's this one
|
||||
=> (lambda (e) (append (engine-roots e) more-local-roots))]
|
||||
[else more-local-roots]))
|
||||
(loop (cdr roots) even-more-local-roots accum-roots accum-custs)]))))
|
||||
(call-with-size-increments
|
||||
roots custs
|
||||
(lambda (sizes custs)
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@
|
|||
make-engine
|
||||
engine-timeout
|
||||
engine-return
|
||||
engine-roots
|
||||
call-with-engine-completion
|
||||
current-process-milliseconds
|
||||
set-ctl-c-handler!
|
||||
|
|
@ -81,7 +82,7 @@
|
|||
[exit host:exit]
|
||||
[current-place-roots host:current-place-roots]
|
||||
[get-initial-place host:get-initial-place]
|
||||
[call-with-current-pthread-continuation host:call-with-current-place-continuation]
|
||||
[call-with-current-continuation-roots host:call-with-current-continuation-roots]
|
||||
|
||||
fork-pthread
|
||||
pthread?
|
||||
|
|
|
|||
|
|
@ -117,15 +117,20 @@
|
|||
(loop child callbacks (lambda (callbacks) (loop g none-k callbacks)))])))
|
||||
|
||||
(define (swap-in-thread t leftover-ticks callbacks)
|
||||
(current-thread/in-atomic t)
|
||||
(define e (thread-engine t))
|
||||
(set-thread-engine! t 'running)
|
||||
;; Remove `e` from the thread in `check-breaks-prefix`, in case
|
||||
;; a GC happens between here and there, because `e` needs to
|
||||
;; be attached to the thread for accounting purposes at a GC.
|
||||
(set-thread-sched-info! t #f)
|
||||
(current-future (thread-future t))
|
||||
(current-thread/in-atomic t)
|
||||
(set-place-current-thread! current-place t)
|
||||
(set! thread-swap-count (add1 thread-swap-count))
|
||||
(run-callbacks-in-engine e callbacks t leftover-ticks))
|
||||
|
||||
(define (current-thread-now-running!)
|
||||
(set-thread-engine! (current-thread/in-atomic) 'running))
|
||||
|
||||
(define (swap-in-engine e t leftover-ticks)
|
||||
(let loop ([e e])
|
||||
(end-implicit-atomic-mode)
|
||||
|
|
@ -158,11 +163,11 @@
|
|||
(define new-leftover-ticks (- leftover-ticks (- TICKS remaining-ticks)))
|
||||
(accum-cpu-time! t (new-leftover-ticks . <= . 0))
|
||||
(set-thread-future! t (current-future))
|
||||
(current-thread/in-atomic #f)
|
||||
(current-future #f)
|
||||
(set-place-current-thread! current-place #f)
|
||||
(unless (eq? (thread-engine t) 'done)
|
||||
(set-thread-engine! t e))
|
||||
(current-thread/in-atomic #f)
|
||||
(poll-and-select-thread! new-leftover-ticks)]
|
||||
[else
|
||||
;; Swap out when the atomic region ends and at a point
|
||||
|
|
@ -172,6 +177,7 @@
|
|||
(loop e)])])))))
|
||||
|
||||
(define (check-break-prefix)
|
||||
(current-thread-now-running!)
|
||||
(check-for-break)
|
||||
(when atomic-timeout-callback
|
||||
(when (positive? (current-atomic))
|
||||
|
|
@ -226,8 +232,9 @@
|
|||
(e
|
||||
TICKS
|
||||
(if (pair? callbacks)
|
||||
;; run callbacks as a "prefix" callbacks
|
||||
;; run callbacks as a "prefix" callback
|
||||
(lambda ()
|
||||
(current-thread-now-running!)
|
||||
(run-callbacks callbacks)
|
||||
(set! done? #t)
|
||||
(engine-block))
|
||||
|
|
|
|||
|
|
@ -1024,3 +1024,11 @@
|
|||
(define mrefs (thread-custodian-references t))
|
||||
(unless (null? mrefs)
|
||||
(custodian-check-immediate-limit (car mrefs) n))))))
|
||||
|
||||
(void (set-thread-engine-for-roots!
|
||||
(lambda (v)
|
||||
(and (thread? v)
|
||||
(let ([e (thread-engine v)])
|
||||
(and (not (eq? e 'done))
|
||||
(not (eq? e 'running))
|
||||
e))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user