@comment(Hey, EMACS, this is -*- SCRIBE -*- input)
@make(6001)
@set(chapter=1)
@set(page=1)

@PageHeading(even,
             left "@Value(Page)",
             right "6.001")

@PageHeading(odd,
             Left "Problem Set 10",
             right "@value(page)")

@begin(center)
MASSACHUSETTS INSTITUTE OF TECHNOLOGY
Department of Electrical Engineering and Computer Science
6.001 Structure and Interpretation of Computer Programs

Problem Set 10

@b[Register Machines]
@end(center)

@begin(format)
Issued: 29 November 1983@>Due: 14 December 1983

Reading Assignment:  Chapter 5
@end(format)

@blankspace(0.25 in)

This is a two-week problem set.  It covers the three major programs
discussed in chapter 5: the register-machine simulator, the
explicit-control evaluator, and the compiler.  We are not asking you
to do much programming for this assignment, but there is an enormous
amount of code to look at.  The versions of the programs here have
been changed somewhat from the ones given in the notes.  The
differences are minor and should not cause much trouble, since we are
asking you only to use these programs, not to modify them.  However,
in case of problems, you should consult the attached listings rather
than the listings in the notes.


@b[Bring this handout with you to Lectures on Thursday, December 2 and
Tuesday, December 6.]

The following files have been included with this problem set:

@begin(description)
@a[PS10-REGSIM.SCM]@\This is the register machine simulator discussed
in section 5.1.5.  It has been modified to include a monitored stack,
as suggested in section 5.2.1 (with a somewhat different version of
the monitored stack than is given in the notes).

@a[PS10-ECEVAL-SYNTAX.SCM]@\These are Scheme procedures that define the
representation of expressions and environments.  This is essentially
the same syntax as was used in the meta-circular evaluator, with a few
additions required by the explicit-control version.

@a[PS10-ECEVAL.SCM]@\This is the explicit-control evaluator described in
section 5.2.  All of the code has been collected here in the form of a
definition to be processed by the register machine simulator when
the file is loaded.  @b[You should not load this file until you have
loaded the previous two files.]  This version of the evaluator also
has hooks in it to handle code produced by the compiler.  (More about
this below.)

@a[PS10-COMPILER.SCM]@\This is the compiler, discussed in section 5.4.
@end(description)

@paragraph(Problem 1 -- Designing Register Machines)

Enter Scheme and load the register machine simulator.  You can now
define register machines using the command @a[define-machine], as
shown in the examples on pages 303, 310, and 312.  Observe the format
for a machine definition: a list of registers, and list of the
permissible operations, and a list that defines the controller
sequence.

For this problem, we ask you to define a machine that computes
exponentials, using the recursive algorithm:

@begin(example)
(define (expt b e)
  (cond ((= b 0) 1)
        (else (* b (expt b (- e 1))))))
@end(example)

You will find it useful to model your definition on the definition of
the @a[sum] machine on page 310 (except for the use of instructions to
monitor the stack -- see paragraph below):

@begin(example)
(define-machine expt
  (registers ....)
  (operations
   ...)
  (controller
   ...))
@end(example)

