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*
    (λ args
        (warning "Missing enclosing resetcc, called with args" args)
        (apply values args)))
  (define (delimcc-reset thunk)
    (let1 (mc *meta-continuation*)
          (letcc k
                 (set! *meta-continuation*
                   (λ args (set! *meta-continuation* mc) (apply k args)))
                 (receive args (thunk) (apply *meta-continuation* args)))))
  (define (delimcc-shift f)
    (letcc k
           (receive
             args*
             (f (λ args (resetcc (apply k args))))
             (apply *meta-continuation* args*))))
  (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-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.006)
 (memory #(12582912 3142040 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 3145016 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.001) (memory #(12582912 3143592 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 3147304 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 3148072 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 3149168 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 3147784 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 3151192 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 3143456 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 3144624 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 3144928 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 3148384 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 3151848 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.09) (memory #(12582912 3150072 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 3154080 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 3160184 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

Categories: scheme papers

Tags: monads callcc shift reset

Final shift for call/cc

Direct implementation of shift and reset