Gasbichler, Martin and Sperber, Michael, 2002. Final shift for call/cc: direct implementation of shift and reset. In SIGPLAN Not., Association for Computing Machinery, New York, NY, USA, vol. 37, pp. 271–282.
Abstract: We present a direct implementation of the shift and reset control operators in the SFE system. The new implementation improves upon the traditional technique of simulating shift and reset via callcc. Typical applications of these operators exhibit space savings and a significant overall performance gain. Our technique is based upon the popular incremental stack/heap strategy for representing continuations. We present implementation details as well as some benchmark measurements for typical applications.

In this page we describe two fundamental macros, resetcc and letcc/shift respectively, that support all the other forms stressed in the tests that follows. Moreover, we show how to discard, extract, preserve, and wrap delimited continuations, accordingly to the tutorial Introduction to Programming with Shift and Reset by Kenichi Asai and Oleg Kiselyov. The former author Professor Kenichi Asai's home page recorded a talk Delimited Continuations for Everyone by Kenichi Asai that given in the workshop CW 2011 Tutorial: home page, slides CW 2011 Tutorial: slides are also available.

The `resetcc` macro

Continuations are delimited by the resetcc syntax as in the following generic expression

(resetcc body ...)

where the expressions body ... execute in a delimited context; for the sake of clarity, it expands to

(delimcc-reset (τ body ...))

The `letcc/shift` macro

The expression

(letcc/shift k body ...)

is explained by author's word:

❝
clears the current continuation
binds the cleared continuation to k
and executes body ...
Kenichi Asai

For the sake of clarity, it expands to

(delimcc-shift (λ (k) body ...))

Implementation

