COM 3351 June 10, 1993 Dr. Wand Readings: EOPL, pp. 458–461

Lecture 10: Deriving a Compiler

Interpreters tend to be inefficient, because they continually make decisions at run-time that could be made at compile-time if we had a compiler. An interpreter keeps looking at the same old parse tree and trying to figure out what it is and what it should do with it. If we were smarter, we could preprocess the parse tree, doing everything we could (without knowing the inputs). The result of this preprocessing phase would not make any more decisions at run-time than absolutely necessary. This is sometimes called staging or partial evaluation (These words don’t really mean the same thing, but they coincide here). How does this compare with our old machines, like the scanner or parser machines. In those examples, we started off with a functional representation, so a program was a function from register-values to answers. From there we derived an AST representation, with an interpreter that looked much like this one. Can we go backwards and reverse-engineer a functional representation for which this is the AST representation? If we could do this, we could write a function func-rep with the property that

((func-rep exp) env k) = (eval-exp exp env k)

The output of func-rep would be like the code for our old machines. We could then choose an efficient representation. The translation from the parse tree to the efficient representation could be called a compiler. If the efficient representation was (or could easily be translated to) real machine language, then the translator would be a compiler.

We could write func-rep trivially:

(define func-rep
  (lambda (exp)
    (lambda (env k)
      (eval-exp exp env k))))

but that wouldn’t lend itself to analysis for efficient representations. So let’s try to do better. It turns out that to do better, we need to generalize the problem. Instead of having a machine with 2 registers (env and k), we need 3 registers: env, k and buf. buf will be a list of values that allow the different parts of our machine to communicate. It will be used as a local stack. We’ll see how this goes. Let’s imagine some typical actions on this machine. Like our old machines, each action will specify a next-action to be performed next. These should look suggestive.

(define lit-action
(lambda (datum next-action)
(lambda (buf env k)
(next-action (cons datum buf) env k))))
(define var-action
(lambda (id next-action)
(lambda (buf env k)
(next-action
(cons (apply-env env id) buf)
env k))))
(define test-action
(lambda (true-action false-action)
(lambda (buf env k)
(if (true-value? (car buf))
(true-action (cdr buf) env k)
(false-action (cdr buf) env k)))))
(define binop-action
(lambda (binop next-action)
(lambda (buf env k)
(next-action
(cons (binop (cadr buf) (car buf))
      (cddr buf))
env k))))
(define restore-action
(lambda ()
(lambda (buf env k)
(k (car buf)))))

Most of these are just what you’d expect for a machine using buf as a local stack. restore-action sends the top of the stack to the continuation. Now that we have this additional register, how should the output of func-rep (which we’ll now call compile-exp) relate to eval-exp? The right answer was discovered by Will Clinger in his 1984 LFP paper. Following Clinger, we’ll require that:

((compile-exp exp next-action) buf env k)
 = (eval-exp exp env
     (lambda (v) (next-action
                   (cons v buf)
                   env k)))

That is, if we run the code for exp followed by next-action, we should get the same result as if we evaluated exp, put the result on the top of buf, and

then ran next-action.

The continuation in this specification is so common that we give it a name:

(define frame
  (lambda (next-action buf env k)
    (lambda (v)
      (next-action (cons v buf) env k))))

So our spec becomes:

((compile-exp exp next-action) buf env k)
 = (eval-exp exp env (frame next-action buf env k))

Let’s start with a vanilla CPS interpreter, and see if we can make this work.

(define eval-exp
(lambda (exp env k)
(record-case exp
(lit-exp (datum) (k datum))
(var-exp (id) (k (apply-env env id)))
(if-exp (test-exp exp1 exp2)
  (eval-exp test-exp env
    (lambda (v)
      (if (true-value? v)
        (eval-exp exp1 env k)
        (eval-exp exp2 env k)))))
(binop-exp (binop exp1 exp2)
  (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)
          (k (apply-binop binop v1 v2)))))))
