Implementing bits of Danvy and Filinski papers Abstracting Control and Representing Control

CPS.rkt

#lang racket

;;;; CPS translaions written with guidance from Ken Shan's notes
;;;; and Danvy & Filinkski's paper Abstracting Control

(define empty-env '())

(define (extend-env name value env)
  (cons (list name value) env))

(define (lookup-env name env)
  (second (assq name env)))

(define example
  '(((λ (square)
       (λ (x) (* (square (square x)) x)))
     (λ (x) (* x x)))
    2))

(define example2
  '(* 10 (call/cc
          (λ (k)
            (* 2 (k 3))))))

(define example3
  '(* 3
      (reset (* 2 (shift c (c (c 10)))))))

;(define (id expr)
;  (match expr
;    [`(λ (,x) ,e)   `(λ (,x) ,(id e))]
;    [ (? symbol?)     expr]
;    [ (? number?)     expr]
;    [`(,f ,e)        `(,(id f) ,(id e))]))
;
;(define (subst x v expr)
;  (match expr
;    [`(λ (,var) ,e)   (if (eq? x var)
;                        expr
;                        `(λ (,var) ,(subst x v e)))]
;    [ (? symbol?)   (if (eq? x expr)
;                        v
;                        expr)]
;    [ (? number?)   expr]
;    [`(* ,e1 ,e2)   `(* ,(subst x v e1) ,(subst x v e2))]
;    [`(,f ,e)       `(,(subst x v f) ,(subst x v e))]))

(define (my-eval expr env)
  (match expr
    [`(λ (,x) ,e)   (λ (a) (my-eval e (extend-env x a env)))]
    [ (? symbol?)   (lookup-env expr env)]
    [ (? number?)   expr]
    [`(+ ,e1 ,e2)   (+ (my-eval e1 env) (my-eval e2 env))]
    [`(* ,e1 ,e2)   (* (my-eval e1 env) (my-eval e2 env))]
    [`(,f ,e)       ((my-eval f env) (my-eval e env))]))

