動機

整理continuation與CPS轉換

用法

cont可以當成一種很強的return或是goto，但是可以當成函數用

(let ((val (callcc (lambda (k) (k k)))))
  (set! cont k)
  (display k))

(cont 10)
(cont 20)

只要調用cont就會回去當初執行callcc的那一行，所以可以用它來跳來跳去

應用

dynamic-wind

類似prehook與posthook，只是有在裡面執行或是要到裡面，就一定會跑prehook與posthook

下面是其中一種實作，stack放(prehook . afterhook)，之後就是對callcc動手腳，只要有人call就去跑整個stack

(define *here* (list #f))

(define origin-callcc call-with-current-continuation)

(define (call-with-current-continuation proc)
    (let ((here *here*))
        (origin-callcc (lambda (cont)
            (proc
                (lambda results
                    (reroot! here) ;; 包一層
                    (apply cont results)))))))

(define (dynamic-wind before during after)
    (let ((here *here*))
        (reroot! (cons (cons before after) here))
        (call-with-values during (lambda results
                                    (reroot! here)
                                    (apply values results)))))

(define (reroot! there)
    (if (not (eq? *here* there))
        (begin
            (reroot! (cdr there))
            (let ((before (caar there))
                  (after (cdar there)))
                (set-car! *here* (cons after before)) ;; reverse before after, so next time after will be invoke!!
                (set-cdr! *here* there)
                (set-car! there #f)
                (set-cdr! there '())
                (set! *here* there)
                (before)))))

exception

一個stack放fail時要跳回去那邊的cont

dynamic-wind是確保，cont被call時一定會pop stack 從cont進去時會把stack建回去 (在exception不需要就是了)

(define-syntax try 
  (syntax-rules (catch)
    ((_ exp ... catch proc) 
     ; =>
     (let ((cc (current-continuation)))
       (cond
         ((procedure? cc)
          (dynamic-wind 
           (lambda ()
             (set! exception-stack (cons cc exception-stack)))
           (lambda ()
             exp ...)
           (lambda ()
             (set! exception-stack (cdr exception-stack)))))
         
         ((pair? cc) 
          (proc (cadr cc))))))))

(define (throw exception-value)
  (let ((handler (car exception-stack)))
    (handler (list 'exception exception-value))))

(try (try (throw 'foo)
          catch
          (lambda (exn)
            (display "got inner exception: ")
            (display exn)
            (newline)
            (throw 'bar)))
     catch
     (lambda (exn)
       (display "got outer exception: ")
       (display exn)
       (newline)))

non-determing computing

一個stack放fail時要跳回去那邊的cont

(define (current-continuation) 
  (call-with-current-continuation 
   (lambda (cc)
     (cc cc))))

; fail-stack : list[continuation]
(define fail-stack '())

; fail : -> ...
(define (fail)
  (if (not (pair? fail-stack))
      (error "back-tracking stack exhausted!")
      (begin
        (let ((back-track-point (car fail-stack)))
          (set! fail-stack (cdr fail-stack))
          (back-track-point back-track-point)))))

; amb : list[a] -> a
(define (amb choices)
  (let ((cc (current-continuation)))
    (cond
      ((null? choices)      (fail))
      ((pair? choices)      (let ((choice (car choices)))
                              (set! choices (cdr choices))
                              (set! fail-stack (cons cc fail-stack))
                              choice)))))

(define (assert condition)
  (or condition (fail)))

; The following prints (4 3 5)
(let ((a (amb (list 1 2 3 4 5 6 7)))
      (b (amb (list 1 2 3 4 5 6 7)))
      (c (amb (list 1 2 3 4 5 6 7))))
  (assert (= (* c c) (+ (* a a) (* b b)))))

generator

一個ptr指向目前generator停下來的位置，另外為了讓generator好看，所以把生generator的cont交給make-yield

所以每次yield就會把val與cont丟回去

(define (current-continuation) 
  (call-with-current-continuation
   (lambda (cc)
     (cc cc))))

; void : -> void
(define (void)
  (if #f #t))

; tree-iterator : tree -> generator
(define (tree-iterator tree)
  (lambda (yield)
    (define (walk tree)
      (if (not (pair? tree))
          (yield tree)
          (begin
            (walk (car tree))
            (walk (cdr tree)))))
    
    (walk tree)))

; make-yield : continuation -> (value -> ...)
(define (make-yield for-cc)
  (lambda (value)
    (let ((cc (current-continuation)))
      (if (procedure? cc)
          (for-cc (cons cc value))
          (void)))))

; (for v in generator body) will execute body 
; with v bound to successive values supplied
; by generator.
(define-syntax for
  (syntax-rules (in)
    ((_ v in iterator body ...)
     ; => 
     (let ((iterator-cont #f))
       (letrec ((loop (lambda ()
                        (let ((cc (current-continuation)))
                          (if (procedure? cc)
                              (if iterator-cont
                                  (iterator-cont (void))
                                  (iterator (make-yield cc)))
                              (let ((it-cont (car cc))
                                    (it-val  (cdr cc)))
                                (set! iterator-cont it-cont)
                                (let ((v it-val))
                                  body ...)
                                (loop)))))))
         (loop))))))

(for v in (tree-iterator '(3 . ( ( 4 . 5 ) . 6 ) )) 
  (display v)
  (newline))

thread

前面是把cont塞到stack，這裡放到queue去!!

; thread-queue : list[continuation]
(define thread-queue '())

; halt : continuation
(define halt #f)

; void : -> void
(define (void) (if #f #t))

; current-continuation : -> continuation
(define (current-continuation)
  (call-with-current-continuation
   (lambda (cc)
     (cc cc))))

; spawn : (-> anything) -> void
(define (spawn thunk)
  (let ((cc (current-continuation)))
    (if (procedure? cc)
        (set! thread-queue (append thread-queue (list cc)))
        (begin (thunk)
               (quit)))))

; yield : value -> void
(define (yield)
  (let ((cc (current-continuation)))
    (if (and (procedure? cc) (pair? thread-queue))
        (let ((next-thread (car thread-queue)))
          (set! thread-queue (append (cdr thread-queue) (list cc)))
          (next-thread 'resume))
        (void))))

; quit : -> ...
(define (quit)
  (if (pair? thread-queue)
      (let ((next-thread (car thread-queue)))
        (set! thread-queue (cdr thread-queue))
        (next-thread 'resume))
      (halt)))
   
; start-threads : -> ...
(define (start-threads)
  (let ((cc (current-continuation)))
    (if cc
        (begin
          (set! halt (lambda () (cc #f)))
          (if (null? thread-queue)
              (void)
              (begin
                (let ((next-thread (car thread-queue)))
                  (set! thread-queue (cdr thread-queue))
                  (next-thread 'resume)))))
        (void))))

;; Example cooperatively threaded program
(define counter 10)

(define (make-thread-thunk name)
  (letrec ((loop (lambda ()
                   (if (< counter 0)
                       (quit))
                   (display "in thread ")
                   (display name)
                   (display "; counter = ")
                   (display counter)
                   (newline)
                   (set! counter (- counter 1))
                   (yield)
                   (loop))))
    loop))

(spawn (make-thread-thunk 'a))
(spawn (make-thread-thunk 'b))
(spawn (make-thread-thunk 'c))

(start-threads)

cont monad

monad就是消滅傳遞參數的過程，下面來複習cont monad

先基本的cps

(define (id x) x)
(define (fib1 n k)
    (if (<= n 1)
        (k 1)
        (fib1 (- n 1)
            (lambda (v1)
                (fib1 (- n 2)
                    (lambda (v2)
                        (k (+ v1 v2))))))))
(writeln (fib1 5 id))

把k往裡面推

(define (fib2 n)
    (if (<= n 1)
        (lambda (k) (k 1))
        (lambda (k)
            ((fib2 (- n 1))
                (lambda (v1)
                    ((fib2 (- n 2))
                        (lambda (v2)
                            (k (+ v1 v2)))))))))
(writeln ((fib2 5) id))

包一包，這裡可以注意到其實monad指的就是(lambda (k) ...)，只要被這個包起來就是monad!!

(define (return val)
    (lambda (k) (k val)))
(define (bind m f)
    (lambda (k)
        ((m f) k)))
(define (fib3 n)
    (if (<= n 1)
        (return 1)
        (bind
            (fib3 (- n 1))
            (lambda (v1)
                (bind
                    (fib3 (- n 2))
                    (lambda (v2)
                        (return (+ v1 v2))))))))
(writeln ((fib3 5) id))

callcc就是

  1. 擷取現在的cont，塞進去lambda
  2. 讓原本的程式用原本的cont繼續跑
(define (callcc f)
  (lambda (k)
    ((f (lambda (val)
          (lambda (_)
            (k val))))
      k)))

邏輯上的關聯: callcc的type是?

cont吃一個值之後就跳走，所以她的return val是什麼type? 沒關西，先當成P -> Q

callcc是什麼type? 吃一個func，接回去原本的運算，注意到因為這裡的return val與cont吃得一樣，所以用一樣的type F -> P

F是什麼type? 吃一個cont，回傳某個值 (P -> Q) -> ?

某個值是什麼type? 這func要接回去原本的運算，所以是P

整個是((P -> Q) -> P) -> P

這就是Peirce’s law，如果把Q帶成bottom(Absurd)，就可以得到排中律!!

CPS conversion

在cont monad看到monad怎麼把cont藏起來 接著就是怎麼把這個k自己生出來，下面都用untyped lambda calculus

說老實話，其實是為了這個才把這篇打出來的

另外如果有人說，學遞迴要用trace實際執行過程，直接丟這個給他看，看他怎麼trace 或是說遞迴可以轉成loop，也是丟這個，看他怎麼轉

naive

先是base case，變數與lambda，這裡base case叫atomic 變數直接回傳，lambda要幫他開一個洞，把值傳回去

(define (M expr)
  (match expr
    [`(λ (,var) ,expr)
      (define $k (gensym '$k))
     `(λ (,var ,$k) ,(T expr $k))]
    [(? symbol?)
      expr]))

剩下就是apply，每個都要先轉沒問題，那這裡要放什麼? 可以先看看簡單的case: (f v)且都是變數 最保險就是每個都要轉(過M)，

((λ (a)
  ((λ (b)
    (k (a b))) ;; !!
      v))
  f)

等等，現在a會多一個cont

((λ (a)
  ((λ (b)
    (a b k)) ;; good
      v))
  f)

(define (T expr k)
  (match expr
    [`(λ . ,_) `(,k ,(M expr))]
    [(? symbol?) `(,k ,(M expr))]
    [`(,F ,V)
      (define $f (gensym '$f))
      (define $v (gensym '$v))
      (T F `(λ (,$f)
              ,(T V `(λ (,$v)
                       (,$f ,$v ,k)))))]))

(T '(g a) 'halt)

變成

((λ ($f1445) 
  ((λ ($e1446) 
    ($f1445 $e1446 halt)) a)) g)

high-order

最保險的方式可以work，但output有點長，為什麼不直接apply進去?

怎麼直接apply進去? 我們不是有現成的函數嗎

重新看T的base case，這裡如果可以直接apply函數，就可以把那坨去掉 換言之，我們原本在k傳的是symbol，但現在是racket的function，最後回傳symbol 所以先把quote拿掉

(define (T expr k)
  (match expr
    [`(λ . ,_) (k (M expr))]
    [(? symbol?) (k (M expr))]
    [`(,F ,V)
      (T F (λ (f)
              (T V (λ (v)
                       `(,f ,v ,k)))))])) ;; !!

等等，這裡k是racket的lambdaㄟ 這裡要是quote，所以要把(f v)的拉到原本的k去

(define (T expr k)
  (match expr
    [`(λ . ,_) (k (M expr))]
    [(? symbol?) (k (M expr))]
    [`(,F ,V)
      (define $ret (gensym `$ret))
      (define cont `(λ (,$ret) ,(k $ret)))
      (T F (λ (f)
              (T V (λ (v)
                       `(,f ,v ,cont)))))]))

回來看M，會看到lambda的k要改，改成racket的lambda，最後回傳symbol

(define (M expr)
  (match expr
    [`(λ (,var) ,expr)
      (define $k (gensym '$k))
     `(λ (,var ,$k) ,(T expr (λ (ret) `(,$k ,ret))))]
    [(? symbol?)
      expr]))

(T '(g a) (λ (ans) `(halt ,ans)))

變成

(g a (λ ($rv1) (halt $rv1)))

少很多，但能不能更好，那個lambda很多餘

混合

多的lambda來自T的cont，但又不能直接去掉，有什麼辦法? 回去看怎麼用的，不覺得很怪嗎，明明是轉symbol卻要寫lambda，有沒有辦法變成最初的方式去call

所以第一層可以先抄第一種T

(define (T-symbol expr k-symbol)
  (match expr
    [`(λ . ,_) `(,k-symbol (M expr))]
    [(? symbol?) `(,k-symbol (M expr))]
    [`(,F ,V)
      ... ]))

但apply用第二種T

(define (T-symbol expr k-symbol)
  (match expr
    [`(λ . ,_) `(,k-symbol ,(M expr))]
    [(? symbol?) `(,k-symbol ,(M expr))]
    [`(,F ,V)
      (T-func F (λ (f)
              (T-func V (λ (v)
                       `(,f ,v ,k-symbol)))))]))

再抄第二種T

(define (T-func expr k-func)
  (match expr
    [`(λ . ,_) (k-func (M expr))]
    [(? symbol?) (k-func (M expr))]
    [`(,F ,V)
      (define $ret (gensym `$ret))
      (define cont `(λ (,$ret) ,(k-func $ret)))
      (T-func F (λ (f)
              (T-func V (λ (v)
                       `(,f ,v ,cont)))))]))

M要抄第一種，觀察兩個T的base case，會看到(M expr)，最後都是要被展開成symbol 所以選都是symbol的第一種

(define (M expr)
  (match expr
    [`(λ (,var) ,expr)
      (define $k (gensym '$k))
     `(λ (,var ,$k) ,(T-symbol expr $k))]
    [(? symbol?)
      expr]))

(T-symbol '(g a) 'halt)

變成

(g a halt)

partition

這個是為了還原calling stack而產生的

要還原calling stack需要知道誰是caller，與之後衍生的 所以回去看生出cont的部分(幫lambda多一格的部分)

(define (T-func expr k-func)
  (match expr
    [`(λ . ,_) (k-func (M expr))]
    [(? symbol?) (k-func (M expr))]
    [`(,F ,V)
      (define $ret (gensym `$ret)) ;; 1
      (define cont `(λ (,$ret) ,(k-func $ret)))
      (T-func F (λ (f)
              (T-func V (λ (v)
                       `(,f ,v ,cont)))))]))

(define (M expr)
  (match expr
    [`(λ (,var) ,expr)
      (define $k (gensym '$k)) ;; 2
     `(λ (,var ,$k) ,(T-symbol expr $k))]
    [(? symbol?)
      expr]))

1是起點，也就是apply；2是中間。 所以把1的symbol標成user, 2是cont

(define (T-func expr k-func)
  (match expr
    [`(λ . ,_) (k-func (M expr))]
    [(? symbol?) (k-func (M expr))]
    [`(,F ,V)
      (define $ret (genusym `$ret)) ;; 1
      (define cont `(λ (,$ret) ,(k-func $ret)))
      (T-func F (λ (f)
              (T-func V (λ (v)
                       `(,f ,v ,cont)))))]))

(define (M expr)
  (match expr
    [`(λ (,var) ,expr)
      (define $k (genksym '$k)) ;; 2
     `(λ (,var ,$k) ,(T-symbol expr $k))]
    [(? symbol?)
      expr]))

在ref中還有scheme的轉換，但其實就是多了不定數量參數列的處理

TODO

delimit cont 據說cooperative的thread加macro可以變成preemptive! Closure conversion: How to compile lambda

Ref

Continuations by example: Exceptions, time-traveling search, generators, threads, and coroutines Appendix: An implementation of dynamic-wind 如何解释 Lisp 中 call/cc 的概念？ 用call/cc合成所有的控制流结构 How to compile with continuations