Last active
December 21, 2015 16:39
-
-
Save shhyou/6335301 to your computer and use it in GitHub Desktop.
CPS transform program with some basic simplifications.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
; 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