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

`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 3134888 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 3137864 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 3136440 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.001) (memory #(12582912 3140152 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 3140920 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 3142016 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 3140632 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 3144040 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 3145688 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 3146856 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 3145016 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 3148472 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 3151936 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.092) (memory #(12582912 3151568 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.001) (memory #(12582912 3155536 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.001) (memory #(12582912 3158904 1048576)) (stdout "") (stderr ""))

Categories: scheme papers

Tags: monads callcc shift reset

Final shift for call/cc

Direct implementation of shift and reset