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 [1] by Kenichi Asai and Oleg Kiselyov. The former author [2] recorded a talk [3] that given in the workshop [4], slides [5] 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

(callcc (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

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

Implementation

(module
  (aux continuation delimited)
  *
  (import scheme (chicken base) (aux base) (aux continuation))
  (define-syntax-rule
    (resetcc body ...)
    (callcc (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 ...)
    (callcc (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-stack* identity)
  (define (delimcc-stack-abort v) (*delimcc-stack* v))
  (define (delimcc-stack-push! k) (set! *delimcc-stack* k))
  (define (delimcc-stack-pop!) *delimcc-stack*)
  (define ((delimcc-reset t) k)
    (let* ((s (delimcc-stack-pop!))
           (s* (λ (r) (delimcc-stack-push! s) (k r))))
      (delimcc-stack-push! s*)
      (delimcc-stack-abort (t))))
  (define ((delimcc-shift h) k)
    (delimcc-stack-abort (h (λ (v) (resetcc (k v))))))
  (define (delimcc-extract) (letcc/shift k k))
  (define (delimcc-discard v) (letcc/shift _ v))
  (define (delimcc-either lst) (letcc/shift k (map k lst)))
  (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-fold 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)))))))

Tests

`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.001) (memory #(12582912 2991992 1048576)) (stdout "") (stderr ""))

`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 2994688 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 2993672 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 2997136 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 2998120 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 2999216 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.001) (memory #(12582912 2997864 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 3001240 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.001) (memory #(12582912 3002888 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 3004056 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 2997304 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 3000688 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 3004160 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.091) (memory #(12582912 3001600 1048576)) (stdout "") (stderr ""))

References

[1] Introduction to Programming with Shift and Reset
[2] Professor Kenichi Asai's home page
[3] Delimited Continuations for Everyone by Kenichi Asai
[4] CW 2011 Tutorial: home page
[5] CW 2011 Tutorial: slides

Final shift for call/cc

Direct implementation of shift and reset