(else (error 'eval-exp "Bad abstract syntax: ~s" exp)))))

Let’s see if we can figure out what compile-exp should do in each case. According to our spec, we should have

((compile-exp (lit-exp datum) next-action) buf env k)
= (eval-exp (lit-exp datum) env (frame next-action buf env k)) [spec]
= ((frame next-action buf env k) datum)          [defn of eval-exp]
= (next-action (cons datum buf) env k)           [defn of frame]
= ((lit-action datum next-action) buf env k)     [defn of lit-action]

So we conclude that we must have

(compile-exp (lit-exp datum) next-action) = (lit-action datum next-action)

Similarly for var-exp– we want

((compile-exp (var-exp id) next-action) buf env k)
= (eval-exp (var-exp id) env (frame next-action buf env k))   [spec]
= ((frame next-action buf env k) (apply-env env id))    [defn of
                                                         eval-exp]
= (next-action (cons (apply-env env id) buf) env k)  [defn of frame]
= ((var-action id next-action) buf env k)            [defn of var-action]

So we conclude that

(compile-exp (var-exp id) next-action) = (var-action id next-action)

test-exp is a little more interesting:

((compile-exp (if-exp test-exp exp1 exp2) next-action)
 buf env k)
= (eval-exp (if-exp test-exp exp1 exp2)
    env
    (frame next-action buf env k))
= (eval-exp test-exp env
    (lambda (v)
      (if (true-value? v)
        (eval-exp exp1 env (frame next-action buf env k))
        (eval-exp exp2 env (frame next-action buf env k)))))

I claim that this will work if we say that

(compile-exp (if-exp test-exp exp1 exp2) next-action)
= (compile-exp test-exp
    (test-action
      (compile-exp exp1 next-action)
      (compile-exp exp2 next-action)))

Let’s check it:

((compile-exp (if-exp test-exp exp1 exp2) next-action)
buf env k)
= ((compile-exp test-exp                ; proposed defn of compile-exp
(test-action
(compile-exp exp1 next-action)
(compile-exp exp2 next-action)))
buf env k)
= (eval-exp test-exp env                ; spec at test-exp
(frame
(test-action
  (compile-exp exp1 next-action)
  (compile-exp exp2 next-action))
buf env k))
= (eval-exp test-exp env
(lambda (v)                         ; defn of frame
((test-action
   (compile-exp exp1 next-action)
   (compile-exp exp2 next-action))
 (cons v buf) env k)))            ; result on test-exp is on top
                                 ; of buffer
= (eval-exp test-exp env
(lambda (v)
(if (true-value? v)               ; defn of test-action
  ((compile-exp exp1 next-action) buf env k)
  ((compile-exp exp2 next-action) buf env k))))

= (eval-exp test-exp env
    (lambda (v)
      (if (true-value? v)               ; spec at exp1 and exp2
        (eval-exp exp1 env (frame next-action buf env k))
        (eval-exp exp2 env (frame next-action buf env k)))))
VOILA!

Now we can do binary ops in the same way. I claim that if we define

compile-exp so that

(compile-exp (binop-exp binop exp1 exp2) next-action)
= (compile-exp exp1
    (compile-exp exp2
      (binop-action binop next-action)))

then the specification will work for binop-exps. Let’s check it:

((compile-exp (binop-exp binop exp1 exp2) next-action)
 buf env k)
= ((compile-exp exp1                    ; defn of compile-exp
    (compile-exp exp2
      (binop-action binop next-action)))
   buf env k)
= (eval-exp exp1 env                    ; spec at exp1
    (frame
      (compile-exp exp2
        (binop-action binop next-action))
      buf env k))
= (eval-exp exp1 env
    (lambda (v1)                        ; defn of frame
      ((compile-exp exp2
        (binop-action binop next-action))
       (cons v1 buf) env k)))

= (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env                ; spec at exp2
        (frame
          (binop-action binop next-action)
          (cons v1 buf) env k))))
= (eval-exp exp1 env                    ; call this (*)
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)                    ; defn of frame
          ((binop-action binop next-action)
           (cons v2 (cons v1 buf))      ; v2 and v1 on top of buf
           env k)))))
= (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)
          (next-action                  ; defn of binop-action
            (cons (apply-binop binop v1 v2) buf)
            env k)))))
= (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)
          ((frame buf next-action buf env k) ; defn of frame
           (apply-binop v1 v2))))))
= (eval-exp (binop-exp binop exp1 exp2) env
    (frame buf next-action buf env k))

So now we can write down the definition of compile-exp:

