cek-lam.rkt

#lang plait
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; an implementation of the CEK machine for the untyped call-by-value lambda
;;; calculus

(define-type Lam
  (lamE [id : Symbol] [body : Lam])
  (appE [e1 : Lam] [e2 : Lam])
  (identE [id : Symbol])
  (valueE [v : Value]))

(define-type-alias Env (Hashof Symbol Value))

(define-type Value
  (lamV [closure : Env] [id : Symbol] [body : Lam]))

(define-type Frame
  ; frame for (app E e)
  (app1E [E : Env] [e : Lam])
  ;;; frame for (appE v E)
  (app2E [E : Env] [v : Value]))

;;; push f onto the frame stack
(define (push-frame f stack)
  (append (list f) stack))

;;; top the frame at the top of the stack off and get a new frame
(define (pop-frame stack)
  (type-case (Listof Frame) stack
             [(cons hd tl)
              (pair hd tl)]
             [empty (error 'invalid "popping empty stack frame")]))

(define-type State
  (state [C : Lam] [E : Env] [K : (Listof Frame)]))

;;; runs the machine beginning from `state` until a fixed point is reached
(define (run-machine s)
  (begin
    (display s)
    (display "\n")
    (let [(next-state (transition s))]
      (if (equal? next-state s)
          s
          (run-machine next-state)))))

(define empty-env (hash empty))

(define (transition s)
  (type-case Lam (state-C s)
             [(valueE v1)
              ; if the stack frame is empty, we are in a terminal state; do nothing
              ; otherwise, place v in the hole
              (if (empty? (state-K s))
                  s
                  (let* [(popped (pop-frame (state-K s)))
                         (popped-call-stack (snd popped))]
                    (type-case Frame (fst popped)
                               [(app1E E e)
                                (state (appE e (valueE v1)) E popped-call-stack)]
                               [(app2E E v2)
                                (state (appE (valueE v1) (valueE v2))
                                       E
                                       popped-call-stack)])))]
             [(identE x)
              (type-case (Optionof Value) (hash-ref (state-E s) x)
                         [(some v)
                          (state (valueE v) empty-env (state-K s))]
                         [(none) (error 'unbound-ident "")])]
             [(lamE id body)
              (state (valueE (lamV (state-E s) id body))
                     empty-env
                     (state-K s))]
             [(appE e1 e2)
              (cond
                [(and (valueE? e1) (valueE? e2))
                 (let* [(lam (valueE-v e1))
                        (body (lamV-body lam))
                        (id (lamV-id lam))
                        (closure (lamV-closure lam))]
                   (state body
                          ; extend the closure with id |-> v2
                          (hash-set closure id (valueE-v e2))
                          ; maintain the current call stack
                          (state-K s)))]
                [(valueE? e1)
                 ; reduce e2
                 (state e2
                        (state-E s)
                        (push-frame (app2E (state-E s) (valueE-v e2)) (state-K s)))]
                [else
                 ; reduce e1
                 (state e1
                        (state-E s)
                        (push-frame (app1E (state-E s) e2) (state-K s)))])]))


(define (run-machine-init e)
  (let* [(r (run-machine (state e
                               empty-env
                               empty)))
         (lamv (valueE-v (state-C r)))]
    (lamE (lamV-id lamv) (lamV-body lamv))))

(test (run-machine-init (appE (lamE 'x (identE 'x))
                              (lamE 'y (identE 'y))))
      (lamE 'y (identE 'y)))

(test (run-machine-init (appE (appE (lamE 'x (identE 'x))
                                    (lamE 'y (identE 'y)))
                              (lamE 'z (identE 'z))))
      (lamE 'z (identE 'z)))

(test (run-machine-init (appE (appE (lamE 'x (identE 'x))
                                    (lamE 'y (identE 'y)))
                              (appE (lamE 'z (identE 'z))
                                    (lamE 'w (identE 'w)))))
      (lamE 'w (identE 'w)))
; test that names go out of scope properly
(test/exn (run-machine-init (appE (lamE 'x (identE 'z))
                            (appE (lamE 'z (identE 'z))
                                  (lamE 'w (identE 'w)))))
      "unbound-ident")


;; (test (run-machine-init (letE 'x (numE 10) (identE 'x)))
;;       (numE 10))
;; (test (run-machine-init (letE 'x (numE 1)
;;                               (letE 'y (numE 2)
;;                                     (addE (identE 'x) (identE 'y)))))
;;       (numE 3))
;; (test (run-machine-init (letE 'y (letE 'z (numE 10) (identE 'z))
;;                               (identE 'y)))
;;       (numE 10))
;; (test/exn (run-machine-init (letE 'y (letE 'z (numE 10) (identE 'z))
;;                                   (identE 'z)))
;;           "unbound-ident")