(define (cps-1 expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (define k (gensym 'k))
     `(λ (,k) (,k ,(lookup-env expr env)))]
    [ (? number?)
     ; =>
     (define k (gensym 'k))
     `(λ (,k) (,k ,expr))]
    [`(* ,e1 ,e2)
     ; =>
     (define k  (gensym 'k))
     (define x1 (gensym 'x))
     (define x2 (gensym 'x))
     `(λ (,k) (,(cps-1 e1 env) (λ (,x1)
               (,(cps-1 e2 env) (λ (,x2)
                (,k (* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k (gensym 'k))
     (define a (gensym 'a))
     `(λ (,k) (,k (λ (,a) ,(cps-1 e (extend-env x a env)))))]
    [`(call/cc (λ (,k) ,e))
     ; =>
     (define k1 (gensym 'k))
     (define k2 (gensym 'k))
     (define a  (gensym 'a))
     `(λ (,k1) (,(cps-1 e
                        (extend-env k `(λ (,a)
                                         (λ (,k2)
                                           (,k1 ,a))) env)) ,k1))]
    [`(shift ,k ,e)
     ; =>
     (define k1 (gensym 'k))
     (define k2 (gensym 'k))
     (define a  (gensym 'a))
     (define x  (gensym 'x))
     `(λ (,k1) (,(cps-1 e
                        (extend-env k `(λ (,a)
                                         (λ (,k2)
                                           (,k2 (,k1 ,a)))) env))
                (λ (,x) ,x)))]
    [`(reset ,e)
     ; =>
     (define k (gensym 'k))
     (define x (gensym 'x))
     `(λ (,k) (,k (,(cps-1 e env) (λ (,x) ,x))))]
    [`(,f ,e)
     ; =>
     (define k (gensym 'k))
     (define fk (gensym 'f))
     (define ek (gensym 'e))
     `(λ (,k) (,(cps-1 f env) (λ (,fk)
                (,(cps-1 e env) (λ (,ek) ((,fk ,ek) ,k))))))]))
       

(define test1
  ((my-eval
    (cps-1 example empty-env)
    empty-env)
   (λ (x) (+ x 1))))

;; Add η-redex
(define (cps-2 expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (define k (gensym 'k))
     `(λ (,k) (,k ,(lookup-env expr env)))]
    [ (? number?)
     ; =>
     (define k (gensym 'k))
     `(λ (,k) (,k ,expr))]
    [`(* ,e1 ,e2)
     ; =>
     (define k  (gensym 'k))
     (define x1 (gensym 'x))
     (define x2 (gensym 'x))
     `(λ (,k) (,(cps-2 e1 env) (λ (,x1)
               (,(cps-2 e2 env) (λ (,x2)
                (,k (* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k  (gensym 'k))
     (define k1 (gensym 'k))                                     ;; <<< This line added
     (define a  (gensym 'a))
     `(λ (,k) (,k (λ (,a)
                    (λ (,k1)                                     ;; <<< This line changed
                     (,(cps-2 e (extend-env x a env)) ,k1)))))]  ;; <<< This line changed
    [`(,f ,e)
     ; =>
     (define k (gensym 'k))
     (define fk (gensym 'f))
     (define ek (gensym 'e))
     `(λ (,k) (,(cps-2 f env) (λ (,fk)
                (,(cps-2 e env) (λ (,ek) ((,fk ,ek) ,k))))))]))
       
(define test2
  ((my-eval
    (cps-2 example empty-env)
    empty-env)
   (λ (x) (+ x 1))))



;; β-redex
(define (cps-3 expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (λ (k) `(,k ,(lookup-env expr env)))]
    [ (? number?)
     ; =>
     (λ (k) `(,k ,expr))]
    [`(* ,e1 ,e2)
     ; =>
     (define x1 (gensym 'x))
     (define x2 (gensym 'x))
     (λ (k) ((cps-3 e1 env) `(λ (,x1)
              ,((cps-3 e2 env) `(λ (,x2)
                (,k (* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (λ (k) `(,k (λ (,a)
                   (λ (,k1)
                     ,((cps-3 e (extend-env x a env)) k1)))))]
    [`(,f ,e)
     ; =>
     (define fk (gensym 'f))
     (define ek (gensym 'e))
     (λ (k) ((cps-3 f env) `(λ (,fk)
            ,((cps-3 e env) `(λ (,ek) ((,fk ,ek) ,k))))))]))

(define test3
  (my-eval ((cps-3 example empty-env) '(λ (x) (+ x 1))) empty-env))

;; Add η-redex
(define (cps-4 expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (λ (k) `(,k ,(lookup-env expr env)))]
    [ (? number?)
     ; =>
     (λ (k) `(,k ,expr))]
    [`(* ,e1 ,e2)
     ; =>
     (define x1 (gensym 'x))
     (define x2 (gensym 'x))
     (λ (k) ((cps-4 e1 env) `(λ (,x1)
              ,((cps-4 e2 env) `(λ (,x2)
                (,k (* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (define m  (gensym 'm))                          ;; <<< line added
     (λ (k) `(,k (λ (,a)
                   (λ (,k1)
                     ,((cps-4 e (extend-env x a env))
                       `(λ (,m) (,k1 ,m)))))))]       ;; <<< line changed
    [`(,f ,e)
     ; =>
     (define fk (gensym 'f))
     (define ek (gensym 'e))
     (λ (k) ((cps-4 f env) `(λ (,fk)
            ,((cps-4 e env) `(λ (,ek) ((,fk ,ek) ,k))))))]))

(define test4
  (my-eval ((cps-4 example empty-env) '(λ (x) (+ x 1))) empty-env))

;; Add final η-redex to make sure κ is always a lambda abstraction
(define (cps-5 expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (λ (k) `(,k ,(lookup-env expr env)))]
    [ (? number?)
     ; =>
     (λ (k) `(,k ,expr))]
    [`(* ,e1 ,e2)
     ; =>
     (define x1 (gensym 'x))
     (define x2 (gensym 'x))
     (λ (k) ((cps-5 e1 env) `(λ (,x1)
              ,((cps-5 e2 env) `(λ (,x2)
                (,k (* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (define m  (gensym 'm))
     (λ (k) `(,k (λ (,a)
                   (λ (,k1)
                     ,((cps-5 e (extend-env x a env))
                       `(λ (,m) (,k1 ,m)))))))]
    [`(,f ,e)
     ; =>
     (define fk (gensym 'f))
     (define ek (gensym 'e))
     (define a  (gensym 'a))
     (λ (k) ((cps-5 f env) `(λ (,fk)
            ,((cps-5 e env) `(λ (,ek) ((,fk ,ek)
                                       (λ (,a) (,k ,a))))))))])) ;; <<< line changed

(define test5
  (my-eval ((cps-5 example empty-env) '(λ (x) (+ x 1))) empty-env))

;; One-pass CPS
(define (one-pass-cps expr env)
  (match expr
    [ (? symbol?)
     ; =>
     (λ (k) (k (lookup-env expr env)))]
    [ (? number?)
     ; =>
     (λ (k) (k expr))]
    [`(* ,e1 ,e2)
     ; =>
     (λ (k) ((one-pass-cps e1 env) (λ (x1)
              ((one-pass-cps e2 env) (λ (x2)
                (k `(* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (λ (k) (k `(λ (,a)
                 (λ (,k1)
                   ,((one-pass-cps e (extend-env x a env))
                       (λ (m) `(,k1 ,m)))))))]
    [`(,f ,e)
     ; =>
     (define a  (gensym 'a))
     (λ (k) ((one-pass-cps f env) (λ (fk)
             ((one-pass-cps e env) (λ (ek) `((,fk ,ek)
                                       (λ (,a) ,(k a))))))))]))

(define (one-pass-dyn-cps expr env)
  `(λ (k) ,((one-pass-cps expr env) (λ (m) `(k ,m)))))

(define test6
  (my-eval ((one-pass-cps example empty-env) (λ (x) `(+ 1 ,x))) empty-env))

(define test7
  ((my-eval (one-pass-dyn-cps example empty-env) empty-env) (λ (x) (+ 1 x))))

(define test8
  ((my-eval
    (cps-1 example2 empty-env)
    empty-env)
   (λ (x) x)))

(define test9
  ((my-eval
    (cps-1 example3 empty-env)
    empty-env)
   (λ (x) x)))

;; One-pass CPS with shift/reset
(define (one-pass-cps2 expr env)
  (match expr
    [`(shift ,k ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (λ (k2) ((one-pass-cps2 e (extend-env k `(λ (,a)
                                               (λ (,k1)
                                                 (,k1 ,(k2 a)))) env))
              (λ (x) x)))]
    [`(reset ,e)
     ; =>
     (λ (k) (k ((one-pass-cps2 e env) (λ (x) x))))]
    [`(* ,e1 ,e2)
     ; =>
     (λ (k) ((one-pass-cps2 e1 env) (λ (x1)
              ((one-pass-cps2 e2 env) (λ (x2)
                (k `(* ,x1 ,x2)))))))]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (λ (k) (k `(λ (,a)
                 (λ (,k1)
                   ,((one-pass-cps2 e (extend-env x a env))
                       (λ (m) `(,k1 ,m)))))))]
    [ (? symbol?)
     ; =>
     (λ (k) (k (lookup-env expr env)))]
    [ (? number?)
     ; =>
     (λ (k) (k expr))]
    [`(,f ,e)
     ; =>
     (define a  (gensym 'a))
     (λ (k) ((one-pass-cps2 f env) (λ (fk)
             ((one-pass-cps2 e env) (λ (ek) `((,fk ,ek)
                                              (λ (,a) ,(k a))))))))]))


(define test10
  (my-eval ((one-pass-cps2 example3 empty-env) (λ (x) x)) empty-env))
  

;; One-pass CPS with shift/reset meta-circular compiler
(require racket/control)

(define (one-pass-cps3 expr env)
  (match expr
    [`(shift ,k ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     (shift k2 (one-pass-cps3 e (extend-env k `(λ (,a)
                                                 (λ (,k1)
                                                   (,k1 ,(k2 a)))) env)))]
    [`(reset ,e)      (reset (one-pass-cps3 e env))]
    [`(* ,e1 ,e2)     `(* ,(one-pass-cps3 e1 env) ,(one-pass-cps3 e2 env))]
    [ (? symbol?)     (lookup-env expr env)]
    [ (? number?)     expr]
    [`(λ (,x) ,e)
     ; =>
     (define k1 (gensym 'k))
     (define a  (gensym 'a))
     `(λ (,a)
        (λ (,k1)
          ,(reset `(,k1 ,(one-pass-cps3 e (extend-env x a env))))))]
    [`(,f ,e)
     ; =>
     (define t  (gensym 't))
     (shift k `((,(one-pass-cps3 f env) ,(one-pass-cps3 e env)) (λ (,t) ,(k t))))]))

(define test11
  (my-eval (one-pass-cps3 example3 empty-env) empty-env))