Exercise 5.12.  The simulator can be used to help determine the data 
paths required for implementing a machine with a given controller. 
Extend the assembler to store the following information in the machine 
model:

    * a list of all instructions, with duplicates removed, sorted by 
      instruction type (assign, goto, and so on);

    * a list (without duplicates) of the registers used to hold entry 
      points (these are the registers referenced by goto instructions);

    * a list (without duplicates) of the registers that are saved or 
      restored;

    * for each register, a list (without duplicates) of the sources from 
      which it is assigned (for example, the sources for register val in 
      the factorial machine of figure 5.11 are (const 1) and ((op *) 
      (reg n) (reg val))). 

Extend the message-passing interface to the machine to provide access to 
this new information. To test your analyzer, define the Fibonacci 
machine from figure 5.12 and examine the lists you constructed.

————————————————————————————————————————————————————————————————————————

- I did not bother removing duplicates from the instruction list.
- I put the code in the simulated machine (in make-machine) though it 
  should be elsewhere.

See 5.12.scm for the modified simulator, and 5.12-test.scm for the test 
program, which loads the Fib machine and generates the following output:

** instructions by type **
restore
(restore continue)
(restore val)
(restore continue)
(restore n)

goto
(goto (reg continue))
(goto (reg continue))
(goto (label fib-loop))
(goto (label fib-loop))

save
(save val)
(save continue)
(save n)
(save continue)

branch
(branch (label immediate-answer))

test
(test (op <) (reg n) (const 2))

assign
(assign val (reg n))
(assign val (op +) (reg val) (reg n))
(assign n (reg val))
(assign continue (label afterfib-n-2))
(assign n (op -) (reg n) (const 2))
(assign n (op -) (reg n) (const 1))
(assign continue (label afterfib-n-1))
(assign continue (label fib-done))

** registers used with goto **
(continue)

** saved or restored registers **
(val n continue)

** assignment sources by register **
val
((reg n))
((op +) (reg val) (reg n))

n
((reg val))
((op -) (reg n) (const 2))
((op -) (reg n) (const 1))

continue
((label afterfib-n-2))
((label afterfib-n-1))
((label fib-done))

The changes made to the simulator:

--- ch5-regsim.scm	2010-03-16 02:00:34.000000000 -0600
+++ 5.12.scm	2010-03-14 15:46:43.000000000 -0600
@@ -99,7 +99,11 @@
   (let ((pc (make-register 'pc))
         (flag (make-register 'flag))
         (stack (make-stack))
-        (the-instruction-sequence '()))
+        (the-instruction-sequence '())
+        (instructions-by-type '())
+        (entry-point-registers '())
+        (saved-registers '())
+        (register-assignment-sources '()))
     (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () (stack 'initialize)))
@@ -116,6 +120,28 @@
                   (cons (list name (make-register name))
                         register-table)))
         'register-allocated)
+      (define (record-instruction instr)
+        (let ((type (car (instruction-text instr)))
+              (text (instruction-text instr)))
+          (let ((group (assoc type instructions-by-type)))
+            (if group
+                (set-cdr! group (cons instr (cdr group)))
+                (set! instructions-by-type (cons (list type instr) instructions-by-type))))
+          (cond ((and (eq? type 'goto)
+                      (eq? (caadr text) 'reg)
+                      (not (memq (cadadr text) entry-point-registers)))
+                 (set! entry-point-registers (cons (cadadr text) entry-point-registers)))
+                ((and (or (eq? type 'save)
+                          (eq? type 'restore))
+                      (not (memq (cadr text) saved-registers)))
+                 (set! saved-registers (cons (cadr text) saved-registers)))
+                ((eq? type 'assign)
+                 (let ((register (cadr text))
+                       (source (cddr text)))
+                   (let ((group (assoc register register-assignment-sources)))
+                     (if group
+                         (if (not (member source (cdr group))) (set-cdr! group (cons source (cdr group))))
+                         (set! register-assignment-sources (cons (list register source) register-assignment-sources)))))))))
       (define (lookup-register name)
         (let ((val (assoc name register-table)))
           (if val
@@ -140,6 +166,11 @@
                (lambda (ops) (set! the-ops (append the-ops ops))))
               ((eq? message 'stack) stack)
               ((eq? message 'operations) the-ops)
+              ((eq? message 'instructions-by-type) instructions-by-type)
+              ((eq? message 'record-instruction) record-instruction)
+              ((eq? message 'entry-point-registers) entry-point-registers)
+              ((eq? message 'saved-registers) saved-registers)
+              ((eq? message 'register-assignment-sources) register-assignment-sources)
               (else (error "Unknown request -- MACHINE" message))))
       dispatch)))
 
@@ -189,7 +220,8 @@
         inst
         (make-execution-procedure
          (instruction-text inst) labels machine
-         pc flag stack ops)))
+         pc flag stack ops))
+       ((machine 'record-instruction) inst))
      insts)))
 
 (define (make-instruction text)