Register_Machine_Monitor.scm

;;;~5.19


(define (tagged-list? lst tag)
  (eq? (car lst) tag))
(define (make-machine trace? register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    (if trace?
	(machine 'trace-on)
	(machine 'trace-off))
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))
(define (make-register name)
  (let ((contents '*unassigned*)
	(trace? #f))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value)
	       (if trace?
		   (display (format "~s:~s->~s~%" name contents value)))
	       (set! contents value)))
	    ((eq? message 'trace)
	     (lambda (value) (set! trace? value)))
            (else
             (errorf 'register "Unknown request : ~s" message))))
    dispatch))
(define (get-contents register)
  (register 'get))
(define (set-contents! register value)
  ((register 'set) value))
(define (trace-register! register bool)
  ((register 'trace) bool))
(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))
(define (pop stack)
  (stack 'pop))
(define (push stack value)
  ((stack 'push) value))
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
	(opcnt (make-register 'opcnt));5.15
	(trace? (make-register 'trace?));5.16
        (stack (make-stack))
	(breakpts '())
        (the-instruction-sequence '())
	(labels '())
	(proceed? #f))
    (let ((the-ops
           (list (list 'initialize-stack
            (lambda () (stack 'initialize)))
      (list 'print-stack-statistics
            (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag)
		 (list 'opcnt opcnt) (list 'trace? trace?))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (errorf 'allocate-register "Multiply defined register: ~s" 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)
              (errorf 'lookup-register "Unknown register: ~s" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
	      (if (memq (caar insts) breakpts)
		  (if proceed?
		      (begin
			(set! proceed? #f)
			((instruction-execution-proc (car insts)))
			(execute))
		      'paused)
		  (begin
                    ((instruction-execution-proc (car insts)))
                    (execute))))))
      (define (find label labels)
	(if (eq? label (caar labels))
	    (cdar labels)
	    (find label (cdr labels))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
	       (set-contents! opcnt 0)
               (execute))
	      ((eq? message 'proceed)
	       (set! proceed? #t)
	       (execute))
	      ((eq? message 'set-breakpoint)
	       (lambda (label n)
		 (set! breakpts (cons (car (list-ref
					    (find label labels)
					    (- n 1)))
				      breakpts))))
	      ((eq? message 'cancel-breakpoint)
	       (lambda (label n)
		 (set-car! (memq
			    (car (list-ref (find label labels) (- n 1)))
			    breakpts)
			   #f)))
	      ((eq? message 'cancel-all-breakpoints)
	       (set! breakpts '()))
              ((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 'set-labels!)
	       (lambda (lbls) (set! labels lbls)))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
	      ((eq? message 'trace-off)(set-contents! trace? #f))
	      ((eq? message 'trace-on) (set-contents! trace? #t))
	      ((eq? message 'register-trace)
	       (lambda (reg bool) (trace-register! reg bool)))
              (else (errorf 'Machine "Unknown request: ~s" message))))
      dispatch)))
(define (start machine)
  (machine 'start))
(define (set-breakpoint machine label n)
  ((machine 'set-breakpoint) label n))
(define (cancel-breakpoint machine label n)
  ((machine 'cancel-breakpoint) label n))
(define (cancel-all-breakpoints machine)
  (machine 'cancel-all-breakpoints))
(define (proceed-machine machine)
  (machine 'proceed))
(define (set-register-trace! machine register-name bool) ;5.18
  ((machine 'register-trace) (get-register machine register-name) bool))
(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))
(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      insts)))
(define (maybe-label inst)
  (if (and (pair? inst) (eq? 'label (car inst)))
      (cadr inst) ; (label smth) -> smth
      inst))
(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
       (lambda (insts labels)
         (let ((next-inst (maybe-label (car text))))
           (if (symbol? next-inst)
	       (if (memq next-inst (map car labels))
		   (errorf 'extract-labels "Duplicate Label : ~s"
			   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))
  ((machine 'set-labels!) labels))
(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)
        (errorf 'lookup-label "Undefined label: ~s" label-name))))
(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  (define (make-normal-proc)
    (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 (errorf 'make-execution-procedure "Unknown instruction type: ~s" inst))))
  (let ((trace? (get-register-contents machine 'trace?))
	(proc (make-normal-proc)))
    (if trace?
	(lambda ()
	  (display (preceding-label inst labels))
	  (newline)
	  (display inst)
	  (newline)
	  (proc))
	proc)))
(define (preceding-label inst labels)
  (if (and
       (not (null? labels))
       (memq inst (map car (cdar labels))))
      (let ((next-result (preceding-label inst (cdr labels))))
	(if (eq? next-result 'none)
	    (caar labels)
	    next-result))
      'none))
(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
	(let ((opcnt (get-register machine 'opcnt)))
	  (set-contents! opcnt (+ (get-contents opcnt) 1)))
        (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))))
(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 ()
	    (let ((opcnt (get-register machine 'opcnt)))
	      (set-contents! opcnt (+ (get-contents opcnt) 1)))
            (set-contents! flag (condition-proc))
            (advance-pc pc)))
        (errorf 'make-test "Bad TEST instruction: ~s" 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 ()
	    (let ((opcnt (get-register machine 'opcnt)))
	      (set-contents! opcnt (+ (get-contents opcnt) 1)))
            (if (get-contents flag)
                (set-contents! pc insts)
                (advance-pc pc))))
        (errorf 'make-branch "Bad BRANCH instruction: ~s" 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 (errorf 'make-goto "Bad GOTO instruction: ~s"
                       inst)))))
(define (goto-dest goto-instruction)
  (cadr goto-instruction))
(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (let ((opcnt (get-register machine 'opcnt)))
	(set-contents! opcnt (+ (get-contents opcnt) 1)))
      (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 ()
      (let ((opcnt (get-register machine 'opcnt)))
	(set-contents! opcnt (+ (get-contents opcnt) 1)))
      (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 ()
	    (let ((opcnt (get-register machine 'opcnt)))
	      (set-contents! opcnt (+ (get-contents opcnt) 1)))
            (action-proc)
            (advance-pc pc)))
        (errorf 'make-perform "Bad PERFORM instruction: ~s" inst))))
(define (perform-action inst) (cdr inst))
(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
         (errorf 'make-primitive-exp "Unknown expression type: ~s" 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)
  (if #f;(memq 'label (map car exp)) ;;;MODDED
   (errorf 'make-operation-exp "Label cannot be used in ops ~% ~s" exp)
   (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)
        (errorf 'lookup-prim "Unknown operation: ~s" symbol))))


(define expt-iter-machine
  (make-machine
   '(n b prod)
   (list (list '= =) (list '- -) (list '* *))
   '((perform (op initialize-stack))
     (assign prod (const 1))
     exp-loop
     (test (op =) (reg n) (const 0))
     (branch (label end-expt))
     (assign n (op -) (reg n) (const 1))
     (assign prod (op *) (reg prod) (reg b))
     (goto (label exp-loop))
     end-expt
     (perform (op print-stack-statistics)))))
(set-register-contents! expt-iter-machine 'n 3)
(set-register-contents! expt-iter-machine 'b 5)
(start expt-iter-machine)
(get-register-contents expt-iter-machine 'prod)

(define fib-m
  (make-machine #f
   '(n continue val)
   (list (list '= =) (list '- -) (list '+ +) (list '< <))
   '(controller
     (perform (op initialize-stack))
   (assign continue (label fib-done))
 fib-loop
   (test (op <) (reg n) (const 2))
   (branch (label immediate-answer))
   ;; set up to compute Fib(n - 1)
   (save continue)
   (assign continue (label afterfib-n-1))
   (save n)                           ; save old value of n
   (assign n (op -) (reg n) (const 1)); clobber n to n - 1
   (goto (label fib-loop))            ; perform recursive call
 afterfib-n-1                         ; upon return, val contains Fib(n - 1)
   (restore n)
   (restore continue)
   ;; set up to compute Fib(n - 2)
   (assign n (op -) (reg n) (const 2))
   (save continue)
   (assign continue (label afterfib-n-2))
   (save val)                         ; save Fib(n - 1)
   (goto (label fib-loop))
 afterfib-n-2                         ; upon return, val contains Fib(n - 2)
   (assign n (reg val))               ; n now contains Fib(n - 2)
   (restore val)                      ; val now contains Fib(n - 1)
   (restore continue)
   (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
           (op +) (reg val) (reg n)) 
   (goto (reg continue))              ; return to caller, answer is in val
 immediate-answer
   (assign val (reg n))               ; base case:  Fib(n) = n
   (goto (reg continue))
   fib-done
   (perform (op print-stack-statistics)))))
    

(define expt-iter-machine
  (make-machine #f
   '(n b prod)
   (list (list '= =) (list '- -) (list '* *))
   '((perform (op initialize-stack))
     (assign prod (const 1))
     exp-loop
     (test (op =) (reg n) (const 0))
     (branch (label end-expt))
     (assign n (op -) (reg n) (const 1))
     (assign prod (op *) (reg prod) (reg b))
     (goto (label exp-loop))
     end-expt
     (perform (op print-stack-statistics)))))
(set-register-contents! expt-iter-machine 'n 20)
(set-register-trace! expt-iter-machine 'n #t)
(set-register-contents! expt-iter-machine 'b 2)
(set-breakpoint expt-iter-machine 'exp-loop 1)
(start expt-iter-machine)
(get-register-contents expt-iter-machine 'opcnt)
(get-register-contents expt-iter-machine 'prod)

(proceed-machine expt-iter-machine)
(cancel-breakpoint expt-iter-machine 'exp-loop 1)
(proceed-machine expt-iter-machine)
(get-register-contents expt-iter-machine 'opcnt)
(get-register-contents expt-iter-machine 'prod)