(define compile-exp
(lambda (exp next-action)
(record-case exp
(lit-exp (datum) (lit-action datum next-action))
(var-exp (id) (var-action id next-action))
(if-exp (test-exp exp1 exp2)
  (compile-exp test-exp
    (test-action
      (compile-exp exp1 next-action)
      (compile-exp exp2 next-action))))
(binop-exp (binop exp1 exp2)
  (compile-exp exp1
    (compile-exp exp2
      (binop-action binop next-action))))
(else (error 'compile-exp "unknown exp ~s" exp)))))

Choosing a Representation

This generates actions in functional representation. Of course we can now do our standard hacks and represent these actions in a different form– say list-of-frames:

(lit-action datum next-action)  ==> ((lit datum) . next-action)
(var-action id    next-action)  ==> ((fetch id)  . next-action)
(test-action true-action false-aciont)
    ==> ((jump-if-true . true-action) . false-action)
(binop-action binop next-action) ==> ((do-binop binop) . next-action)
(restore-action) ==> ((restore))
;;; action constructors in list-of-frames representation
(define lit-action
  (lambda (datum next-action)
    (cons (list 'lit datum) next-action)))
(define var-action
  (lambda (id next-action)
    (cons (list 'fetch id) next-action)))
(define test-action
  (lambda (true-action false-action)
    (cons
      (cons 'jump-if-true true-action)
      false-action)))
(define binop-action
  (lambda (binop next-action)
    (cons (list 'do-binop binop) next-action)))
(define restore-action
  (lambda ()
    '((restore))))

The Machine

(define apply-action
(lambda (action buf env k)
(let ((instruction (car action))
(next-action (cdr action)))
(case (car instruction)
((lit)
(let ((datum (cadr instruction)))
(apply-action next-action
(cons datum buf) env k)))
((fetch)
(let ((id (cadr instruction)))
(apply-action next-action
(cons
  (apply-env env id)
  buf)
env k)))
((jump-if-true)
(let ((true-action (cdr instruction))
  (false-action next-action))
(if (true-value? (car buf))
(apply-action true-action  (cdr buf) env k)
(apply-action false-action (cdr buf) env k))))

        ((do-binop)
         (let ((binop (cadr instruction)))
           (apply-action next-action
             (cons (apply-binop binop (cadr buf) (car buf))
                   (cddr buf))
             env k)))
        ((restore)
         (apply-cont k (car buf)))
        (else
          (error 'apply-action
            "unknown instruction ~s"
            instruction))))))

Nothing here manipulates environments or continuations; for the moment we can test it with the initial continuation

(lambda (v) v)  ==> any value
(define apply-cont
  (lambda (k v)
    v))                                 ; k ignored !-)

For example, (compile-exp (scan&parse "(+ x (+ y z))") (restore-action))

gives (in approximate functional notation):

(var-action 'x
  (var-action 'y
    (var-action 'z
      (do-binop-action '(add-binop)     ; (add-binop) is
                                       ; representation of +
        (do-binop-action '(add-binop)
          (restore-action))))))

Or, in list-of-frames notation:

((fetch x)
 (fetch y)
 (fetch z)
 (do-binop (add-binop))
 (do-binop (add-binop))
 (restore))

See how the code produced is linear, and gets everything done in post-order, as specified by the interpreter.

– exercise: put cells in the environment and do set! and begin.

– exercise: deal better with tests, as in Ex. 12.3.2

Dealing with eval-rands

Our goal is to figure out how to compile procedures and procedure applications. This is a bit of jigsaw puzzle, in which there are several pieces, and we won’t be sure that it works until all the pieces are in place. But we’ll try to add the pieces so that we can see the picture as it emerges. As a first step, we need to figure out how to deal with lists of operands and

eval-rands.

(define eval-rands
  (lambda (rands env k)
    (if (null? rands)
      (k '())
      (eval-exp (car rands) env
        (lambda (v)
          (eval-rands rands env
            (lambda (w)
              (k (cons v w)))))))))

In the step of our derivation we marked (*), we saw the effect of evaluating

((compile exp1 (compile exp2 (binop-action binop next-action)))
 buf env k)
= (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)                    ; defn of frame
          ((binop-action binop next-action)
           (cons v2 (cons v1 buf))      ; v2 and v1 on top of buf
           env k)))))

The value v1 of exp1 is put on buf, and then the value v2 of exp2 is pushed onto buf. We can generalize this to n expressions, so that

((compile exp1 (compile exp2 ... (compile exp_n next-action)..))
 buf env k)
= (eval-exp exp1 env
    (lambda (v1)
      (eval-exp exp2 env
        (lambda (v2)
          ...
          (eval-exp exp_n env
            (lambda (v_n)
              (next-action
                (cons v_n ... (cons v2 (cons v1 buf)))
                env k)))))))

So that the list (v1 v2 ... vn) is pushed on buf in reverse. (This is the same behavior as our scanners had). This gives us the key to specifying the behavior of compile-rands. If eval-rands is supposed to send a list of values (v1 ... vn) to its continuation, then executing the compiled code should push this list of values on buf in reverse. Formally, we can write this specification as follows:

((compile-rands rands next-action) buf env k) =
   (eval-rands rands env
     (lambda (w)
       (next-action (append (reverse w) buf)
         env k)))

We can satisfy this specification by defining compile-rands as follows:

(define compile-rands
  (lambda (rands next-action)
    (if (null? rands)
      next-action
      (compile-exp (car rands)
        (compile-rands (cdr rands) next-action)))))

Let’s check this:

((compile-rands '() next-action) buf env k)
= (next-action buf env k)
= (next-action (append '() buf) env k)  ; (append '() buf) = buf
= (next-action (append (reverse '()) buf) env k)
= (eval-rands '() env
    (lambda (w) (next-action (append (reverse '()) buf) env k)))

Now let’s try the other case:

((compile-rands (cons exp rands) next-action)
 buf env k)
= ((compile-exp exp (compile-rands rands next-action))
   buf env k)
= (eval-exp exp env                     ; [spec at exp]
    (frame (compile-rands rands next-action) buf env k))
= (eval-exp exp env
    (lambda (first-arg)
      ((compile-rands rands next-action)
       (cons first-arg buf)
       env k)

= (eval-exp exp env
    (lambda (first-arg)
      (eval-rands rands env
        (lambda (other-args)
          (next-action
            (append (reverse other-args) (cons first-arg buf))
            env k)))))
= (eval-exp exp env
    (lambda (first-arg)
      (eval-rands rands env
        (lambda (other-args)
          (next-action
            (append (reverse (cons first-arg other-args)) buf) ; check it!
            env k)))))
= (eval-exp exp env
    (lambda (first-arg)
      (eval-rands rands env
        (lambda (other-args)
                                       ; rearranging:
          ((lambda (w) (next-action (append (reverse w) buf) env k))
           (cons first-arg other-args))))))
= (eval-rands (cons exp rands) env      ; defn of eval-rands
    (lambda (w)
      (next-action
        (append (reverse w) buf)
        env k)))

This completes the proof of correctness of eval-rands.

Adding Procedures (First Attempt)

Now we have almost all the pieces in place for adding procedures. We have to worry about compiling procedures and applications. But now this looks easy. We can define an action

(define proc-action
  (lambda (formals body next-action)
    (lambda (buf env k)
      (next-action
        (cons (make-closure formals body env) buf)
        env k))))

that pushes a closure on the stack, so we can extend compile-exp by:

    (proc-exp (formals body)
      (proc-action formals body next-action))

For an application, we can write

    (app-exp (rator rands)
      (compile-exp rator
        (compile-rands rands
          (call-action (length rands)
            next-action))))

Why do we need the extra (length rands) ? When this code is executed, the value of rator (which we usually call proc) will be pushed on the stack, followed by each of the arguments (in reverse). So we need to know how many arguments to pop off the stack before we can find the procedure. So (call-action n next-action) pops n items off the stack and reassembles them into an args list, pops the next item off the stack and calls it using apply-proc. The continuation to apply-proc will be a frame that will push the result of the procedure body on the remaining stack. Note that we can’t just call (reverse buf), since there may be other things in it that we don’t want to pass to the procedure.

(define call-action
  (lambda (n next-action)
    (lambda (buf env k)
      (letrec
        ((loop (lambda (n buf args)
                 (if (zero? n)
                   (apply-proc (car buf) args
                     (frame next-action (cdr buf) env k))
                   (loop (- n 1) (cdr buf) (cons (car buf) args))))))
        (loop n buf '())))))

This is similar to apply-ak. Exercise: Prove the correctness of these lines for proc-exp and app-exp by doing algebraic manipulation as above. For app-exp, you will need to proceed by induction on the length of rands.

Exercise: Replace call-action with a sequence of about n smaller instructions. To do this, you’ll probably need an args register in addition to buf, env, and k.

Note that call-action is the only procedure (so far) that actually manipulates the continuation register, and by calling apply-proc manipulates the environment register. This is reasonable– our goal is to make as many decisions at compile-time as we can. In particular, most of the time we know the first part of the continuation at compile time, namely the part of the continuation out to the first procedure boundary. That part winds up as the next-action. The essence of a procedure is that it can be called from many different places, so that we can’t know anything about the continuation when it is called. Digression: A more sophisticated compiler might attempt to do something about this when it can figure out something about the continuaion. For example, it might be able to figure out that a procedure is called in only one place, and use the next-action associated with that call site. Or it might deduce exactly which procedure is called a given call site, and substitute the procedure body in-line.

Adding Procedures (Second Attempt)

What’s wrong with this? We haven’t yet written down apply-proc. Let’s look at a version of apply-proc that fits our interpreter:

(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (closure (formals body env)
        (eval-exp
          body
          (extend-env formals args env)
          k)))))

This still has a call to eval-exp in it. This means that we will be interpreting the procedure body at run-time (Ouch!). This is not what we had in mind. We need to arrange this so we can compile procedure bodies and run the compiled code instead. In order to do this, we must overcome several difficulties.

1. We can’t quite use compile-exp, because our spec for compile-exp was

((compile-exp exp next-action) buf env k)
 = (eval-exp exp env (frame next-action buf env k))

which means that we would have to build a frame on entering the procedure body, so we would lose proper tail-recursion. We will solve this problem by writing a new compilation function compile-tail, which will be used for compiling expressions in tail position only. The specification for

compile-tail will be:

((compile-tail exp) '() env k) = (eval-exp exp env k)

[Very close to our original try at a specification for func-rep!] We’ll do this in the next section. Assuming we can fulfill this specification, then we can

replace apply-proc by:

(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (closure (formals body env)
        ((compile-tail body)
         '()
          (extend-env formals args env)
          k)))))

2. This compiles the body of the procedure, all right, but it still doesn’t do the right thing: it recompiles the procedure body every time the procedure is called! Let’s summarize the important “times” in the execution of a procedure call:

1. compilation time– when compile-exp is executed:

(define compile-exp
  (lambda (exp next-action)
    (record-case exp
      ...
      (proc-exp (formals body)
        (proc-action
          formals
          body
          next-action))
      ...)))

2. procedure creation time– when proc-action is executed:

(define proc-action
  (lambda (formals body next-action)
    (lambda (buf env k)
      (next-action
        (cons (make-closure formals body env) buf)
        env k))))

3. procedure application time– when apply-proc is executed:

(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (closure (formals body env)
        ((compile-tail body)
         '()
          (extend-env formals args env)
          k)))))

But the action of apply-proc on this closure depends only on (compile-tail body), not on body. But we could compute this all the way back at compile time! So we can do it then, and just pass the compiled code around instead of the original body-expression. In this model, the three crucial bits of code become:

1. compilation time– when compile-exp is executed:

(define compile-exp
  (lambda (exp next-action)
    (record-case exp
      ...
      (proc-exp (formals body)
        (proc-action
          formals
          (compile-tail body)  ; put compiled code in closure
          next-action))
      ...)))

2. procedure creation time– when proc-action is executed:

;; same text, but BODY is now compiled code.
(define proc-action
  (lambda (formals body next-action)
    (lambda (buf env k)
      (next-action
        (cons (make-closure formal body env) buf)
        env k))))

3. procedure application time– when apply-proc is executed:

(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (closure (formals body env)
        (body                           ; body is now compiled code
          '()
          (extend-env formals args env)
          k)))))

And this does the job as desired. Voila!

                     Writing compile-tail

Now all we have to do is to write compile-tail, which is to satisfy the specification

((compile-tail exp) '() env k) = (eval-exp exp env k)

This is made easier by the action restore above:

(define restore-action
  (lambda ()
    (lambda (buf env k)
      (k (car buf)))))

For then we have

(frame (restore-action) '() env k)
= (lambda (v) ((restore-action) (cons v '()) env k))
= (lambda (v) (k v))
= k

So we have for any exp:

((compile-exp exp (restore-action)) '() env k)
= (eval-exp exp env (frame (restore-action) '() env k))
= (eval-exp exp env k)

So we could define

(define compile-tail
  (lambda (exp)
    (compile-exp exp (restore-action))))

But this wouldn’t help us get our procedure bodies tail-recursive. Instead, we write a special version of compile-exp that inserts a restore when necessary, but uses a tail-recursive version of call-action:

(define compile-tail
(lambda (exp)
(record-case exp
(lit-exp (datum) (lit-action datum (restore-action))
(var-exp (id) (var-action id (restore-action))
(if-exp (test-exp exp1 exp2)
  (compile-exp test-exp
    (test-action
      (compile-tail exp1)
      (compile-tail exp2))))
(binop-exp (binop exp1 exp2)
  (compile-exp exp1
    (compile-exp exp2
      (binop-action binop (restore-action)))))
(proc-exp (formals body)
  (proc-action
    formals
    (compile-tail body)
    (restore-action)))
(app-exp (rator rands)
   (compile-exp rator
     (compile-rands rands
       (tail-call-action (length rands)))))
(else (error 'compile-exp "unknown exp ~s" exp)))))
(define tail-call-action
(lambda (n)
(lambda (buf env k)
(letrec
  ((loop (lambda (n buf args)
           (if (zero? n)
             (apply-proc (car buf) args k)
             (loop (- n 1) (cdr buf) (cons (car buf) args))))))
  (loop n buf '())))))

The compiler summarized

(define compile-exp
(lambda (exp next-action)
(record-case exp
(lit-exp (datum) (lit-action datum next-action))
(var-exp (id) (var-action id next-action))
(if-exp (test-exp exp1 exp2)
  (compile-exp test-exp
    (test-action
      (compile-exp exp1 next-action)
      (compile-exp exp2 next-action))))
(unop-exp (unop exp1)
  (compile-exp exp1
    (unop-action unop next-action)))
(binop-exp (binop exp1 exp2)
  (compile-exp exp1
    (compile-exp exp2
      (binop-action binop next-action))))
(proc-exp (formals body)
  (proc-action
    formals
    (compile-tail body)
    next-action))
(app-exp (rator rands)
  (compile-exp rator
    (compile-rands rands
      (call-action (length rands)
        next-action))))

(let-exp (decls body)
  ;; macro-expand into application and compile
  (compile-exp
    (make-app-exp
      (make-proc-exp
        (map decl->name decls)
        body)
      (map decl->exp decls))
    next-action))
(else (error 'compile-exp "unknown exp ~s" exp)))))
(define compile-rands
(lambda (rands next-action)
(if (null? rands)
next-action
(compile-exp (car rands)
  (compile-rands (cdr rands) next-action)))))
(define compile-tail
(lambda (exp)
(record-case exp
(lit-exp (datum) (lit-action datum (restore-action)))
(var-exp (id) (var-action id (restore-action)))
(if-exp (test-exp exp1 exp2)
  (compile-exp test-exp
    (test-action
      (compile-tail exp1)
      (compile-tail exp2))))
(unop-exp (unop exp1)
  (compile-exp exp1
    (unop-action unop (restore-action))))
(binop-exp (binop exp1 exp2)
  (compile-exp exp1
    (compile-exp exp2
      (binop-action binop (restore-action)))))

(proc-exp (formals body)
  (proc-action
    formals
    (compile-tail body)
    (restore-action)))
(app-exp (rator rands)
     (compile-exp rator
       (compile-rands rands
         (tail-call-action (length rands)))))
(let-exp (decls body)
  (compile-tail
    (make-app-exp
      (make-proc-exp
        (map decl->name decls)
        body)
      (map decl->exp decls))))
(else (error 'compile-exp "unknown exp ~s" exp)))))

;;; action-builders (instruction emitters)
(define lit-action
  (lambda (datum next-action)
    (cons (list 'lit datum) next-action)))
(define var-action
  (lambda (id next-action)
    (cons (list 'fetch id) next-action)))
(define test-action
  (lambda (true-action false-action)
    (cons
      (cons 'jump-if-true true-action)
      false-action)))
(define unop-action
  (lambda (unop next-action)
    (cons (list 'do-unop unop) next-action)))
(define binop-action
  (lambda (binop next-action)
    (cons (list 'do-binop binop) next-action)))
(define restore-action
  (lambda ()
    '((restore))))
(define proc-action
  (lambda (formals body next-action)
    (cons (list 'push-closure formals body) next-action)))
(define call-action
  (lambda (n next-action)
    (cons (list 'call n) next-action)))

(define tail-call-action
  (lambda (n)
    (list (list 'tail-call n))))

;;; The Machine
(define apply-action
(lambda (action buf env k)
(let ((instruction (car action))
(next-action (cdr action)))
(case (car instruction)
((lit)
(let ((datum (cadr instruction)))
(apply-action next-action
(cons datum buf) env k)))
((fetch)
(let ((id (cadr instruction)))
(apply-action next-action
(cons
  (apply-env env id)
  buf)
env k)))
((jump-if-true)
(let ((true-action (cdr instruction))
  (false-action next-action))
(if (true-value? (car buf))
(apply-action true-action  (cdr buf) env k)
(apply-action false-action (cdr buf) env k))))
((do-unop)
(let ((unop (cadr instruction)))
(apply-action next-action
(cons (apply-unop unop (car buf))
      (cdr buf))
env k)))
((do-binop)
(let ((binop (cadr instruction)))
(apply-action next-action
(cons (apply-binop binop (cadr buf) (car buf))
      (cddr buf))

env k)))
((push-closure)
(let ((formals (cadr instruction))
  (body   (caddr instruction)))
(apply-action next-action
(cons (make-closure formals body env) buf)
env k)))
((call)
(let ((n (cadr instruction)))
(letrec
((loop (lambda (n buf args)
         (if (zero? n)
           (apply-proc (car buf) args
             (make-frame next-action (cdr buf) env k))
           (loop (- n 1) (cdr buf) (cons (car buf) args))))))
(loop n buf '()))))
((tail-call)
(let ((n (cadr instruction)))
(letrec
((loop (lambda (n buf args)
         (if (zero? n)
           (apply-proc (car buf) args k)
           (loop (- n 1) (cdr buf) (cons (car buf) args))))))
(loop n buf '()))))
((restore)
(apply-cont k (car buf)))
(else
(error 'apply-action
"unknown instruction ~s"
instruction))))))

Continuations

(define-record frame (next-action buf env k))
(define-record init-cont ())
(define apply-cont
  (lambda (k v)
    (record-case k
      (init-cont () v)
      (frame
        (action buf env k)
        (apply-action action (cons v buf) env k))
      (else
        (error 'apply-cont
          "unknown continuation ~s" k)))))
(define apply-proc
  (lambda (proc args k)
    (record-case proc
      (closure (formals body env)
        (apply-action
          body
         '()
          (extend-env formals args env)
          k)))))

;;; Top level
(define run
  (lambda (string)
    (let ((code (compile-tail (scan&parse string))))
      (printf "Source program:~%~d~%Compiled code:~%" string)
      (pretty-print code)
      (apply-action code  '() (make-init-env) (make-init-cont)))))
> (load "parse-utils.s")
> (load "syntax.s")
> (load "compiler.s")
> (run pgm1)
Source program:
1
Compiled code:
((lit 1) (restore))
1
> (run pgm2)
Source program:
(+ 40 50)
Compiled code:
((lit 40) (lit 50) (do-binop (add-binop)) (restore))
90
> (run pgm3)
Source program:
(proc (f) (f 40 50) proc (x y) (+ x y))
Compiled code:
((push-closure
    (f)
    ((fetch f) (lit 40) (lit 50) (tail-call 2)))
 (push-closure
    (x y)
    ((fetch x) (fetch y) (do-binop (add-binop)) (restore)))
 (tail-call 1))

> (run pgm4)
Source program:
let diff = proc (x y)(- x y) in (diff 6 4)
Compiled code:
((push-closure
    (diff)
    ((fetch diff) (lit 6) (lit 4) (tail-call 2)))
 (push-closure
    (x y)
    ((fetch x) (fetch y) (do-binop (sub-binop)) (restore)))
 (tail-call 1))
2
> (run pgm5)
Source program:
let app = proc(f x) (add1 (f x))
       foo = proc (x) (add1 x)
    in (app foo 17)
Compiled code:
((push-closure
    (app foo)
    ((fetch app) (fetch foo) (lit 17) (tail-call 2)))
 (push-closure
    (f x)
    ((fetch f)
     (fetch x)
     (call 1)
     (do-unop (incr-unop))
     (restore)))
 (push-closure
    (x)
    ((fetch x) (do-unop (incr-unop)) (restore)))
 (tail-call 2))
19

44