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

(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 (chicken base) 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 *meta-continuation*
    (λ (v) (warning "Missing enclosing resetcc" v) v))
  (define (delimcc-reset thunk)
    (let1 (mc *meta-continuation*)
          (letcc k
                 (set! *meta-continuation*
                   (λ (v) (set! *meta-continuation* mc) (k v)))
                 (let1 (v (thunk)) (*meta-continuation* v)))))
  (define (delimcc-shift f)
    (letcc k
           (let1 (v* (f (λ (v) (resetcc (k v))))) (*meta-continuation* 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 (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 (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.005)
 (memory #(12582912 3031224 1048576))
 (stdout "")
 (stderr "\nWarning: Missing enclosing resetcc: 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 3034264 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 3032904 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 3036552 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 3037352 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 3038448 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 3037096 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.001) (memory #(12582912 3040472 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 3042120 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.001) (memory #(12582912 3043288 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.001) (memory #(12582912 3041480 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 3044904 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 3048336 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.081) (memory #(12582912 3047632 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 3051256 1048576)) (stdout "") (stderr ""))

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

Given an S-expression expr and a variable name v, the function anf 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 expr v)
    (letrec ((L (λ (e)
                    (match/first
                      e
                      ((,a unquote d)
                       (let ((d* (map L d)))
                         (letcc/shift k `(let1 (,v (,a ,@d*)) ,(k v)))))
                      (,v v)))))
      (resetcc (L expr))))
  (⊦= '(let1 (α (- b c d)) (let1 (α (- a α)) α))
        (anf '(- a (- b c d)) 'α)))

((eta 0.0) (memory #(12582912 3053488 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