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

@@ -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]))

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

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

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 ([mc (cons mf (current-metacontinuation))])
-            (let ([r (proc (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)))))))))))
+                   (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))))))

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))
 

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
+  (let loop ([k k] [offset #f] [n 0] [accum '()] [accums '()] [slow-k k] [move? #f])
-   (lambda ()
-     (let loop ([k k] [slow-k k] [move? #f] [attachments (continuation-next-attachments k)])
     (cond
       [(or (not (#%$continuation? k))
-              (eq? k #%$null-continuation))
+           (eq? k #%$null-continuation)
-          (values slow-k '())]
+           (fx= n trace-length-limit))
-         [(hashtable-ref cached-traces k #f)
+       (finish-continuation-trace slow-k '() accum accums)]
+      [(and (not offset)
+            (hashtable-ref cached-traces k #f))
        => (lambda (l)
-               (values slow-k l))]
+            (finish-continuation-trace slow-k l accum accums))]
       [else
-          (let* ([next-attachments (continuation-next-attachments k)]
+       (let* ([name (or (and (not offset)
-                 [name (or (let ([n (and (not (eq? attachments next-attachments))
+                             (let ([attachments (continuation-next-attachments k)])
-                                         (pair? attachments)
+                               (and (pair? attachments)
-                                         (extract-mark-from-frame (car attachments) linklet-instantiate-key #f))])
+                                    (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))))
+                                           (string->symbol (format "body of ~a" n)))))))
-                           (let* ([c (#%$continuation-return-code k)]
+                        (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
-                                 (procedure-name-string->visible-name-string n))))]
+                              n)))]
               [desc
-                  (let* ([ci (#%$code-info (#%$continuation-return-code k))]
+               (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 (#%$continuation-return-offset k) ci)
+                             (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)))])
-            (#%$split-continuation k 0)
+         (let* ([offset (if offset
-            (call-with-values
+                            (fx- offset (#%$continuation-stack-return-frame-words k offset))
-             (lambda () (loop (#%$continuation-link k)
+                            (fx- (#%$continuation-stack-clength k)
-                              (if move? (#%$continuation-link slow-k) slow-k) (not move?)
+                                 (#%$continuation-return-frame-words k)))]
-                              next-attachments))
+                [offset (if (fx= offset 0) #f offset)]
-             (lambda (slow-k l)
+                [move? (and move? (not offset) (not (eq? k slow-k)))]
-               (let ([l (if desc
+                [next-k (if offset k (#%$continuation-link k))]
-                            (cons desc l)
+                [accum (if desc (cons desc accum) accum)]
-                            l)])
+                [accums (if offset accums (cons (cons k accum) accums))]
-                 (when (eq? k slow-k)
+                [accum (if offset accum '())])
-                   (hashtable-set! cached-traces k l))
+           (loop next-k
-                 (values slow-k l)))))])))
+                 offset
-   (lambda (slow-k l)
+                 (fx+ n 1)
-     l)))
+                 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)]

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

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

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 \

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)

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
+             (host:call-with-current-continuation-roots
-              (lambda (starting-k)
+              (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)

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?

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))

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))))))