After you have read this definition into Scheme, you can use the
machine by assigning initial values to the registers, then using
@a[start] to start the machine.  For example, you should be able to
compute 2@+[6] as follows:
@begin(example)
(remote-assign expt 'b 2)

(remote-assign expt 'e 6)

(start expt)
@end(example)
If all goes well, the simulation should terminate, printing @a[done],
and you can now find the answer by examining the @a[val] register (or
whichever register you stashed the answer in):
@begin(example)
==>(remote-fetch expt 'val)
@end(example)

In addition, this version of the register machine simulator includes a
monitored stack.  To access it, you can include in your machine
definition the instruction 
@begin(example)
(perform (the-stack 'initialize))
@end(example)
as the very first instruction in the controller sequence.  As the very
last instruction, you can use
@begin(example)
(perform (the-stack 'print-statistics))
@end(example)
which will print the total number of pushes and the maximum stack
depth used during the computation.

After you get your machine debugged, do some analysis of the stack
usage.  How many stack pushes are performed in raising a number to the
3rd power?  To the 4th power?  What is the maximum stack depth in each
case?

Give formulas for the number of pushes and maximum depth used in
computing @a[b@+[e]] (for @a[e]>1) as a function of @a[e].  Hint:
Both of these should grow linearly with @a[e], that is, they should
be formulas of the form @a[xe+y], so you should be able to derive the
formula by doing two experiments.  Then do a third experiment to check
your formula.

@b[Advice:] As you will find from doing this problem, low-level
machine programming like this can be painful.  (That is why we build
interpreters and compilers, after all.)  In particular, it is very
easy to mess up the use of the stack, forgetting to save a register
that was restored, or vice versa.  If you get hopelessly bogged down,
it may help to monitor the actual saves and restores.  You can do this
by changing the @a[make-new-machine] procedure, redefining the
internal @a[save] and @a[restore] instructions to print the name of
the register being accessed (which is the @a[cdr] of the register, in
this representation).  You could also simply @a[trace] the internal
@a[save] and @a[restore] procedures, by evaluating for example:
@begin(example)
(eval '(trace save) expt)
@end(example)
but this will print out a lot of garbage every time the @a[continue]
register is accessed, since the value of @a[continue] is a sequence of
procedures (the operation sequence at which to continue).

Turn in for this problem a listing of your machine definition together
with the stack-usage formulas that you derived.

@paragraph(Problem 2 -- Using the Evaluator)

Load into Scheme the files @a[ECEVAL-SYNTAX] and @a[ECEVAL] (you must
have @a[REGSIM] loaded first!).  Loading this file will define
@a[explicit-control-evaluator] as a register machine.  To start the
machine, execute the no-argument procedure called @a[go].  At the
beginning of each @a[read-eval-print] cycle, the system prints the
stack statistics that tell how many operations were used during the
previous cycle.

In order to help you keep straight when you are typing at Scheme and
when you are typing at the simulated evaluator, the simulation uses the
prompt @a[EC-EVAL==>].  Here is an example, showing the evaluator
being started and used:
@begin(example)
==> (go)
@d[(TOTAL-PUSHES: 0 MAXIMUM-DEPTH: 0)]
EC-EVAL==>(define x 73)
@d[X]
@d[(TOTAL-PUSHES: 3 MAXIMUM-DEPTH: 3)]
EC-EVAL==>(+ x (* x 2))
@d[219]
@d[(TOTAL-PUSHES: 16 MAXIMUM-DEPTH: 8)]
EC-EVAL==>
@end(example)

Play around evaluating some expressions.  Note that there is no real
error handler for the evaluator, so most errors will bounce you out
into Scheme.  You can restart by executing @a[go] (the global
environment will remain intact, so you won't lose previous definitions
by encountering an error.  The only primitive operations that have
been placed in the global environment are:
@begin(example)
car cdr cons atom? eq? + - * / > < =
@end(example)
but you can define more if you like.  See the procedure
@a[setup-environment] in the @a[ECEVAL] file.

Once you have things working, define the exponentiation procedure
that you hand-translated in problem 1:
@begin(example)
(define (expt b e)
  (cond ((= b 0) 1)
        (else (* b (expt b (- e 1))))))
@end(example)

Note that you must type this definition into the evaluator directly,
not to the editor, since there is no editor interface on the
simulation level.  Don't be shocked when this procedure runs extremely
slowly compared to how fast it would run in Scheme (better use small
values of @a[e]).  Think about the multiple layers of simulation
involved.

Determine how many pushes, and the maximum stack depth required by the
explicit control evaluator to compute @a[(expt b e)] as a function of
@a[e].

Note that the maximum stack depth essentially measures the space
required by the @a[expt] process, while the total number of pushes is
a good indication of the time required.

@paragraph(Problem 3 -- Varying the procedure)

Type in and run the following alternative version of the @a[expt]
procedure:
@begin(example)
(define (expt1 b e)
  (cond ((= b 0) 1)
        (else (* (expt1 b (- e 1)) b))))
@end(example)

Once again, take statistics and give formulas for the number of pushes
and maximum stack depth involved.  You should discover that @a[expt]
and @a[expt1] behave somewhat differently.  What is the reason for
this difference?  Which procedure executes more efficiently?

@paragraph(Problem 4 -- Iteration)

Give formulas for the stack usage in the following exponentiation
process:
@begin(example)
(define (expt-iter b e)
  (define (iter count acc)
    (cond ((> count e) acc)
          (else (iter (+ count 1) (* b acc)))))
  (iter 1 1))
@end(example)
You should find that the maximum stack depth required here is
independent of @a[e] (for @a[e]>1).  This illustrates that the
procedure really is being executed as an iteration, because of the
tail-recursive nature of the evaluator.

@paragraph(Problem 5 -- Compilation)

Assuming that all the previous files have been loaded, you can load
the compiler into Scheme.  The basic program here is called
@a[compile].  For example
@begin(example)
==>(compile '(+ x (* y z)))
@end(example)
will show you the compilation of this expression.  The code sequence
is actually the third element in the list returned by the compiler.
the first two items are internal information used by the compiler
itself (the @a[needs] and @a[mung] lists, which are described in the
notes). 

The compiled code is arranged to interface with the interpreter by
expecting that when it is called, the continuation address is saved on
the stack, and the result is wanted in @a[val].  (This is essentially
how interpreted procedure bodies behave.)

Use the compiler to compare the compilation of the expressions
@begin(example)
(+ x (* y z))       @r[versus]        (+ (* y z) x)
@end(example)

Explain the differences between these two code sequences, in
particular, why different registers are being saved and restored.
Does this shed any light on the comparison between @a[expt] and
@a[expt1] in problem 3?

@paragraph(Problem 6 -- Running compiled code)

The explicit control interpreter includes a special form called
@a[compile-and-run], which takes an expression, compiles it, and runs
the result.  For example, to define a compiled version of the @a[expt]
procedure, start the interpreter and type
@begin(example)
EC-EVAL==>(compile-and-run
           (define (c-expt b e)
             (cond ((= e 0) 1)
                   (else (* b (c-expt (- e 1)))))))
@end(example)
This will compile the definition of @a[c-expt] and run the @a[define]
so that @a[c-expt] can now be called just like any procedure:
@begin(example)
EC-EVAL==>(c-expt 2 3)
@end(example)
In this case @a[c-expt] is just like @a[expt], except that it calls
compiled code, rather than having the interpreter trace through the
definition every time.

In this way, define compiled versions @a[c-expt], @a[c-expt1], and
@a[c-expt-iter] of the procedures you defined in problems 2,3, and 4.
Take stack usage statistics for each one, and give formulas for total
number of pushes and maximum depth.

@paragraph(Problem 7 -- Summary analysis)

You now have experimented with three versions of the exponential program,
both in compiled and interpreted form.  For each program you have a
formula, in terms of @a[e], of the approximate time (number of pushes)
and space (maximum stack depth) required to compute @a[b@+[e]].

Taking the ratio of compiled to interpreted version will tell us how
much the compiler speeds up the computation, and how much space
efficiency it buys us.  (Since all the formulas are of the form
@a[xe+y] each ratio will approach a constant as @a[e] becomes large.
It is this constant in which we are interested.)

Fill in the following table, with the ratios that you compute for each
of the three procedures

@begin(programexample)

                Ratio of Compiled to Interpreted Code


                     Speed-up                Space-saving
--------------------------------------------------------------
EXPT       |                      |                          |
-----------|----------------------|--------------------------|
EXPT1      |                      |                          |
-----------|----------------------|--------------------------|
EXPT-ITER  |                      |                          |
--------------------------------------------------------------
@end(programexample)

Also compute the ratios of time and space usage comparing @a[expt]
with the special-purpose machine you designed in problem 1.  Fill in
the following chart:

@begin(programexample)

               Ratio to Performance of Interpreted EXPT


                     Speed-up                Space-saving
--------------------------------------------------------------
compiled code |                   |                          |
--------------|-------------------|--------------------------|
hand-generated|                   |                          |
code          |                   |                          |
--------------------------------------------------------------
@end(programexample)


Your special-purpose machine should do much better than the compiled
version, since (if you are careful) your ``hand-compilation'' should
be much better than what is produced by our rather rudimentary
general-purpose compiler.  Can you think of improvements to the
compiler that would help it generate code that would come closer in
performance to your hand-generated procedure?

@newpage()
@begin(programexample)
;;; This is the register machine simulator
;;; file ps10-regsim.scm


;;; Magic syntax hack... DO NOT expect to understand this.  Hal doesn't, 
;;; and he wrote it!

(define-syntax
 define-machine
 (source->source
  (lambda(exp)
    `(define ,(second exp) (check-syntax-and-assemble ',exp)))))

;;; To set up a simulation:

(define (check-syntax-and-assemble machine-description)
  (define (check-for symbol structure)
    (cond ((not (pair? structure))
           (error "bad machine description format" structure))
          ((not (eq? (car structure) symbol))
           (error "bad machine description keyword"
                  (list symbol structure)))
          (else 'ok)))
  (check-for 'define-machine machine-description)
  (check-for 'registers (nth 2 machine-description))
  (check-for 'operations (nth 3 machine-description))
  (check-for 'controller (nth 4 machine-description))
  (assemble (cdr (nth 2 machine-description))
            (cdr (nth 3 machine-description))
            (cdr (nth 4 machine-description))))

(define (assemble registers operations controller)
  (let ((machine (make-new-machine)))
    (set-up-registers machine registers)
    (set-up-operations machine operations)
    (set-up-controller machine controller)
    machine))

(define (set-up-registers machine registers)
  (remote-set! machine '*registers* registers)
  (mapc (lambda (register-name)
          (remote-define machine register-name 
                         (make-register register-name)))
        registers))

(define (make-register name) 
  (cons nil name))

(define fetch car)

(define (set-up-operations machine operations)
  (remote-set! machine '*instruction-map*
    (mapcar (lambda (operation)
              (cons operation
                    (make-machine-instruction machine
                                              operation)))
            operations)))

(define (set-up-controller machine controller)
  (define (build-instruction-list op-list)
    (if (null? op-list)
        '()
        (let ((rest-of-instructions
               (build-instruction-list (cdr op-list))))
          (if (symbol? (car op-list))     ; An atomic symbol
                                          ; indicates a label
              (sequence (declare-label! machine
                                        (car op-list)
                                        rest-of-instructions)
                        rest-of-instructions)
              (cons (lookup-operation machine (car op-list))
                    rest-of-instructions)))))
  (remote-set! machine
               '*start*
               (build-instruction-list controller)))

(define (declare-label! machine label labeled-entry)
  (let ((defined-labels (remote-get machine '*labels*)))
    (if (memq label defined-labels)
        (error "Multiply defined label" label)
        (sequence
         (remote-define machine label labeled-entry)
         (remote-set! machine
                      '*labels*
                      (cons label defined-labels))))))

(define (lookup-operation machine op)
  (let ((pair (assoc op
                     (remote-get machine
                                 '*instruction-map*))))
    (if (null? pair)
        (error "Undeclared op" op)
        (cdr pair))))

(define (remote-get machine variable)
  (eval variable machine))

(define (remote-set! machine variable value)
  (eval (list 'set! variable (list 'quote value))
        machine))

(define (remote-define machine variable value)
  (eval (list 'define variable (list 'quote value))
        machine))

(define (make-machine-instruction machine op)
  (eval (list 'lambda '() op) machine))

(define (remote-fetch machine register-name)
  (car (remote-get machine register-name)))

(define (remote-assign machine register-name value)
  (set-car! (remote-get machine register-name) value))

(define (start machine)
  (eval '(sequence (goto *start*)
                   (execute-next-instruction))
        machine))

;;monitored stack

(define (make-stack)
  (define s nil)
  (define number-pushes 0)
  (define max-depth 0)
  (define (push x)
    (set! s (cons x s))
    (set! number-pushes (1+ number-pushes))
    (set! max-depth (max (length s) max-depth)))
  (define (pop)
    (let ((top (car s)))
      (set! s (cdr s))
      top))
  (define (initialize)
    (set! s nil)
    (set! number-pushes 0)
    (set! max-depth 0))
  (define (print-statistics)
    (print (list 'total-pushes: number-pushes
                 'maximum-depth: max-depth)))
  (define (dispatch message)
      (cond ((eq? message 'push) push)
            ((eq? message 'pop) (pop))
            ((eq? message 'initialize) (initialize))
            ((eq? message 'print-statistics) (print-statistics))
            (else (error "Unknown request -- STACK"
                         message))))
  dispatch)

(define (make-new-machine)
  (make-environment

   ;;routine to assign values to registers
   (define (assign register value)
     (set-car! register value)
     (normal-next-instruction))

   ;;saving and restoring registers
   (define the-stack (make-stack))

   (define (initialize-stack)
     (the-stack 'print-statistics)
     (the-stack 'initialize))
     
   (define (save reg)
     ((the-stack 'push) (fetch reg))
     (normal-next-instruction))

   (define (restore reg)
     (assign reg (the-stack 'pop)))

   ;;sequencing instructions
   (define program-counter (make-register 'program-counter))

   (define (execute-next-instruction)
     (cond ((null? (fetch program-counter)) 'done)
           (else
            ((car (fetch program-counter)))
            (execute-next-instruction))))

   (define (normal-next-instruction)
     (set-car! program-counter (cdr (fetch program-counter))))

   (define (goto new-sequence)
     (set-car! program-counter new-sequence))

   (define (branch predicate alternate-next)
     (if predicate
         (goto alternate-next)
         (normal-next-instruction)))

   ;; routine for simulating special instructions
   (define (perform op)
     (normal-next-instruction))

   ;; special variables used by the assembler
   (define *instruction-map* nil)
   (define *labels* nil)
   (define *registers* nil)
   (define *start* nil)

   ))
@end(programexample)
@newpage()
@begin(programexample)
;;;File PS10-ECEVAL.SYNTAX.SCM
;;;These are the definitions of the representations of expressions and
;;;environments used by the explicit-control evaluator.  These are
;;;essentially the same as the ones used by the meta-circualr
;;;evaluator, with a few additions (e.g., no-argument procedures).


(define (self-evaluating? exp) (number? exp))

(define (quoted? exp)
  (if (atom? exp)
      nil
      (eq? (car exp) 'quote)))

(define (text-of-quotation exp) (cadr exp))

(define (variable? exp) (symbol? exp))

(define (assignment? exp)
  (if (atom? exp)
      nil
      (eq? (car exp) 'set!)))

(define (assignment-variable exp) (cadr exp))

(define (assignment-value exp) (caddr exp))

(define (definition? exp)
  (if (atom? exp)
      nil
      (eq? (car exp) 'define)))

(define (definition-variable exp)
  (cond ((variable? (cadr exp))
         (cadr exp))
        (else
         (caadr exp))))

(define (definition-value exp) 
  (cond ((variable? (cadr exp))
         (caddr exp))           
        (else
         (cons 'lambda
               (cons (cdadr exp)
                     (cddr exp))))))

(define (lambda? exp)
  (if (atom? exp)
      nil
      (eq? (car exp) 'lambda)))

(define (conditional? exp)
  (if (atom? exp)
      nil
      (eq? (car exp) 'cond)))

(define (clauses exp) (cdr exp))

(define (no-clauses? clauses) (null? clauses))

(define (first-clause clauses) (car clauses))

(define (rest-clauses clauses) (cdr clauses))

(define (predicate clause) (car clause))

(define (action-sequence clause) (cdr clause))

(define (true? x) (not (null? x)))

(define (else-clause? clause)
  (eq? (predicate clause) 'else))

(define (last-exp? seq) (eq? (cdr seq) nil))

(define (first-exp seq) (car seq))

(define (rest-exps seq) (cdr seq))

(define (no-args? exp)
  (if (atom? exp)
      nil
      (null? (cdr exp))))

(define (application? exp)
  (if (atom? exp)
      nil
      (not (null? (cdr exp)))))

(define (operator app) (car app))

(define (operands app) (cdr app))

(define (no-operands? args) (eq? args nil))

(define (last-operand? args)
  (null? (cdr args)))

(define (first-operand args) (car args))

(define (rest-operands args) (cdr args))

(define (make-procedure lambda-exp env)
  (list 'procedure lambda-exp env))

(define (compound-procedure? proc)
  (if (atom? proc)
      nil
      (eq? (car proc) 'procedure)))

(define (parameters proc) (cadr (cadr proc)))

(define (procedure-body proc) (cddr (cadr proc)))

(define (procedure-environment proc) (caddr proc))

;;; representing environments

(define (make-binding variable value)
  (cons variable value))

(define (binding-variable binding)
  (car binding))

(define (binding-value binding)
  (cdr binding))

(define (set-binding-value! binding value)
  (set-cdr! binding value))


(define (binding-in-frame var frame)
  (assq var frame))


(define (make-frame variables values)
  (cond ((and (null? variables) (null? values)) '())
        ((null? variables)
         (error "Too many values supplied" values))
        ((null? values)
         (error "Too few values supplied" variables))
        (else
         (cons (make-binding (car variables)
                             (car values))
               (make-frame (cdr variables)
                           (cdr values))))))
(define (first-frame env) (car env))

(define (rest-frames env) (cdr env))

(define (adjoin-frame frame env) (cons frame env))

(define (set-first-frame! env new-frame)
  (set-car! env new-frame))

(define (binding-in-env var env)
  (if (null? env)
      nil
      (let ((b (binding-in-frame var
                                 (first-frame env))))
        (if (not (null? b))
            b
            (binding-in-env var (rest-frames env))))))

(define (lookup-variable-value var env)
  (let ((b (binding-in-env var env)))
    (if (null? b)
        (error "Unbound variable" var)
        (binding-value b))))

(define (extend-environment variables values base-env)
  (adjoin-frame (make-frame variables values) base-env))

(define (set-variable-value! var val env)
  (let ((b (binding-in-env var env)))
    (if (null? b)
        (error "Unbound variable" var)
        (set-binding-value! b val))))

(define (define-variable! var val env)
  (set-first-frame! env
                    (cons (make-binding var val)
                          (first-frame env))))
@end(programexample)
@newpage()
@begin(programexample)
;;; file ps10-eceval.scm
;;;explicit control evaluator, with modifications to handle complied
;;;code.  works with register machine simulator and eceval-syntax procedures

;;;This file contains the definition of the explicit control
;;;evaluator, in a form that an be processed by the register macine
;;;simulator.  There are also a few interface procedures, which allow
;;;the ec-evaluator to call the underlying Lisp in order to run
;;;primitive procedures.   Also a few utilities used to construct
;;;environments, to set up the initial environment, and the READ and
;;;PRINT operations used by the evaluator.  It also includes a few
;;;additional syntax procedures needed to handle compiled code.

;;;Before loading this file, one should have loaded the register
;;;machine simulator, so it can process the definition; and the
;;;ECEVAL-SYNTAX procedures, which define the representations of
;;;expressions and environments.  You should also load the COMPILER,
;;;in order to generate compiled code.

;;;Once all this has been loaded, you can run the evaluator by executing
;;;      (go)


;;;the compiler has been set up so that you can call it from within
;;;the ec-evaluator using the special form COMPILE-AND-RUN, for
;;;example
;;;EC-EVAL==> (compile-and-run (define (frob x y) (+ x (* 2 y))))


(define (go)
  (start explicit-control-evaluator))

;;;Linking to compiled code

(define (cload insts)
  (cond ((null? insts) nil)
        ((symbol? (car insts))
	 (let ((rest (cload (cdr insts))))
	   (declare-label! explicit-control-evaluator (car insts) rest)
	   rest))
        (else (cons (make-machine-instruction
                     explicit-control-evaluator
                     (car insts))
                    (cload (cdr insts))))))

;;;syntax to recognize compiled procedures

(define (compiled-procedure? p)
  (if (atom? p)
      nil
      (eq? (car p) 'compiled-procedure)))

(define (make-compiled-procedure code env)
  (list 'compiled-procedure code env))

(define (code-of-compiled-procedure p) (cadr p))

(define (env-of-compiled-procedure p) (caddr p))


;;code to recognize compilation commands

(define (compilation? exp)
  (eq? (car exp) 'compile-and-run))

(define (compilation-expression exp)
  (cadr exp))

;;;Primitives:
;;;For our purposes, a "primitive procedure" is one that is given in
;;;a specified list of primitives.

(define (primitive-procedure? p)
  (applicable? p))

(define primitive-procedure-names
  '(car cdr cons atom? eq?
    + - * / > < =))
    
(define primitive-procedures
  (list car cdr cons atom? eq?
        + - * / > < =))

;;;the arglist for eceval appears in reverse order, so this reversal
;;;must be undone when passing args off to a Scheme procedure

(define (apply-primitive-procedure p args)
  (apply p (reverse args)))

;;; The same reversal is needed when we interface to the
;;;environment-constructing routines, to build the environment for
;;;procedure application

(define (make-bindings proc args)
  (extend-environment (parameters proc)
                      (reverse args)
                      (procedure-environment proc)))

;;; seting up the initial environment

(define (setup-environment)
  (define initial-env
    (extend-environment primitive-procedure-names
                        primitive-procedures
                        nil))
  (define-variable! 'nil nil initial-env)
  (define-variable! 't (not nil) initial-env)
  initial-env)

(define the-simulated-global-environment (setup-environment))

(define (user-print object)
  (cond ((compound-procedure? object)
         (print (list 'compound-procedure
                      (parameters object)
                      (procedure-body object)
                      '<procedure-env>)))
        ((compiled-procedure? object)
         (print '<compiled-procedure>))
        (else (print object))))

(define (prompting-read prompt)
  (newline)
  (princ prompt)
  (read))

;;;Here is the definition of the evaluator itself.

(define-machine explicit-control-evaluator
  (registers exp env unev argl fun val continue)
  (operations
  (assign exp (compilation-expression (fetch exp)))
  (assign val (compile (fetch exp)))
  (assign continue (cload (caddr (fetch val))))
   (assign argl '())
   (assign argl (cons (fetch val) (fetch argl)))
   (assign continue accumulate-arg)
   (assign continue accumulate-last-arg)
   (assign continue setup-no-arg-apply)
   (assign continue print-result)
   (assign continue ev-assignment-1)
   (assign continue ev-definition-1)
   (assign continue eval-sequence-continue)
   (assign continue eval-args)
   (assign continue evcond-decide)
   (assign continue (code-of-compiled-procedure (fetch fun)))

   (assign env (make-bindings (fetch fun) (fetch argl)))
   (assign env the-simulated-global-environment)
   (assign exp (prompting-read 'EC-EVAL==>))
   (assign exp (assignment-value (fetch exp)))
   (assign exp (definition-value (fetch exp)))
   (assign exp (first-clause (fetch unev)))
   (assign exp (first-exp (fetch unev)))
   (assign exp (first-operand (fetch unev)))
   (assign exp (operator (fetch exp)))
   (assign exp (predicate (fetch exp)))
   (assign exp (transform-let (fetch exp)))
   (assign fun (fetch val))
   (assign unev (action-sequence (fetch exp)))
   (assign unev (assignment-variable (fetch exp)))
   (assign unev (clauses (fetch exp)))
   (assign unev (definition-variable (fetch exp)))
   (assign unev (operands (fetch exp)))
   (assign unev (procedure-body (fetch fun)))
   (assign unev (rest-clauses (fetch unev)))
   (assign unev (rest-exps (fetch unev)))
   (assign unev (rest-operands (fetch unev)))

   (assign val (apply-primitive-procedure (fetch fun) (fetch argl)))
   (assign val (fetch exp))
   (assign val (fetch fun))
   (assign val (fetch unev))
   (assign val (lookup-variable-value (fetch exp) (fetch env)))
   (assign val (make-procedure (fetch exp) (fetch env)))
   (assign val (text-of-quotation (fetch exp)))
   (assign val nil)
   (assign val 'Unknown-expression-type-error)
   (assign val 'Unknown-procedure-type-error)

   (goto read-eval-print-loop)
   (goto apply-dispatch)
   (goto signal-error)
   (goto eval-sequence)
   (goto eval-arg-loop)
   (goto eval-dispatch)
   (goto evcond-pred)
   (goto unknown-expression-type-error)
   (goto unknown-procedure-type-error)
   (goto (fetch continue))

   (branch (application? (fetch exp)) ev-application)
   (branch (assignment? (fetch exp)) ev-assignment)
   (branch (compound-procedure? (fetch fun)) compound-apply)
   (branch (conditional? (fetch exp)) ev-cond)
   (branch (compilation? (fetch exp)) ev-compilation)
   (branch (definition? (fetch exp)) ev-definition)
   (branch (no-clauses? (fetch unev)) evcond-return-nil)
   (branch (else-clause? (fetch exp)) evcond-else-clause)
   (branch (lambda? (fetch exp)) ev-lambda)
   (branch (last-exp? (fetch unev)) last-exp)
   (branch (last-operand? (fetch unev)) eval-last-arg)
   (branch (no-args? (fetch exp)) ev-no-args)
   (branch (primitive-procedure? (fetch fun)) primitive-apply)
   (branch (compiled-procedure? (fetch fun)) compiled-apply)
   (branch (quoted? (fetch exp)) ev-quote)
   (branch (self-evaluating? (fetch exp)) ev-return)
   (branch (true? (fetch val)) evcond-true-predicate)
   (branch (variable? (fetch exp)) ev-variable)

   (perform (initialize-stack))
   (perform (define-variable! (fetch unev) (fetch val) (fetch env)))
   (perform (set-variable-value! (fetch unev) (fetch val) (fetch env)))
   (perform (user-print (fetch val)))
   (save argl) (restore argl)
   (save continue) (restore continue)
   (save env) (restore env)
   (save fun) (restore fun)
   (save unev) (restore unev))

(controller
 read-eval-print-loop
  (perform (initialize-stack))
  (assign exp (prompting-read 'EC-EVAL==>))
  (assign env the-simulated-global-environment)
  (assign continue print-result)
  (goto eval-dispatch)
 print-result
  (perform (user-print (fetch val)))
  (goto read-eval-print-loop)

 eval-dispatch
  (branch (self-evaluating? (fetch exp)) ev-return)
  (branch (quoted? (fetch exp)) ev-quote)
  (branch (variable? (fetch exp)) ev-variable)
  (branch (definition? (fetch exp)) ev-definition)
  (branch (assignment? (fetch exp)) ev-assignment)
  (branch (lambda? (fetch exp)) ev-lambda)
  (branch (conditional? (fetch exp)) ev-cond)
  (branch (compilation? (fetch exp)) ev-compilation)
  (branch (no-args? (fetch exp)) ev-no-args)
  (branch (application? (fetch exp)) ev-application)
  (goto unknown-expression-type-error)

 ev-return
  (assign val (fetch exp))
  (goto (fetch continue))
 ev-quote
  (assign val (text-of-quotation (fetch exp)))
  (goto (fetch continue))
 ev-variable
  (assign val
         (lookup-variable-value (fetch exp)
                                (fetch env)))
  (goto (fetch continue))
 ev-lambda
  (assign val
         (make-procedure (fetch exp)
                         (fetch env)))
  (goto (fetch continue))

 ev-compilation
  (save continue)
  (assign exp (compilation-expression (fetch exp)))
  (assign val (compile (fetch exp)))
  (assign continue (cload (caddr (fetch val))))
  (goto (fetch continue))

 ev-no-args
  (assign exp (operator (fetch exp)))
  (save continue)
  (assign continue setup-no-arg-apply)
  (goto eval-dispatch)

 setup-no-arg-apply
  (assign fun (fetch val))
  (assign argl '())
  (goto apply-dispatch)

 ev-application
  (assign unev (operands (fetch exp)))
  (assign exp (operator (fetch exp)))
  (save continue)
  (save env)
  (save unev)
  (assign continue eval-args)
  (goto eval-dispatch)

 eval-args
  (restore unev)
  (restore env)
  (assign fun (fetch val))
  (save fun)
  (assign argl '())
  (goto eval-arg-loop)

 eval-arg-loop
  (save argl)
  (assign exp (first-operand (fetch unev)))
  (branch (last-operand? (fetch unev)) eval-last-arg)
  (save env)
  (save unev)
  (assign continue accumulate-arg)
  (goto eval-dispatch)

 accumulate-arg
  (restore unev)
  (restore env)
  (restore argl)
  (assign argl (cons (fetch val) (fetch argl)))
  (assign unev (rest-operands (fetch unev)))
  (goto eval-arg-loop)

 eval-last-arg
  (assign continue accumulate-last-arg)
  (goto eval-dispatch)
 accumulate-last-arg
  (restore argl)
  (assign argl (cons (fetch val) (fetch argl)))
  (restore fun)
  (goto apply-dispatch)

 apply-dispatch
  (branch (primitive-procedure? (fetch fun)) primitive-apply)
  (branch (compound-procedure? (fetch fun)) compound-apply)
  (branch (compiled-procedure? (fetch fun)) compiled-apply)
  (goto unknown-procedure-type-error)

 primitive-apply
  (assign val
         (apply-primitive-procedure (fetch fun)
                                    (fetch argl)))
  (restore continue)
  (goto (fetch continue))

 compound-apply
  (assign env (make-bindings (fetch fun) (fetch argl)))
  (assign unev (procedure-body (fetch fun)))
  (goto eval-sequence)

 compiled-apply
  (assign continue (code-of-compiled-procedure (fetch fun)))
  (goto (fetch continue))

 eval-sequence
  (assign exp (first-exp (fetch unev)))
  (branch (last-exp? (fetch unev)) last-exp)
  (save unev)
  (save env)
  (assign continue eval-sequence-continue)
  (goto eval-dispatch)
 eval-sequence-continue
  (restore env)
  (restore unev)
  (assign unev (rest-exps (fetch unev)))
  (goto eval-sequence)
 last-exp
  (restore continue)
  (goto eval-dispatch)

 ev-cond
  (save continue)
  (assign continue evcond-decide)
  (assign unev (clauses (fetch exp)))
 evcond-pred
  (branch (no-clauses? (fetch unev)) evcond-return-nil)
  (assign exp (first-clause (fetch unev)))
  (branch (else-clause? (fetch exp)) evcond-else-clause)
  (save env)
  (save unev)
  (assign exp (predicate (fetch exp)))
  (goto eval-dispatch)
 evcond-return-nil
  (restore continue)
  (assign val nil)
  (goto (fetch continue))

 evcond-decide
  (restore unev)
  (restore env)
  (branch (true? (fetch val)) evcond-true-predicate)
  (assign unev (rest-clauses (fetch unev)))
  (goto evcond-pred)

 evcond-true-predicate
  (assign exp (first-clause (fetch unev)))
 evcond-else-clause
  (assign unev (action-sequence (fetch exp)))
  (goto eval-sequence)

 ev-assignment
  (assign unev (assignment-variable (fetch exp)))
  (save unev)
  (assign exp (assignment-value (fetch exp)))
  (save env)
  (save continue)
  (assign continue ev-assignment-1)
  (goto eval-dispatch)
 ev-assignment-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform (set-variable-value! (fetch unev) (fetch val) (fetch env)))
  (goto (fetch continue))

 ev-definition
  (assign unev (definition-variable (fetch exp)))
  (save unev)
  (assign exp (definition-value (fetch exp)))
  (save env)
  (save continue)
  (assign continue ev-definition-1)
  (goto eval-dispatch)
 ev-definition-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform (define-variable! (fetch unev) (fetch val) (fetch env)))
  (assign val (fetch unev))
  (goto (fetch continue))

 unknown-procedure-type-error
  (assign val 'unknown-procedure-type-error)
  (goto signal-error)
 unknown-expression-type-error
  (assign val 'unknown-expression-type-error)
  (goto signal-error)

 signal-error
  (perform (user-print (fetch val)))
  (goto read-eval-print-loop)

 done
  ))
@end(programexample)
@newpage()
@begin(programexample)
;;; file ps10-compiler.scm
;;; SCHEME compiler
;;;goes with ECEVAL interpreter with modifications for compiled code.

(define (compile exp)
  (compile-expression exp '() 'val 'return))

(define (compile-expression exp env target cont)
  (cond ((self-evaluating? exp)
	 (compile-constant exp target cont))
	((quoted? exp)
	 (compile-constant (text-of-quotation exp) target cont))
	((variable? exp)
	 (compile-variable-access exp env target cont))
	((assignment? exp)
	 (compile-assignment exp env target cont))
	((definition? exp)
	 (compile-definition exp env target cont))
	((lambda? exp)
	 (compile-lambda exp env target cont))
	((conditional? exp)
	 (compile-cond (clauses exp) env target cont))
	((no-args? exp)
	 (compile-no-args exp env target cont))
	((application? exp)
	 (compile-application exp env target cont))
	(else
	 (error "Unknown expression type -- compile" exp))))

(define (compile-constant constant target cont)
  (append-instruction-sequences
   (make-register-assignment target (make-constant constant))
   (continue-at cont)))

(define (compile-variable-access var env target cont)
  (append-instruction-sequences
   (make-register-assignment target (make-variable-access var env))
   (continue-at cont)))

(define (compile-assignment exp env target cont)
  (let ((target (if (null? target) 'val target)))
    (preserving 'env
		(compile-expression (assignment-value exp) env target 'next)
		(append-instruction-sequences
		 (make-variable-assignment (assignment-variable exp)
					   env
					   (make-fetch target))
		 (continue-at cont)))))

(define (compile-definition exp env target cont)
  (let ((target (if (null? target) 'val target)))
    (preserving 'env
     (compile-expression (definition-value exp)
			 (definition-env! (definition-variable exp)
			   env)
			 target
			 'next)
     (append-instruction-sequences
      (make-variable-definition (definition-variable exp)
				env
				(make-fetch target))
      (continue-at cont)))))

(define (compile-lambda exp env target cont)
  (let ((entry (generate-new-name 'entry)))
    (append-instruction-sequences
     (make-register-assignment target (make-procedure-maker entry))
     (if (eq? cont 'next)
	 (let ((after-lambda (generate-new-name 'after-lambda)))
	   (append-instruction-sequences
	    (continue-at after-lambda)
	    (append-instruction-sequences
	     (compile-lambda-body exp env entry)
	     (make-labeled-point after-lambda))))
	 (append-instruction-sequences
	  (continue-at cont)
	  (compile-lambda-body exp env entry)))))) 

(define (compile-lambda-body exp env entry)
  (safe-instruction-sequence
   (append-instruction-sequences
    (make-labeled-point entry)
    (append-instruction-sequences
     (make-environment-switch (lambda-parameters exp))
     (compile-sequence (lambda-body exp)
		       (extend-compile-time-env (lambda-parameters exp)
						env)
		       'val
		       'return)))))

(define (make-environment-switch formals)
  (append-instruction-sequences
   (make-register-assignment 'env
			     (make-env-ref (make-fetch 'fun)))
   (make-register-assignment 'env
			     (make-bindings-maker formals
						  (make-fetch 'argl)
						  (make-fetch 'env)))))


(define (compile-cond clauses env target cont)
  (if (eq? cont 'next)
      (let ((end-of-cond (generate-new-name 'cond-end)))
	(append-instruction-sequences
	 (compile-clauses clauses env target end-of-cond)
	 (make-labeled-point end-of-cond)))	;Output label
      (compile-clauses clauses env target cont)))

(define (compile-clauses clauses env target cont)
  (if (no-clauses? clauses)
      (continue-at cont)
      (let ((fc (first-clause clauses)))
        (if (else-clause? fc)
            (compile-sequence (action-sequence fc) env target cont)
	    (let ((ift (generate-new-name 'true-branch)))
	      (preserving 'env
	       (compile-expression (predicate fc) env 'val 'next)
	       (append-instruction-sequences
		(make-branch (make-fetch 'val) ift)
		(join-instruction-sequences
		 (compile-clauses (rest-clauses clauses) env target cont)
		 (append-instruction-sequences
		  (make-labeled-point ift)
		  (compile-sequence (action-sequence fc) env target cont))))))))))

(define (compile-sequence seq env target cont)
  (if (last-exp? seq)
      (compile-expression (first-exp seq) env target cont)
       (preserving 'env
		   (compile-expression (first-exp seq) env 'nil 'next)
		   (compile-sequence (rest-exps seq) env target cont))))


(define (compile-no-args app env target cont)
  (append-instruction-sequences
   (compile-expression (operator app) env 'fun 'next)
   (append-instruction-sequences
    (make-register-assignment 'argl (make-empty-arglist))
    (make-call target cont))))


(define (compile-application app env target cont)
  (preserving 'env
	      (compile-expression (operator app) env 'fun 'next)
	      (preserving 'fun
			  (compile-operands (operands app) env)
			  (make-call target cont))))

(define (compile-operands rands env)
  (let ((fo (compile-first-operand rands env)))
    (if (last-operand? rands)
	fo
	(preserving 'env
		    fo
		    (compile-rest-operands (rest-operands rands) env)))))

(define (compile-first-operand rands env)
  (append-instruction-sequences
   (compile-expression (first-operand rands) env 'val 'next)
   (make-register-assignment 'argl
			     (make-singleton-arglist (make-fetch 'val)))))

(define (compile-rest-operands rands env)
  (let ((no (compile-next-operand rands env)))
    (if (last-operand? rands)
	no
	(preserving 'env
		    no
		    (compile-rest-operands (rest-operands rands) env)))))

(define (compile-next-operand rands env)
  (preserving 'argl
	      (compile-expression (first-operand rands) env 'val 'next)
	      (make-register-assignment 'argl
		 (make-addition-to-arglist (make-fetch 'val)
					   (make-fetch 'argl)))))

(define (make-call target cont)
  (let ((cc (make-call-result-in-val cont)))
    (if (eq? target 'val)
	cc
	(append-instruction-sequences
	 cc
	 (make-register-assignment target (make-fetch 'val))))))

(define (make-call-result-in-val cont)
  (cond ((eq? cont 'return)
	 (make-transfer-to-procedure-applicator))
	((eq? cont 'next)
	 (let ((after-call (generate-new-name 'after-call)))
	   (append-instruction-sequences
	    (make-call-return-to after-call)
	    (make-labeled-point after-call))))
	(else
	 (make-call-return-to cont))))			;A label

(define (make-call-return-to retlabel)
  (append-instruction-sequences
   (append-instruction-sequences
    (make-register-assignment 'continue retlabel)
    (make-save 'continue))
   (make-transfer-to-procedure-applicator)))

(define (continue-at continuation)
  (cond ((eq? continuation 'return)
	 (append-instruction-sequences
	  (make-restore 'continue)
	  (make-goto-instruction (make-fetch 'continue))))
	((eq? continuation 'next)
	 (the-empty-instruction-sequence))
	(else
	 (make-goto-instruction continuation))))



(define (append-instruction-sequences s1 s2)
  (make-seq (set-union (needs-list s1)
		       (set-difference (needs-list s2)
				       (mung-list s1)))
	    (set-union (mung-list s1) (mung-list s2))
	    (append (statements s1) (statements s2))))

(define (preserving reg seq1 seq2)
  (if (and (memq reg (needs-list seq2))
	   (memq reg (mung-list seq1)))
      (append-instruction-sequences
       (make-seq (needs-list seq1)
		 (set-difference (mung-list seq1) (list reg))
		 (append (statements (make-save reg))
			 (statements seq1)
			 (statements (make-restore reg))))
       seq2)
      (append-instruction-sequences seq1 seq2)))

(define (join-instruction-sequences s1 s2)
  (make-seq (set-union (needs-list s1) (needs-list s2))
	    (set-union (mung-list s1) (mung-list s2))
	    (append (statements s1) (statements s2))))

(define (safe-instruction-sequence seq)
  (make-seq '() '() (statements seq)))

;;; Nothing above this line knows the format of
;;;  an "assembly-language" instruction.

(define (make-goto-instruction continuation)
  (make-instruction (needs-list continuation)
		    '()
		    (list 'goto (value-of continuation))))

(define (make-branch predicate if-true-label)
  (make-instruction (needs-list predicate)
		    '()
		    (list 'branch
			  (value-of predicate)
			  if-true-label)))

(define (make-transfer-to-procedure-applicator)
  (make-instruction '(fun argl) all '(goto apply-dispatch)))

(define (make-labeled-point label)
  (make-instruction '() '() label))

(define (make-register-assignment reg val)
  (cond ((not (null? reg))
	 (make-instruction (needs-list val)
			   (list reg)
			   (list 'assign reg (value-of val))))
	(else
	 (the-empty-instruction-sequence))))

(define (make-fetch reg)
  (make-value (list reg) (list 'fetch reg)))

(define (make-save reg)
  (make-instruction '() '() (list 'save reg)))

(define (make-restore reg)
  (make-instruction '() '() (list 'restore reg)))

(define (make-constant x)
  (make-value '() (list 'quote x)))

(define (make-variable-access var compilation-env)
  (make-value '(env)
	      (list 'lookup-variable-value
		    (list 'quote var)
		    (value-of (make-fetch 'env)))))

(define (make-variable-assignment var compilation-env val)
  (make-instruction (set-union '(env) (needs-list val))
		    '()
		    (list 'perform
			  (list 'set-variable-value!
				(list 'quote var)
				(value-of val)
				(value-of (make-fetch 'env))))))

(define (make-variable-definition var compilation-env val)
  (make-instruction (set-union '(env) (needs-list val))
		    '()
		    (list 'perform
			  (list 'define-variable!
				(list 'quote var)
				(value-of val)
				(value-of (make-fetch 'env))))))

(define (make-bindings-maker vars args env)
  (make-value (list (needs-list args) (needs-list env)) 
	      (list 'extend-environment
		    (list 'quote (reverse vars))
		    (value-of args)
		    (value-of env))))

(define (make-procedure-maker entry)
  (make-value '(env)
	      (list 'make-compiled-procedure
		    entry
		    (value-of (make-fetch 'env)))))

(define (make-env-ref fun)
  (make-value (needs-list fun)
	      (list 'env-of-compiled-procedure
		    (value-of fun))))

(define (make-empty-arglist)
  (make-value '() '()))

(define (make-singleton-arglist val)
  (make-value (needs-list val)
	      (list 'cons (value-of val) '())))

(define (make-addition-to-arglist val args)
  (make-value (set-union (needs-list val) (needs-list args))
	      (list 'cons (value-of val) (value-of args))))


;; From here on down is internal compiler data structure stuff:

(define (make-value needed-regs expression)
  (list needed-regs expression))

(define (needs-list value)
  (if (symbol? value)			; Label
      '()
      (car value)))

(define (value-of value)
  (if (symbol? value)
      value
      (cadr value)))

(define (make-instruction needs mungs code)
  (make-seq needs mungs (list code)))

(define (make-seq needs mungs seq)
  (list needs mungs seq))

(define (the-empty-instruction-sequence)
  (list '() '() '()))
  
;;;NEEDS-LIST already defined above.
(define (mung-list seq) (cadr seq))
(define (statements seq) (caddr seq))

(define (set-union x y)
  (cond ((null? x) y)
	((memq (car x) y) (set-union (cdr x) y))
	(else (cons (car x) (set-union (cdr x) y)))))

(define (set-difference x y)
  (cond ((null? x) '())
	((memq (car x) y)
	 (set-difference (cdr x) y))
	(else
	 (cons (car x)
	       (set-difference (cdr x) y)))))

(define (extend-compile-time-env frame env)
  (cons (reverse frame) env))   ;;note reversal to match interpreter's
                                ;;make-bindings 

(define (definition-env! var env)
  (if (and (not (null? env))
	   (not (memq var (car env))))
      (set!-car env (cons var env)))
  env)


(define (given-new-definition var env)
  (if (null? env)					;global?
      env						;no nothing.
      (cons (cons var (car env))			;add to top frame
	    (cdr env))))

(sequence
 (enable-language-features)
 (define generate-new-name
   (access generate-uninterned-symbol '()))
 (disable-language-features))

(define all '(env argl val fun continue))


;; Syntax extras

(define (lambda-parameters exp) (cadr exp))

(define (lambda-body exp) (cddr exp))
@end(programexample)
