From c40a7ae2fcab8836649126dc730cb18c7c4aa47e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Jul 2020 06:58:12 -0600 Subject: [PATCH] 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. --- pkgs/base/info.rkt | 2 +- racket/src/cs/compile-file.ss | 2 +- racket/src/cs/rumble.sls | 3 + racket/src/cs/rumble/control.ss | 22 ++++-- racket/src/cs/rumble/engine.ss | 8 +- racket/src/cs/rumble/error.ss | 136 +++++++++++++++++++++----------- racket/src/cs/thread.sls | 5 +- racket/src/racket/src/schvers.h | 2 +- racket/src/thread/Makefile | 4 +- racket/src/thread/bootstrap.rkt | 3 +- racket/src/thread/custodian.rkt | 25 ++++-- racket/src/thread/host.rkt | 3 +- racket/src/thread/schedule.rkt | 15 +++- racket/src/thread/thread.rkt | 8 ++ 14 files changed, 164 insertions(+), 74 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 511b61416d..640c2677f7 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 33c2e42e52..cd6f631f27 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -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 diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 1123caa0c1..a85b74ac70 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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 diff --git a/racket/src/cs/rumble/control.ss b/racket/src/cs/rumble/control.ss index eb5e3016da..da8946d908 100644 --- a/racket/src/cs/rumble/control.ss +++ b/racket/src/cs/rumble/control.ss @@ -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)))))) diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss index 49822c9f81..0a1c1fef0b 100644 --- a/racket/src/cs/rumble/engine.ss +++ b/racket/src/cs/rumble/engine.ss @@ -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)) diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index a7fb885323..c9ed40977b 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -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)] diff --git a/racket/src/cs/thread.sls b/racket/src/cs/thread.sls index adf69fde11..aa0b013f94 100644 --- a/racket/src/cs/thread.sls +++ b/racket/src/cs/thread.sls @@ -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 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 90726b6481..0113ffa641 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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 diff --git a/racket/src/thread/Makefile b/racket/src/thread/Makefile index 42ff2a7fd8..59d86ded48 100644 --- a/racket/src/thread/Makefile +++ b/racket/src/thread/Makefile @@ -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 \ diff --git a/racket/src/thread/bootstrap.rkt b/racket/src/thread/bootstrap.rkt index 85cdd03ce1..d3e5884f2e 100644 --- a/racket/src/thread/bootstrap.rkt +++ b/racket/src/thread/bootstrap.rkt @@ -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) diff --git a/racket/src/thread/custodian.rkt b/racket/src/thread/custodian.rkt index c0ff393c7f..21a45380f8 100644 --- a/racket/src/thread/custodian.rkt +++ b/racket/src/thread/custodian.rkt @@ -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) diff --git a/racket/src/thread/host.rkt b/racket/src/thread/host.rkt index 1887145c40..4a77047878 100644 --- a/racket/src/thread/host.rkt +++ b/racket/src/thread/host.rkt @@ -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? diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 668a84c2f0..9b3bcd2b10 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -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)) diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index 49dec51779..8020530b4d 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -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))))))