#+TITLE: 5.2 - A Register-Machine Simulator
#+STARTUP: indent
#+OPTIONS: num:nil
#+PROPERTY: header-args:scheme :tangle yes

#+name: gcd-machine
#+BEGIN_SRC scheme :tangle no
  (define gcd-machine
    (make-machine
     '(a b t)
     (list (list 'rem remainder) (list '= =))
     '(test-b
       (test (op =) (reg b) (const 0))
       (branch (label gcd-done))
       (assign t (op rem) (reg a) (reg b))
       (assign a (reg b))
       (assign b (reg t))
       (goto (label test-b))
       gcd-done)))
#+END_SRC

* COMMENT Set up source file
#+BEGIN_SRC scheme :tangle yes
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; 5.2 - A Register-Machine Simulator
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (tagged-list? exp tag)
    (if (pair? exp)
        (eq? (car exp) tag)
        false))

#+END_SRC
* The Machine Model
#+BEGIN_SRC scheme
  (define (make-machine register-names 
                        ops 
                        controller-text)
    (let ((machine (make-new-machine)))
      (for-each (lambda (register-name)
                  ((machine 'allocate-register) 
                   register-name))
                register-names)
      ((machine 'install-operations) ops)
      ((machine 'install-instruction-sequence)
       (assemble controller-text machine))
      machine))
#+END_SRC

** Registers
#+BEGIN_SRC scheme
  (define (make-register name)
    (let ((contents '*unassigned*))
      (define (dispatch message)
        (cond ((eq? message 'get) contents)
              ((eq? message 'set)
               (lambda (value) 
                 (set! contents value)))
              (else
               (error "Unknown request: 
                       REGISTER"
                      message))))
      dispatch))

  (define (get-contents register)
    (register 'get))

  (define (set-contents! register value)
    ((register 'set) value))
#+END_SRC

** The stack
#+BEGIN_SRC scheme
  (define (make-stack)
    (let ((s '()))
      (define (push x)
        (set! s (cons x s)))
      (define (pop)
        (if (null? s)
            (error "Empty stack: POP")
            (let ((top (car s)))
              (set! s (cdr s))
              top)))
      (define (initialize)
        (set! s '())
        'done)
      (define (dispatch message)
        (cond ((eq? message 'push) push)
              ((eq? message 'pop) (pop))
              ((eq? message 'initialize) 
               (initialize))
              (else 
               (error "Unknown request: STACK"
                      message))))
      dispatch))

  (define (pop stack) (stack 'pop))
  (define (push stack value)
    ((stack 'push) value))
#+END_SRC

** The basic machine
#+BEGIN_SRC scheme
  (define (make-new-machine)
    (let ((pc (make-register 'pc))
          (flag (make-register 'flag))
          (stack (make-stack))
          (the-instruction-sequence '()))
      (let ((the-ops
             (list 
              (list 'initialize-stack
                    (lambda () 
                      (stack 'initialize)))))
            (register-table
             (list (list 'pc pc) 
                   (list 'flag flag))))
        (define (allocate-register name)
          (if (assoc name register-table)
              (error 
               "Multiply defined register: " 
               name)
              (set! register-table
                    (cons 
                     (list name 
                           (make-register name))
                     register-table)))
          'register-allocated)
        (define (lookup-register name)
          (let ((val 
                 (assoc name register-table)))
            (if val
                (cadr val)
                (error "Unknown register:" 
                       name))))
        (define (execute)
          (let ((insts (get-contents pc)))
            (if (null? insts)
                'done
                (begin
                  ((instruction-execution-proc 
                    (car insts)))
                  (execute)))))
        (define (dispatch message)
          (cond ((eq? message 'start)
                 (set-contents! 
                  pc
                  the-instruction-sequence)
                 (execute))
                ((eq? 
                  message 
                  'install-instruction-sequence)
                 (lambda (seq) 
                   (set! 
                    the-instruction-sequence 
                    seq)))
                ((eq? message 
                      'allocate-register) 
                 allocate-register)
                ((eq? message 'get-register) 
                 lookup-register)
                ((eq? message 
                      'install-operations)
                 (lambda (ops) 
                   (set! the-ops 
                         (append the-ops ops))))
                ((eq? message 'stack) stack)
                ((eq? message 'operations) 
                 the-ops)
                (else (error "Unknown request: 
                              MACHINE"
                             message))))
        dispatch)))

  (define (start machine)
    (machine 'start))

  (define (get-register-contents 
           machine register-name)
    (get-contents 
     (get-register machine register-name)))

  (define (set-register-contents! 
           machine register-name value)
    (set-contents! 
     (get-register machine register-name) 
     value)
    'done)

  (define (get-register machine reg-name)
    ((machine 'get-register) reg-name))
#+END_SRC

* The Assembler
#+BEGIN_SRC scheme
  (define (assemble controller-text machine)
    (extract-labels controller-text
                    (lambda (insts labels)
                      (update-insts! insts labels machine)
                      insts)))

  (define (extract-labels text receive)
    (if (null? text)
        (receive '() '())
        (extract-labels 
         (cdr text)
         (lambda (insts labels)
           (let ((next-inst (car text)))
             (if (symbol? next-inst)
                 (receive 
                  insts
                  (cons 
                   (make-label-entry 
                    next-inst
                    insts)
                   labels))
                 (receive 
                  (cons (make-instruction 
                         next-inst)
                        insts)
                  labels)))))))

  (define (update-insts! insts labels machine)
    (let ((pc (get-register machine 'pc))
          (flag (get-register machine 'flag))
          (stack (machine 'stack))
          (ops (machine 'operations)))
      (for-each
       (lambda (inst)
         (set-instruction-execution-proc!
          inst
          (make-execution-procedure
           (instruction-text inst) 
           labels
           machine
           pc
           flag
           stack
           ops)))
       insts)))

  (define (make-instruction text)
    (cons text '()))
  (define (instruction-text inst) (car inst))
  (define (instruction-execution-proc inst)
    (cdr inst))
  (define (set-instruction-execution-proc!
           inst
           proc)
    (set-cdr! inst proc))

  (define (make-label-entry label-name insts)
    (cons label-name insts))

  (define (lookup-label labels label-name)
    (let ((val (assoc label-name labels)))
      (if val
          (cdr val)
          (error "Undefined label: ASSEMBLE" 
                 label-name))))
#+END_SRC

** Exercise 5.8
The following register-machine code is ambiguous,
because the label `here' is defined more than once:

#+BEGIN_EXAMPLE
  start
    (goto (label here))
  here
    (assign a (const 3))
    (goto (label there))
  here
    (assign a (const 4))
    (goto (label there))
  there
#+END_EXAMPLE

With the simulator as written, what will the contents of register `a'
be when control reaches `there'?  Modify the `extract-labels'
procedure so that the assembler will signal an error if the same label
name is used to indicate two different locations.

----------------------------------------------------------------------

The contents of register =a= will always be =3=. Labels are looked up
using =assoc=, which will always return the first match in the lookup
table.

#+BEGIN_SRC scheme
  (define (extract-labels text receive)
    (if (null? text)
        (receive '() '())
        (extract-labels 
         (cdr text)
         (lambda (insts labels)
           (let ((next-inst (car text)))
             (if (symbol? next-inst)
                 (if (assoc next-inst labels)
                     (error "Duplicate label. AVENGERS, ASSEMBLE!")
                     (receive 
                      insts
                      (cons 
                       (make-label-entry 
                        next-inst
                        insts)
                       labels)))
                 (receive 
                  (cons (make-instruction 
                         next-inst)
                        insts)
                  labels)))))))
#+END_SRC
* Generating Execution Procedures for Instructions
#+BEGIN_SRC scheme
  (define (make-execution-procedure 
           inst labels machine pc flag stack ops)
    (cond ((eq? (car inst) 'assign)
           (make-assign 
            inst machine labels ops pc))
          ((eq? (car inst) 'test)
           (make-test 
            inst machine labels ops flag pc))
          ((eq? (car inst) 'branch)
           (make-branch 
            inst machine labels flag pc))
          ((eq? (car inst) 'goto)
           (make-goto inst machine labels pc))
          ((eq? (car inst) 'save)
           (make-save inst machine stack pc))
          ((eq? (car inst) 'restore)
           (make-restore inst machine stack pc))
          ((eq? (car inst) 'perform)
           (make-perform
            inst machine labels ops pc))
          (else (error "Unknown instruction 
                        type: ASSEMBLE"
                       inst))))
#+END_SRC

** =Assign= instructions
#+BEGIN_SRC scheme
  (define (make-assign 
           inst machine labels operations pc)
    (let ((target 
           (get-register 
            machine 
            (assign-reg-name inst)))
          (value-exp (assign-value-exp inst)))
      (let ((value-proc
             (if (operation-exp? value-exp)
                 (make-operation-exp
                  value-exp 
                  machine
                  labels
                  operations)
                 (make-primitive-exp
                  (car value-exp)
                  machine
                  labels))))
        (lambda ()   ; execution procedure
                     ; for assign
          (set-contents! target (value-proc))
          (advance-pc pc)))))

  (define (assign-reg-name assign-instruction)
    (cadr assign-instruction))
  (define (assign-value-exp assign-instruction)
    (cddr assign-instruction))

  (define (advance-pc pc)
    (set-contents! pc (cdr (get-contents pc))))
#+END_SRC

** =Test=, =branch= and =goto= instructions
#+BEGIN_SRC scheme
  (define 
    (make-test 
     inst machine labels operations flag pc)
    (let ((condition (test-condition inst)))
      (if (operation-exp? condition)
          (let ((condition-proc
                 (make-operation-exp
                  condition 
                  machine
                  labels
                  operations)))
            (lambda () 
              (set-contents! 
               flag (condition-proc))
              (advance-pc pc)))
          (error "Bad TEST instruction: 
                  ASSEMBLE" inst))))

  (define (test-condition test-instruction)
    (cdr test-instruction))

  (define 
    (make-branch 
     inst machine labels flag pc)
    (let ((dest (branch-dest inst)))
      (if (label-exp? dest)
          (let ((insts
                 (lookup-label 
                  labels 
                  (label-exp-label dest))))
            (lambda ()
              (if (get-contents flag)
                  (set-contents! pc insts)
                  (advance-pc pc))))
          (error "Bad BRANCH instruction: 
                  ASSEMBLE"
                 inst))))

  (define (branch-dest branch-instruction)
    (cadr branch-instruction))

  (define (make-goto inst machine labels pc)
    (let ((dest (goto-dest inst)))
      (cond ((label-exp? dest)
             (let ((insts
                    (lookup-label 
                     labels
                     (label-exp-label dest))))
               (lambda () 
                 (set-contents! pc insts))))
            ((register-exp? dest)
             (let ((reg
                    (get-register 
                     machine
                     (register-exp-reg dest))))
               (lambda ()
                 (set-contents! 
                  pc
                  (get-contents reg)))))
            (else (error "Bad GOTO instruction: 
                          ASSEMBLE"
                         inst)))))

  (define (goto-dest goto-instruction)
    (cadr goto-instruction))
#+END_SRC

** Other instructions
#+BEGIN_SRC scheme
  (define (make-save inst machine stack pc)
    (let ((reg (get-register 
                machine
                (stack-inst-reg-name inst))))
      (lambda ()
        (push stack (get-contents reg))
        (advance-pc pc))))

  (define (make-restore inst machine stack pc)
    (let ((reg (get-register
                machine
                (stack-inst-reg-name inst))))
      (lambda ()
        (set-contents! reg (pop stack))
        (advance-pc pc))))

  (define (stack-inst-reg-name 
           stack-instruction)
    (cadr stack-instruction))

  (define (make-perform 
           inst machine labels operations pc)
    (let ((action (perform-action inst)))
      (if (operation-exp? action)
          (let ((action-proc
                 (make-operation-exp
                  action
                  machine
                  labels
                  operations)))
            (lambda ()
              (action-proc)
              (advance-pc pc)))
          (error "Bad PERFORM instruction: 
                  ASSEMBLE"
                 inst))))

  (define (perform-action inst) (cdr inst))
#+END_SRC

** Execution procedures for subexpressions
#+BEGIN_SRC scheme
  (define (make-primitive-exp exp machine labels)
    (cond ((constant-exp? exp)
           (let ((c (constant-exp-value exp)))
             (lambda () c)))
          ((label-exp? exp)
           (let ((insts
                  (lookup-label 
                   labels
                   (label-exp-label exp))))
             (lambda () insts)))
          ((register-exp? exp)
           (let ((r (get-register
                     machine
                     (register-exp-reg exp))))
             (lambda () (get-contents r))))
          (else (error "Unknown expression type: 
                        ASSEMBLE"
                       exp))))

  (define (register-exp? exp)
    (tagged-list? exp 'reg))
  (define (register-exp-reg exp)
    (cadr exp))
  (define (constant-exp? exp)
    (tagged-list? exp 'const))
  (define (constant-exp-value exp)
    (cadr exp))
  (define (label-exp? exp)
    (tagged-list? exp 'label))
  (define (label-exp-label exp) 
    (cadr exp))

  (define (make-operation-exp
           exp machine labels operations)
    (let ((op (lookup-prim 
               (operation-exp-op exp)
               operations))
          (aprocs
           (map (lambda (e)
                  (make-primitive-exp 
                   e machine labels))
                (operation-exp-operands exp))))
      (lambda () (apply op (map (lambda (p) (p))
                                aprocs)))))

  (define (operation-exp? exp)
    (and (pair? exp)
         (tagged-list? (car exp) 'op)))
  (define (operation-exp-op operation-exp)
    (cadr (car operation-exp)))
  (define (operation-exp-operands operation-exp)
    (cdr operation-exp))

  (define (lookup-prim symbol operations)
    (let ((val (assoc symbol operations)))
      (if val
          (cadr val)
          (error "Unknown operation: ASSEMBLE"
                 symbol))))
#+END_SRC

* Monitoring Machine Performance
#+BEGIN_SRC scheme
  (define (make-stack)
    (let ((s '())
          (number-pushes 0)
          (max-depth 0)
          (current-depth 0))
      (define (push x)
        (set! s (cons x s))
        (set! number-pushes (+ 1 number-pushes))
        (set! current-depth (+ 1 current-depth))
        (set! max-depth 
              (max current-depth max-depth)))
      (define (pop)
        (if (null? s)
            (error "Empty stack: POP")
            (let ((top (car s)))
              (set! s (cdr s))
              (set! current-depth
                    (- current-depth 1))
              top)))
      (define (initialize)
        (set! s '())
        (set! number-pushes 0)
        (set! max-depth 0)
        (set! current-depth 0)
        'done)

      (define (print-statistics)
        (newline)
        (display (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))
#+END_SRC