(module
  (aux continuation delimited)
  *
  (import
    scheme
    (only (scheme base) make-parameter)
    (chicken base)
    (only (chicken fixnum) fx+ fx- fxmax)
    srfi-1
    (aux base)
    (aux continuation))
  (define-syntax-rule (resetcc body ...) (delimcc-reset (τ body ...)))
  (define-syntax-rule (resetcc+null body ...) (resetcc body ... '()))
  (define-syntax
    define-resetcc
    (syntax-rules
      ()
      ((define-resetcc (def arg ...) body ...)
       (define def (λ (arg ...) (resetcc body ...))))
      ((define-resetcc def body ...) (define def (resetcc body ...)))))
  (define-syntax-rule
    (letcc/shift k body ...)
    (delimcc-shift (λ (k) body ...)))
  (define (callcc/shift f) (letcc/shift k (f k)))
  (define-syntax-rule
    (λ-shift args body ...)
    (letcc/shift k (λ args (let1 (x (begin body ...)) (k x)))))
  (define-syntax-rule (τ-shift body ...) (λ-shift () body ...))
  (define (delimcc-missing-reset . args)
    (warning "Missing enclosing resetcc, called with args" args)
    (apply values args))
  (define-record
    delimcc-frame
    k
    parent
    outer
    winds
    signalling
    state
    host
    escaped)
  (define delimcc-root-frame (make-delimcc-frame #f #f #f #f 0 'in #f #f))
  (define (delimcc-handlers-push handler handlers)
    (if (pair? handlers) (cons handler handlers) handler))
  (define (delimcc-handlers-call handlers c)
    (cond ((pair? handlers)
           (let1 (saved #f)
                 (##sys#dynamic-wind
                   (τ (set! saved ##sys#current-exception-handler)
                      (set! ##sys#current-exception-handler (cdr handlers)))
                   (τ ((car handlers) c))
                   (τ (set! ##sys#current-exception-handler saved)))))
          (else (handlers c))))
  (define delimcc-pop-exception-handler
    (and (##sys#symbol-has-toplevel-binding? '##sys#pop-exception-handler!)
         (##sys#slot '##sys#pop-exception-handler! 0)))
  (define (delimcc-raise-winds)
    (let1 (ws ##sys#dynamic-winds)
          (if (and delimcc-pop-exception-handler
                   (pair? ws)
                   (eq? (caar ws) delimcc-pop-exception-handler))
            (cdr ws)
            ws)))
  (define-inline (delimcc-frame-k/fast f) (##sys#slot f 1))
  (define-inline (delimcc-frame-parent/fast f) (##sys#slot f 2))
  (define-inline (delimcc-frame-winds/fast f) (##sys#slot f 4))
  (define-inline (delimcc-frame-signalling/fast f) (##sys#slot f 5))
  (define-inline (delimcc-frame-state/fast f) (##sys#slot f 6))
  (define-inline (delimcc-frame-outer/fast f) (##sys#slot f 3))
  (define-inline
    (delimcc-frame-signalling-set!/fast f n)
    (##sys#setislot f 5 n))
  (define-inline (delimcc-frame-state-set!/fast f s) (##sys#setslot f 6 s))
  (define-inline (delimcc-frame-host/fast f) (##sys#slot f 7))
  (define-inline
    (delimcc-frame-gone?/fast frame)
    (or (eq? (delimcc-frame-state/fast frame) 'left)
        (let1 (host (delimcc-frame-host/fast frame))
              (and host
                   (memq (delimcc-frame-state/fast host) '(left popped))
                   #t))
        (and (eq? (delimcc-frame-state/fast frame) 'escaping)
             (delimcc-frame-escaped-away? frame))))
  (define (delimcc-frame-escaped-away? frame)
    (let1 (winds (delimcc-frame-escaped frame))
          (and winds
               (eq? 0 (delimcc-frame-signalling/fast frame))
               (not (delimcc-within? winds)))))
  (define (delimcc-within? base)
    (let loop ((ws ##sys#dynamic-winds))
      (cond ((eq? ws base) #t) ((pair? ws) (loop (cdr ws))) (else #f))))
  (define delimcc-meta-continuation-thread-cell (make-parameter #f))
  (define delimcc-meta-continuation-cml-cell #f)
  (define (delimcc-settle! cell)
    (let1 (frame (cdr cell))
          (when (delimcc-frame-gone?/fast frame)
                (delimcc-frame-state-set! frame 'popped)
                (delimcc-frame-signalling-set! frame 0)
                (set-cdr! cell (delimcc-frame-parent frame))
                (delimcc-settle! cell)))
    cell)
  (define (delimcc-meta-continuation-cell)
    (let1 (cell (delimcc-meta-continuation-cell/raw))
          (if (delimcc-frame-gone?/fast (cdr cell))
            (delimcc-settle! cell)
            cell)))
  (define (delimcc-meta-continuation-cell/raw)
    (let1 (host 'aux.cml#%host-thread)
          (cond ((and (##sys#symbol-has-toplevel-binding? host)
                      (eq? (##sys#slot host 0) ##sys#current-thread))
                 (unless
                   delimcc-meta-continuation-cml-cell
                   (receive
                     (clear! get peek put!)
                     ((##sys#slot 'aux.cml#make-thread-property 0)
                      (τ (cons 'cml delimcc-root-frame)))
                     (set! delimcc-meta-continuation-cml-cell get)))
                 (delimcc-meta-continuation-cml-cell))
                (else
                 (let1 (cell (delimcc-meta-continuation-thread-cell))
                       (if (and cell (eq? (car cell) ##sys#current-thread))
                         cell
                         (let1 (cell (cons ##sys#current-thread delimcc-root-frame))
                               (delimcc-meta-continuation-thread-cell cell)
                               cell)))))))
  (define (delimcc-escape cell frame args)
    (cond ((eq? frame delimcc-root-frame) (apply delimcc-missing-reset args))
          (else
           (set-cdr! cell (delimcc-frame-parent/fast frame))
           (unless
             (eq? 0 (delimcc-frame-signalling/fast frame))
             (delimcc-frame-signalling-set! frame 0))
           (apply (delimcc-frame-k/fast frame) args))))
  (define (delimcc-return args)
    (let1 (cell (delimcc-meta-continuation-cell))
          (delimcc-escape cell (cdr cell) args)))
  (define (delimcc-signal c outer)
    (let loop ((frame (cdr (delimcc-meta-continuation-cell))))
      (cond ((eq? frame delimcc-root-frame) (delimcc-handlers-call outer c))
            ((not (eq? 0 (delimcc-frame-signalling/fast frame)))
             (loop (delimcc-frame-parent/fast frame)))
            (else
             (when (eq? (delimcc-frame-state/fast frame) 'escaping)
                   (delimcc-frame-state-set!/fast frame 'in))
             (let1 (returned #f)
                   (##sys#dynamic-wind
                     (τ (set! returned #f)
                        (delimcc-frame-escaped-set! frame #f)
                        (delimcc-frame-signalling-set!/fast
                          frame
                          (fx+ (delimcc-frame-signalling/fast frame) 1)))
                     (τ (receive
                          vs
                          (delimcc-handlers-call
                            (delimcc-frame-outer/fast frame)
                            c)
                          (set! returned #t)
                          (apply values vs)))
                     (τ (delimcc-frame-signalling-set!/fast
                          frame
                          (fxmax 0
                                 (fx- (delimcc-frame-signalling/fast frame) 1)))
                        (unless
                          (or returned
                              (not (eq? (delimcc-frame-state/fast frame) 'in)))
                          (delimcc-frame-state-set!/fast frame 'escaping)
                          (unless
                            (delimcc-within? (delimcc-frame-winds/fast frame))
                            (delimcc-frame-escaped-set!
                              frame
                              (delimcc-raise-winds)))))))))))
  (define (delimcc-reset thunk)
    (let1 (cell (delimcc-meta-continuation-cell))
          (letcc k
                 (let* ((parent (cdr cell))
                        (outer ##sys#current-exception-handler)
                        (host (if (eq? 0 (delimcc-frame-signalling/fast parent))
                                (delimcc-frame-host/fast parent)
                                parent))
                        (frame (make-delimcc-frame
                                 k
                                 parent
                                 outer
                                 #f
                                 0
                                 'in
                                 host
                                 #f))
                        (handler (λ (c) (delimcc-signal c outer))))
                   (set-cdr! cell frame)
                   (##sys#dynamic-wind
                     (τ (set! ##sys#current-exception-handler
                          (delimcc-handlers-push handler outer))
                        (case (delimcc-frame-state/fast frame)
                          ((left escaping)
                           (delimcc-frame-state-set! frame 'in))
                          ((popped)
                           (delimcc-frame-state-set! frame 'in)
                           (let1 (cell (delimcc-meta-continuation-cell))
                                 (when (eq? (cdr cell) parent)
                                       (set-cdr! cell frame))))))
                     (τ (delimcc-frame-winds-set! frame ##sys#dynamic-winds)
                        (receive args (thunk) (delimcc-return args)))
                     (τ (set! ##sys#current-exception-handler outer)
                        (when (or (not (eq? 0 (delimcc-frame-signalling/fast frame)))
                                  (eq? (delimcc-frame-state/fast frame) 'escaping))
                              (delimcc-frame-state-set! frame 'left))))))))
  (define (delimcc-unwind! base)
    (let loop ((segment '()))
      (let1 (ws ##sys#dynamic-winds)
            (cond ((eq? ws base) segment)
                  (else
                   (set! ##sys#dynamic-winds (cdr ws))
                   ((cdar ws))
                   (loop (cons (car ws) segment)))))))
  (define (delimcc-rewind! segment)
    (unless
      (null? segment)
      ((caar segment))
      (set! ##sys#dynamic-winds (cons (car segment) ##sys#dynamic-winds))
      (delimcc-rewind! (cdr segment))))
  (define (delimcc-shift f)
    (let* ((cell (delimcc-meta-continuation-cell))
           (base (delimcc-frame-winds/fast (cdr cell))))
      (define (return vs)
        (when (delimcc-frame-gone?/fast (cdr cell)) (delimcc-settle! cell))
        (delimcc-escape cell (cdr cell) vs))
      (if (delimcc-within? base)
        (##sys#call-with-current-continuation
          (λ (c)
             (let1 (segment (delimcc-unwind! base))
                   (receive
                     vs
                     (f (λ args
                           (resetcc (delimcc-rewind! segment) (apply c args))))
                     (return vs)))))
        (letcc k
               (receive
                 vs
                 (f (λ args (resetcc (apply k args))))
                 (return vs))))))
  (define (delimcc-extract) (letcc/shift k k))
  (define (delimcc-discard . args) (letcc/shift _ (apply values args)))
  (define (delimcc-either lst) (letcc/shift k (map k lst)))
  (define (delimcc-either/map f lst)
    (letcc/shift k (map (λ (v) (let1 (v* (f v)) (k v*))) lst)))
  (define (delimcc-either/append f lst)
    (letcc/shift k (append-map (λ (v) (let1 (v* (f v)) (k v*))) lst)))
  (define (delimcc-either/filter pred? lst)
    (letcc/shift
      k
      (filter-map (λ (v) (let1 (v* (pred? v)) (and v* (k v*)))) lst)))
  (define (delimcc-compose . fns) (letcc/shift k (apply compose (cons k fns))))
  (define (delimcc-state-get) (letcc/shift k (λ (state) ((k state) state))))
  (define (delimcc-state-put v) (letcc/shift k (λ (state) ((k state) v))))
  (define-syntax-rule
    (delimcc-state-monad init body ...)
    (let* ((t (τ body ...))
           (R (resetcc (let1 (result (t)) (λ (state) result)))))
      (R init)))
  (define (yield v) (letcc/shift k (cons v (k (void)))))
  (define (yield/extract v) (letcc/shift k (cons v k)))
  (define-syntax
    delimcc-foldr
    (syntax-rules
      ()
      ((delimcc-foldr bexpr ((each acc) fbody ...) body ...)
       (let* ((witness (gensym)) (b bexpr) (f (λ (each acc) fbody ...)))
         (define (L r)
           (cond ((eq? r witness) b)
                 (else (f (car r) (L (let1 (k (cdr r)) (k (void))))))))
         (L (resetcc body ... witness)))))))

`test/delimcc/basic`: pass

This test case introduces basic expressions to get introduced to delimited continuations.

(define (test/delimcc/basic _)
  (⊦= 10 (letcc/shift k 10))
  (⊦= '(1 2 10) (cons 1 (cons 2 (letcc/shift k (k (k '(10)))))))
  (⊦= '(1 2 2 10) (cons 1 (resetcc (cons 2 (letcc/shift k (k (k '(10))))))))
  (⊦= 41 (+ 1 (resetcc (* 2 (letcc/shift k (k (k 10)))))))
  (⊦= 15 (+ 10 (resetcc (+ 2 3))))
  (⊦= 13 (+ 10 (resetcc (+ 2 (letcc/shift k 3)))))
  (⊦= '(10 3) (cons 10 (resetcc (cons 2 (letcc/shift k '(3))))))
  (⊦= 15 (+ 10 (resetcc (+ 2 (letcc/shift k (k 3))))))
  (⊦= '(10 2 3) (cons 10 (resetcc (cons 2 (letcc/shift k (k '(3)))))))
  (⊦= 115 (+ 10 (resetcc (+ 2 (letcc/shift k (+ 100 (k 3)))))))
  (⊦= '(10 100 2 3)
      (cons 10 (resetcc (cons 2 (letcc/shift k (cons 100 (k '(3))))))))
  (⊦= 117 (+ 10 (resetcc (+ 2 (letcc/shift k (+ 100 (k (k 3))))))))
  (⊦= '(10 100 2 2 3)
      (cons 10 (resetcc (cons 2 (letcc/shift k (cons 100 (k (k '(3)))))))))
  (⊦= 117 (resetcc (+ 10 (resetcc (+ 2 (letcc/shift k (+ 100 (k (k 3)))))))))
  (⊦= '(10 100 2 2 3)
      (resetcc
        (cons 10 (resetcc (cons 2 (letcc/shift k (cons 100 (k (k '(3)))))))))))

((eta 0.0)
 (memory #(12582912 3987240 1048576))
 (stdout "")
 (stderr "\nWarning: Missing enclosing resetcc, called with args: (10)\n"))

`test/delimcc/tutorial/discard`: pass

(define (test/delimcc/tutorial/discard _)
  (⊦= 10 (resetcc (sub1 (+ 3 (letcc/shift k (* 5 2))))))
  (⊦= '(10) (resetcc (cdr (cons 3 (letcc/shift k (list (* 5 2)))))))
  (⊦= 9 (sub1 (resetcc (+ 3 (letcc/shift k (* 5 2))))))
  (⊦= '() (cdr (resetcc (cons 3 (letcc/shift k (list (* 5 2)))))))
  (⊦= 'hello (resetcc (sub1 (+ 3 (letcc/shift k 'hello))))))

((eta 0.0) (memory #(12582912 3989664 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/discard/prod`: pass

(define (test/delimcc/tutorial/discard/prod _)
  (define (prod lst)
    (cond ((null? lst) 1)
          ((zero? (car lst)) (delimcc-discard 'zero))
          (else (* (car lst) (prod (cdr lst))))))
  (⊦= 'zero (resetcc (prod '(2 3 0 5)))))

((eta 0.0) (memory #(12582912 3987608 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/extract`: pass

(define (test/delimcc/tutorial/extract _)
  (define-resetcc f (sub1 (+ 3 (letcc/shift k k))))
  (⊦= (sub1 (+ 3 10)) (f 10))
  (define-resetcc g (sub1 (+ 3 (delimcc-extract))))
  (⊦= 12 (g 10)))

((eta 0.0) (memory #(12582912 3992304 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/extract/appender`: pass

(define (test/delimcc/tutorial/extract/appender _)
  (define (appender lst)
    (cond ((null? lst) (delimcc-extract))
          (else (cons (car lst) (appender (cdr lst))))))
  (define-resetcc A (appender '(1 2 3)))
  (⊦= '(1 2 3 4 5 6) (A '(4 5 6))))

((eta 0.0) (memory #(12582912 3992888 1048576)) (stdout "") (stderr ""))

`test/delimcc/yield`: pass

(define (test/delimcc/yield _)
  (⊦= '(1) (resetcc+null (yield 1)))
  (⊦= '(1 2) (resetcc+null (yield 1) (yield 2))))

((eta 0.0) (memory #(12582912 3994176 1048576)) (stdout "") (stderr ""))

`test/delimcc/yield/extract`: pass

(define (test/delimcc/yield/extract _)
  (⊦= '((a 1) (a 2))
      (§->list
        (map§/yielded
          (λ (v) (list 'a v))
          (resetcc+null (yield/extract 1) (yield/extract 2)))))
  (⊦= 3
      (foldr/yielded + (resetcc+null (yield/extract 1) (yield/extract 2)) 0)))

((eta 0.0) (memory #(12582912 3992504 1048576)) (stdout "") (stderr ""))

`test/delimcc/yield§`: pass

(define (test/delimcc/yield§ _)
  (⊦= '(1) (§->list (resetcc+null (yield§ 1))))
  (⊦= '(1) (§->list (take§ 1 (resetcc+null (yield§ 1) (yield§ 2)))))
  (⊦= '(1 2) (§->list (resetcc+null (yield§ 1) (yield§ 2)))))

((eta 0.0) (memory #(12582912 3996504 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/yield§/walk`: pass

(define (test/delimcc/tutorial/yield§/walk _)
  (define (walk f tree)
    (cond ((null? tree) (void))
          (else (walk f (car tree)) (f (cadr tree)) (walk f (caddr tree)))))
  (⊦= '(1 2 3)
      (§->list (resetcc+null (walk yield§ª '((() 1 ()) 2 (() 3 ()))))))
  (⊦= 600
      (delimcc-foldr
        100
        ((each prod) (* each prod))
        (walk yield/extract '((() 1 ()) 2 (() 3 ()))))))

((eta 0.0) (memory #(12582912 3998360 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/either`: pass

(define (test/delimcc/tutorial/either _)
  (⊦= '(1 3 3) (resetcc (delimcc-either `(1 ,(add1 2) 3)))))

((eta 0.0) (memory #(12582912 3999720 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/either/tensor`: pass

(define (test/delimcc/tutorial/either/tensor _)
  (⊦= '(((p #t) (q #f)))
      (let1 (sols '())
            (resetcc
              (let ((p (delimcc-either '(#t #f)))
                    (q (delimcc-either '(#t #f))))
                (when (and (or p q) (or p (not q)) (or (not p) (not q)))
                      (push! `((p ,p) (q ,q)) sols))))
            sols))
  (⊦= '((((p #t) (q #t) no) ((p #t) (q #f) yes))
        (((p #f) (q #t) no) ((p #f) (q #f) no)))
      (resetcc
        (let ((p (delimcc-either '(#t #f))) (q (delimcc-either '(#t #f))))
          `((p ,p)
            (q ,q)
            ,(if (and (or p q) (or p (not q)) (or (not p) (not q)))
               'yes
               'no))))))

((eta 0.0) (memory #(12582912 3999352 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/τ`: pass

(define (test/delimcc/tutorial/τ _)
  (define-resetcc a (append (τ-shift '(hello)) '(world)))
  (⊦= '(hello world) (a)))

((eta 0.0) (memory #(12582912 4003504 1048576)) (stdout "") (stderr ""))

`test/delimcc/tutorial/λ`: pass

(define (test/delimcc/tutorial/λ _)
  (define-resetcc p (append '(hello) (λ-shift (x) (list x)) '(world)))
  (⊦= '(hello 4 world) (p 4)))

((eta 0.0) (memory #(12582912 4007616 1048576)) (stdout "") (stderr ""))

`test/delimcc/exception`: pass

A condition that leaves a resetcc for a handler outside of it leaves the enclosing resetcc as the target of the next shift, also when the handler escapes from within a resetcc of its own. A handler runs where the condition was raised, inside the resetcc: a shift there, as in a handler of a continuable signal that resumes the signalling code as an effect handler does, goes to that resetcc, which stays the current one also when the handler returns, when a guard re-raises in its context, and while the handler lets other CML threads run. A condition raised by a resumed shift continuation goes to the handler around the resume, not to the one around the resetcc that captured it, which has returned. A body that a continuation enters again after a handler escaped from it signals to the handler around it, as a body entered for the first time does. A condition also leaves the resetcc of a resume when a handle-exceptions or a guard in the resumed continuation has returned through its call/cc continuation, which brings back the context of the original resetcc: a generator, or a choice resumed once per alternative, that raises out of such a form does not stay the target of the next shift; a handler that escapes back into that context keeps it.

(define (test/delimcc/exception _)
  (define trace '())
  (⊦= 'shifted
      (resetcc
        (push! 'start trace)
        (push! (handle-exceptions e 'caught (resetcc (error "boom"))) trace)
        (letcc/shift k 'shifted)))
  (⊦= '(start caught) (reverse trace))
  (set! trace '())
  (⊦= 'shifted
      (resetcc
        (push! (letcc out
                      (with-exception-handler
                        (λ (c) (resetcc (list 'b (resetcc (out 'escaped)))))
                        (τ (list 'a
                                 (resetcc (list 'aa (raise-continuable 'boom)))))))
               trace)
        (letcc/shift k 'shifted)))
  (⊦= '(escaped) trace)
  (⊦= 111
      (with-exception-handler
        (λ (c) 10)
        (τ (resetcc (+ 1 (signal 'x) (letcc/shift k (k 100)))))))
  (define old-handler-calls 0)
  (define r
    (handle-exceptions
      e
      (begin (set! old-handler-calls (add1 old-handler-calls)) (λ (x) 'old))
      (resetcc
        (let1 (x (letcc/shift k k)) (if (= x 0) (error "zero") (list x))))))
  (⊦= '(1) (r 1))
  (⊦= '(caught "zero")
      (handle-exceptions
        e
        (list 'caught (get-condition-property e 'exn 'message))
        (r 0)))
  (⊦= 0 old-handler-calls)
  (⊦= '(h 6)
      (with-exception-handler
        (λ (c) (letcc/shift k (list 'h (k 5))))
        (τ (resetcc (+ 1 (signal 'x))))))
  (⊦= '(o (h 6 8))
      (resetcc
        (list 'o
              (with-exception-handler
                (λ (c) (letcc/shift k (list 'h (k 5) (k 7))))
                (τ (resetcc (+ 1 (signal 'x))))))))
  (⊦= 111
      (with-exception-handler
        (λ (c) 10)
        (τ (guard (e ((string? e) 'string))
                  (resetcc
                    (+ 1 (raise-continuable 'sym) (letcc/shift k (k 100))))))))
  (define r1 #f)
  (define r2 #f)
  (run-cml
    (τ (let ((t1 (spawn (τ (set! r1
                             (with-exception-handler
                               (λ (c) (cml/yield) (cml/yield) 'handled)
                               (τ (resetcc
                                    (let1 (x (signal 'cont))
                                          (list x (letcc/shift k 'shifted))))))))))
             (t2 (spawn (τ (set! r2 (resetcc (cml/yield) 'b-normal))))))
         (sync (join-evt t1))
         (sync (join-evt t2)))))
  (⊦= 'shifted r1)
  (⊦= 'b-normal r2)
  (define out #f)
  (define re #f)
  (define n 0)
  (⊦= '(body-got (mid second))
      (with-exception-handler
        (λ (c) (list 'top c))
        (τ (resetcc
             (with-exception-handler
               (λ (c) (if (eq? c 'first) (out 'escaped) (list 'mid c)))
               (τ (let1 (v (letcc o
                                  (set! out o)
                                  (resetcc
                                    (letcc k (set! re k))
                                    (set! n (add1 n))
                                    (if (= n 1)
                                      (signal 'first)
                                      (list 'body-got (signal 'second))))))
                        (if (eq? v 'escaped) (re #f) v))))))))
  (define (message e) (get-condition-property e 'exn 'message))
  (set! trace '())
  (⊦= 'shifted
      (resetcc
        (push! (handle-exceptions
                 c
                 (list 'top c)
                 (resetcc
                   (list (handle-exceptions
                           c
                           'caught
                           (letcc/shift e (list 'hs (e 5))))
                         (signal 'sg))))
               trace)
        (letcc/shift k 'shifted)))
  (⊦= '((top sg)) trace)
  (set! trace '())
  (⊦= 'shifted
      (resetcc
        (push! (guard (e (#t (list 'top e)))
                      (resetcc
                        (list (guard (e ((string? e) 'caught))
                                     (letcc/shift e (list 'hs (e 5))))
                              (raise 'boom))))
               trace)
        (letcc/shift k 'shifted)))
  (⊦= '((top boom)) trace)
  (set! trace '())
  (define g3
    (resetcc
      (handle-exceptions e 'caught (yield/extract 1))
      (error "gen-fail")
      '()))
  (⊦= 'shifted
      (resetcc
        (push! (handle-exceptions
                 e
                 (list 'caught (message e))
                 ((cdr g3) (void)))
               trace)
        (letcc/shift k 'shifted)))
  (⊦= '((caught "gen-fail")) trace)
  (set! trace '())
  (⊦= 'shifted
      (resetcc
        (push! (handle-exceptions
                 e
                 (list 'caught (message e))
                 (resetcc
                   (let1 (x (handle-exceptions
                              e
                              'inner
                              (delimcc-either '(1 2 3))))
                         (if (= x 2) (error "boom") x))))
               trace)
        (letcc/shift k 'shifted)))
  (⊦= '((caught "boom")) trace)
  (⊦= '(hs (5 recover))
      (with-exception-handler
        (λ (c) ((car c) 'recover))
        (τ (resetcc
             (list (handle-exceptions
                     c
                     'caught
                     (letcc/shift e (list 'hs (e 5))))
                   (letcc j (signal (list j)))))))))

((eta 0.0) (memory #(12582912 4012152 1048576)) (stdout "") (stderr ""))

`test/delimcc/threads`: pass

Each srfi-18 thread has its own meta-continuation: a thread shifting while another one sits in its resetcc does not return to it, and a thread started inside a resetcc body is not inside it. A shift continuation captured in a thread returns to the resetcc of the thread that resumes it.

(define (test/delimcc/threads _)
  (define a
    (make-thread
      (τ (resetcc (thread-sleep! 0.05) (letcc/shift k 'a-shifted)))))
  (define b (make-thread (τ (resetcc (thread-sleep! 0.2) 'b-normal))))
  (thread-start! a)
  (thread-sleep! 0.01)
  (thread-start! b)
  (⊦= 'a-shifted (thread-join! a))
  (⊦= 'b-normal (thread-join! b))
  (⊦= '(parent child-shifted)
      (resetcc
        (list 'parent
              (thread-join!
                (thread-start!
                  (make-thread (τ (letcc/shift k 'child-shifted))))))))
  (define g #f)
  (thread-join!
    (thread-start!
      (make-thread (τ (set! g (resetcc (list 'a (letcc/shift k k))))))))
  (⊦= '(a 1) (g 1))
  (⊦= '(a 2) (thread-join! (thread-start! (make-thread (τ (g 2)))))))

((eta 0.001)
 (memory #(12582912 4014000 1048576))
 (stdout "")
 (stderr
   "\nWarning: Missing enclosing resetcc, called with args: (child-shifted)\n"))

`test/delimcc/cml`: pass

Each thread of (aux cml), although all of them run within one srfi-18 thread, has its own meta-continuation too, and another srfi-18 thread, running no CML while CML threads switch in the first one, keeps one for all its resets; the one of a CML thread goes with the thread, also when it dies inside a resetcc.

(define (test/delimcc/cml _)
  (define ra #f)
  (define rb #f)
  (run-cml
    (τ (let ((a (spawn (τ (set! ra
                            (resetcc
                              (cml/yield)
                              (cml/yield)
                              (letcc/shift k 'a-shifted))))))
             (b (spawn (τ (set! rb
                            (resetcc
                              (cml/yield)
                              (cml/yield)
                              (cml/yield)
                              (cml/yield)
                              'b-normal))))))
         (sync (join-evt a))
         (sync (join-evt b)))))
  (⊦= 'a-shifted ra)
  (⊦= 'b-normal rb)
  (define results '())
  (define worker
    (make-thread
      (τ (do ((i 0 (add1 i)))
             ((= i 50))
           (push! (resetcc (thread-yield!) (letcc/shift k 'shifted))
                  results)))))
  (thread-start! worker)
  (run-cml
    (τ (for-each
         (λ (t) (sync (join-evt t)))
         (map (λ (n)
                 (spawn (τ (do ((i 0 (add1 i)))
                               ((= i 200))
                             (thread-yield!)
                             (cml/yield)))))
              '(1 2)))))
  (thread-join! worker)
  (⊦= 50 (length results))
  (⊦= results (map (λ (r) 'shifted) results))
  (define freed 0)
  (define (dying i)
    (let1 (v (make-vector 10 i))
          (set-finalizer! v (λ (v) (set! freed (add1 freed))))
          (list (resetcc
                  (cml/yield)
                  (if (even? i) (cml/exit) (error "dying inside a resetcc")))
                v)))
  (run-cml
    (τ (do ((i 0 (add1 i)))
           ((= i 100))
         (sync (join-evt (spawn (τ (dying i))))))
       (gc #t)))
  (gc #t)
  (⊨ (<= 90 freed)))

((eta 0.015)
 (memory #(12582912 4023504 1048576))
 (stdout "")
 (stderr
   "\ncml: thread [000004] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000006] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000008] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000010] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000012] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000014] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000016] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000018] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000020] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000022] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000024] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000026] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000028] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000030] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000032] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000034] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000036] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000038] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000040] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000042] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000044] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000046] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000048] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000050] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000052] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000054] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000056] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000058] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000060] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000062] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000064] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000066] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000068] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000070] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000072] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000074] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000076] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000078] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000080] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000082] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000084] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000086] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000088] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000090] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000092] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000094] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000096] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000098] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000100] died of an uncaught exception: dying inside a resetcc\n\ncml: thread [000102] died of an uncaught exception: dying inside a resetcc\n"))

`test/delimcc/dynamic-wind`: pass

Every resume of a delimited continuation re-enters the dynamic-wind frames, hence the parameterize forms, between the shift and its reset. A limitation: a resume from within a resumption of the same continuation enters those frames while they are still active, and there a parameterize, which swaps the parameter's value with a saved one, gives the value from where the first resumption entered it instead of its binding; sequential resumes, as here, are not affected.

(define (test/delimcc/dynamic-wind _)
  (define q (make-parameter 'outer))
  (define-resetcc
    r
    (parameterize ((q 'inner)) (let1 (x (letcc/shift k k)) (list x (q)))))
  (⊦= 'outer (q))
  (⊦= '(1 inner) (r 1))
  (⊦= '(2 inner) (r 2))
  (⊦= 'outer (q))
  (define depth 0)
  (define-resetcc
    w
    (dynamic-wind
      (τ (set! depth (add1 depth)))
      (τ (let1 (x (letcc/shift k k)) (list x depth)))
      (τ (set! depth (sub1 depth)))))
  (⊦= 0 depth)
  (⊦= '(1 1) (w 1))
  (⊦= '(2 1) (w 2))
  (⊦= 0 depth))

((eta 0.0) (memory #(12582912 4017648 1048576)) (stdout "") (stderr ""))

`test/delimcc/resume-site`: pass

A delimited continuation holds nothing of the context outside its reset: resumed, it sees the parameters and signals to the handlers in force around the resume.

(define (test/delimcc/resume-site _)
  (define p (make-parameter 'outer))
  (define g
    (resetcc (yield/extract 1) (yield/extract (p)) (error "gen-fail") '()))
  (define g2 (parameterize ((p 'consumer)) ((cdr g) (void))))
  (⊦= 'consumer (car g2))
  (⊦= 'outer (p))
  (⊦= '(caught "gen-fail")
      (handle-exceptions
        e
        (list 'caught (get-condition-property e 'exn 'message))
        ((cdr g2) (void)))))

((eta 0.0) (memory #(12582912 4023848 1048576)) (stdout "") (stderr ""))

`test/delimcc/resume-site/call/cc`: pass

Only the continuation of the shift is delimited: one captured by call/cc between the shift and its reset, as handle-exceptions does (it returns through it), brings back the whole context of its capture when the resumed continuation takes it. Here the generator resumed under a parameterize sees the parameter of its creation after its handle-exceptions returns, and resuming h runs the before and after thunks around the original reset again.

(define (test/delimcc/resume-site/call/cc _)
  (define p (make-parameter 'outer))
  (define g
    (resetcc
      (handle-exceptions e 'caught (yield/extract 1))
      (yield/extract (p))
      '()))
  (⊦= 'outer (car (parameterize ((p 'consumer)) ((cdr g) (void)))))
  (define winds '())
  (define h
    (dynamic-wind
      (τ (push! 'in winds))
      (τ (resetcc (handle-exceptions e 'caught (list (letcc/shift k k)))))
      (τ (push! 'out winds))))
  (set! winds '())
  (⊦= '(1) (h 1))
  (⊦= '(in out) (reverse winds)))

((eta 0.0) (memory #(12582912 4025400 1048576)) (stdout "") (stderr ""))

`test/letcc/delimcc+monad`: pass

(define (test/letcc/delimcc+monad _)
  (define (reflect meaning) (letcc/shift k (extend k meaning)))
  (define (reify* t) (resetcc (eta (t))))
  (define (eta x) (list x))
  (define (extend f l) (apply append (map f l)))
  (define-syntax
    reify
    (syntax-rules () ((reify body ...) (reify* (τ body ...)))))
  (define-syntax
    amb
    (syntax-rules () ((amb v ...) (reflect (append (reify v) ...)))))
  (⊦= '(1 2 3) (reify (amb 1 2 3)))
  (⊦= '((1 3 4) (1 3 5) (2 3 4) (2 3 5)) (reify (list (amb 1 2) 3 (amb 4 5))))
  (⊦= '((1 10 3) (1 10 1 4))
      (reify (cons 1 (letcc k (cons 10 (amb '(3) (k '(4))))))))
  (define (www)
    (define (f x) (append x (list (amb 6 4 2 8) (amb 2 4 5 4 1))))
    (reify (f (f (amb '(0) '(2) '(3) '(4) '(5) '(32))))))
  (⊦= www-expected (www))
  (⊦= 2400 (length www-expected))
  (define (wwww)
    (define (f x) (+ x (amb 6 4 2 8) (amb 2 4 5 4 1)))
    (reify (f (f (f (amb 0 2 3 4 5 32))))))
  (⊦= 48000 (length (wwww))))

((eta 0.176) (memory #(12582912 5371440 1048576)) (stdout "") (stderr ""))

`test/asai-pwl-talk/take`: pass

Given a list lst and a number n, the function T returns a list that is the same as lst but with the n-th element moved to the front. The test cases show that if n is zero or greater than the length of the list, the result is the same as the input list.

(define (test/asai-pwl-talk/take _)
  (define (T lst n)
    (letrec ((L (λ (lst n)
                   (match/first
                     lst
                     (() '())
                     ((,a unquote d)
                      (cond ((= n 0) (letcc/shift k (cons a (k d))))
                            (else `(,a unquote (L d (sub1 n))))))))))
      (resetcc (L lst n))))
  (⊦= '(0 1 2 3 4) (T '(0 1 2 3 4) 0))
  (⊦= '(0 1 2 3 4) (T '(0 1 2 3 4) 5))
  (⊦= '(3 0 1 2 4) (T '(0 1 2 3 4) 3))
  (⊦= '(1 0 2 3 4) (T '(0 1 2 3 4) 1)))

((eta 0.0) (memory #(12582912 5376128 1048576)) (stdout "") (stderr ""))

`test/asai-pwl-talk/anf`: pass

Given an S-expression expr and a variable name v, the function anf/let transforms expr into an A-normal form, where all intermediate results are (uniquely) named by a let-binding. The test case shows that the expression <->a <->bcd is transformed into an A-normal form where the intermediate result of <->bcd is named by a let-binding with variable name α.

(define (test/asai-pwl-talk/anf _)
  (define (anf/let expr w)
    (letrec ((count 0)
             (L (λ (e)
                   (match/first
                     e
                     ((λ (,v) unquote d)
                      `(λ (,v) unquote (map (λ (e) (resetcc (L e))) d)))
                     ((,a unquote d)
                      (letcc/shift
                        k
                        (let ((w (symbol-append
                                   w
                                   (string->symbol (number->string count))))
                              (_ (add1! count))
                              (a* (L a))
                              (d* (map L d)))
                          `(let1 (,w (,a* unquote d*)) ,(k w)))))
                     (,v v)))))
      (resetcc (L expr))))
  (define (anf/λ expr w)
    (letrec ((count 0)
             (L (λ1-match/first
                  ((λ (,v) unquote d)
                   `(λ (,v) unquote (map (λ (e) (resetcc (L e))) d)))
                  ((,a unquote d)
                   (letcc/shift
                     k
                     (let ((w (symbol-append
                                w
                                (string->symbol (number->string count))))
                           (_ (add1! count))
                           (a* (L a))
                           (d* (map L d)))
                       `((λ (,w) ,(k w)) (,a* unquote d*)))))
                  (,v v))))
      (resetcc (L expr))))
  (⊦= '(let1 (α1 (- b c d)) (let1 (α0 (- a α1)) α0))
      (anf/let '(- a (- b c d)) 'α))
  (⊦= '((λ (α1) ((λ (α0) α0) (- a α1))) (- b c d)) (anf/λ '(- a (- b c d)) 'α))
  (⊦= '((λ (α2) ((λ (α1) ((λ (α0) α0) (- a α1))) (+ b α2))) (/ c d))
      (anf/λ '(- a (+ b (/ c d))) 'α))
  (⊦= '((λ (α1) ((λ (α2) ((λ (α0) α0) (if α1 0 α2))) (void))) (null? l))
      (anf/λ '(if (null? l) 0 (void)) 'α))
  (⊦= '((λ (α1)
           ((λ (α4)
               ((λ (α3)
                   ((λ (α5) ((λ (α2) ((λ (α0) α0) (if α1 0 α2))) (if α3 1 α5)))
                    (void)))
                (null? α4)))
            (cdr l)))
        (null? l))
      (anf/λ '(if (null? l) 0 (if (null? (cdr l)) 1 (void))) 'α))
  (⊦= '((λ (α1)
           ((λ (α4)
               ((λ (α3)
                   ((λ (α7)
                       ((λ (α6)
                           ((λ (α8)
                               ((λ (α5)
                                   ((λ (α2) ((λ (α0) α0) (if α1 0 α2)))
                                    (if α3 1 α5)))
                                (if α6 2 α8)))
                            (void)))
                        (null? α7)))
                    (cdr l)))
                (null? α4)))
            (cdr l)))
        (null? l))
      (anf/λ '(if (null? l)
                0
                (if (null? (cdr l)) 1 (if (null? (cdr l)) 2 (void))))
             'α))
  (⊦= '(λ (x)
          (λ (y)
             (λ (z)
                (let1 (α1 (x z)) (let1 (α2 (y z)) (let1 (α0 (α1 α2)) α0))))))
      (anf/let '(λ (x) (λ (y) (λ (z) ((x z) (y z))))) 'α))
  (⊦= '(λ (x)
          (λ (y)
             (λ (z) ((λ (α1) ((λ (α2) ((λ (α0) α0) (α1 α2))) (y z))) (x z)))))
      (anf/λ '(λ (x) (λ (y) (λ (z) ((x z) (y z))))) 'α)))

((eta 0.0) (memory #(12582912 4031920 1048576)) (stdout "") (stderr ""))

Categories: scheme papers

Tags: monads callcc shift reset

Final shift for call/cc

Direct implementation of shift and reset