Skip to content

Instantly share code, notes, and snippets.

@shhyou
Last active December 21, 2015 16:39
Show Gist options
  • Save shhyou/6335301 to your computer and use it in GitHub Desktop.
Save shhyou/6335301 to your computer and use it in GitHub Desktop.
CPS transform program with some basic simplifications.
; See also: https://github.com/yinwang0/old-toys/blob/master/cps.ss
(load "prelude.ss")
;; Syntax:
;; e ::= x
;; | c
;; | (lambda (x ...) e)
;; | (op2 e1 e2)
;; | (if e0 e1 e2)
;; | (e1 e2 ...)
;; where c :: Integer
;; op2 `elem` ['+', '-', '*', '/']
(define constant? integer?)
(define operator2?
(lambda (sym)
(memq sym '(+ - * /))))
(define gen-fresh-var
(lambda ()
(let [(var-name 0)]
(lambda (s)
(set! var-name (+ var-name 1))
(string->symbol (string-append s (number->string var-name)))))))
;; CPS-transformation
;; [[ x ]] = \k -> k x
;; [[ \x. e ]] = \k -> k (\x k -> [[ e ]] k)
;; [[ e1 e2 ]] = \k -> [[ e1 ]] (\f ->
;; [[ e2 ]] (\v ->
;; f v k))
;; cps0, an trivial method for converting to CPS.
;; There are lots of redundant closures.
(define cps0
(let [(fresh-var (gen-fresh-var))]
(lambda (expr)
(match expr
[(lambda (,x) ,e)
(let* [(k0 (fresh-var "k"))
(k (fresh-var "k"))]
`(lambda (,k0)
(,k0 (lambda (,x ,k)
(,(cps0 e) ,k)))))]
[(,op ,e1 ,e2)
(guard (operator2? op))
(let* [(k (fresh-var "k"))
(v1 (fresh-var "v"))
(v2 (fresh-var "v"))]
`(lambda (,k)
(,(cps0 e1) (lambda (,v1)
(,(cps0 e2) (lambda (,v2)
(,op ,v1 ,v2 ,k)))))))]
[(if ,e0 ,e1 ,e2)
(let* [(k (fresh-var "k"))
(v (fresh-var "v"))]
`(lambda (,k)
(,(cps0 e0) (lambda (,v)
(if v (,(cps0 e1) ,k) (,(cps0 e2) ,k))))))]
[(,e0 ,e1)
(let* [(k (fresh-var "k"))
(f (fresh-var "f"))
(v (fresh-var "v"))]
`(lambda (,k)
(,(cps0 e0) (lambda (,f)
(,(cps0 e1) (lambda (,v)
(,f ,v ,k)))))))]
[,var
(guard (or (symbol? var) (constant? var)))
(let [(k (fresh-var "k"))]
`(lambda (,k) (,k ,var)))]))))
;; cps1, a better version
;
; (cps1 '((x z) (y z)))
;;;; ==> (x z
; (lambda (t1) (y z (lambda (t2) (t1 t2 (lambda (t3) t3))))))
;
; (cp1 '((x z) (y z) (w z)))
;;;; ==> (x z
; (lambda (t1)
; (y z
; (lambda (t2)
; (w z (lambda (t3) (t1 t2 t3 (lambda (t4) t4))))))))
;
; (cps1 '((lambda (x y) x) ((lambda (x) (x x)) y) z))
;;;; ==> ((lambda (x k2) (x x k2))
; y
; (lambda (t3)
; ((lambda (x y k1) (k1 x)) t3 z (lambda (t4) t4))))(define cps1
(lambda (expr)
(let [(fresh-var (gen-fresh-var))]
(define id (lambda (x) x))
(define apply-cont
(lambda (cont k)
(cond [(procedure? cont) (cont k)]
[(symbol? cont) `(,cont ,k)]
[else (error 'apply-cont (format "unknown cont ~s" cont))])))
(define put-cont
(lambda (cont)
(cond [(procedure? cont)
(let [(t (fresh-var "t"))]
`(lambda (,t) ,(cont t)))]
[(symbol? cont) cont]
[else (error 'put-cont (format "unknown cont ~s" cont))])))
(define do-cps
(lambda (expr k)
(match expr
[(lambda (,[xs ..]) ,e)
(let [(k0 (fresh-var "k"))]
(apply-cont k `(lambda (,@xs ,k0) ,(do-cps e k0))))]
[(,op ,e1 ,e2)
(guard (operator2? op))
(do-cps e1
(lambda (v1)
(do-cps e2
(lambda (v2)
`(,op ,v1 ,v2 ,(put-cont k))))))]
[(if ,e0 ,e1 ,e2)
(let [(k0 (fresh-var "k"))]
(do-cps e0
(lambda (v)
(if (or (symbol? k) (eq? k id))
`(if ,v ,(do-cps e1 k) ,(do-cps e2 k))
`(let [(,k0 ,(put-cont k))] (if ,v ,(do-cps e1 k0) ,(do-cps e2 k0)))))))]
[(,e0 ,[es ..])
(do-cps e0
(lambda (f)
(letrec
[(eval-args*
(lambda (xs k)
(cond [(null? xs) (k '())]
[else (do-cps
(car xs)
(lambda (v)
(eval-args*
(cdr xs)
(lambda (vs)
(k (cons v vs))))))])))]
(eval-args* es (lambda (vs) `(,f ,@vs ,(put-cont k)))))))]
[,var
(guard (or (symbol? var) (constant? var)))
(apply-cont k var)])))
(do-cps expr id))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment