SICP/ex-5_07-13.scm

(load "util.scm")
(load "misc/sicp-regsim.scm")

(display "\nex-5.7 - test-machines\n")

; We have already tested the machines in the previous exercises.

(display "[answered]\n")

; continue at 5.2.2 - the assembler

(display "\nex-5.8 - double-here\n")

(define (extract-labels text receive)
  (define (warn-if-label-exists label labels)
    (if (assoc label labels)
      (begin
        (display "Duplicated labels -- EXTRACT-LABELS ")
        (display label)
        (newline))))
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
             (warn-if-label-exists next-inst labels))
           (if (symbol? next-inst)
               (receive insts
                        (cons (make-label-entry next-inst
                                                insts)
                              labels))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(define double-here-machine
  (make-machine
    '(a)
    '()
    '(start
        (goto (label here))
      here
        (assign a (const 3))
        (goto (label there))
      here
        (assign a (const 4))
        (goto (label there))
      there)))

(start double-here-machine)
(assert (get-register-contents double-here-machine 'a) 3)

; The register contains 3 because the assembler jumps to the first label in the
; list.

(display "\nex-5.9 - strict-op\n")

(display "[done]\n")

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (if (or (register-exp? e) (constant-exp? e))
                  (make-primitive-exp e machine labels)
                  (error "Invalid operation argument -- MAKE-OPERATION-EXP" e)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

; The following instruction creates an error when analyzing the arguments for
; op. Previously it created the error during runtime.

; (define invalid-op-arg-machine
;   (make-machine
;     '(a)
;     (list (list '+ +))
;     '((assign a (op +) (label here) (const 1))
;       here)))

(display "\nex-5.10 - inc\n")

(define inc-reg-name cadr)

(define (make-inc inst machine labels operations pc)
  (let ((target (get-register machine (inc-reg-name inst))))
    (lambda ()
      (set-contents!
        target
        (+ (get-contents target) 1))
      (advance-pc pc))))

(define triple-inc-machine
  (make-machine
    '(a)
    ()
    '((inc a)
      (inc a)
      (inc a))))

(set-register-contents! triple-inc-machine 'a 8)
(start triple-inc-machine)
(assert (get-register-contents triple-inc-machine 'a) 11)

(display "\nex-5.11 - stack-behavior\n")

; a
(define fib-machine
  (make-machine
    '(n val continue)
    (list (list '< <) (list '- -) (list '= +) (list '+ +))
    '(controller
        (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)
        ;; set up to compute Fib(n - 2)
        (assign n (op -) (reg n) (const 2))
        (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 n)                        ; ex-5.11 - save one instruction
        (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
                (op +) (reg val) (reg n))
        (restore continue)
        (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)))

; We can replace ((assign n (reg val)) (restore val)) with (restore n) because
; we add up n and val anyway. It does not matter which is in which register.

(set-register-contents! fib-machine 'n 8)
(start fib-machine)
(display "a. ")
(assert (get-register-contents fib-machine 'val) 21)

; b.

; If we install the following stack procedure before the optimzed fib
; implementation above it will raise an error because we restore val into n.

(define stack-register car)
(define stack-content cadr)

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (list reg (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 ((stack-element (pop stack)))
        (if (not (eq? reg (stack-register stack-element)))
          (error "restore from different reg -- MAKE-RESTORE"
                 (reg 'name?)
                 ((stack-register stack-element) 'name?)))
      (set-contents! reg (stack-content stack-element))
      (advance-pc pc)))))

(display "b. [implemented]\n")


(display "c.\n")

(define (make-save inst machine stack pc)
  (let* ((reg-name (stack-inst-reg-name inst))
         (reg (get-register machine reg-name)))
    (lambda ()
      ((stack 'push) (get-contents reg) reg-name)
      (advance-pc pc))))

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

(define (make-stack)
  ;; stack that maintains a separate stack for each register internally
  (let ((stacks '()))
    (define (push x reg)
      (let ((s (assoc reg stacks)))
        (if s
          (begin
            (set-cdr! s (cons x (cdr s))))
          (begin
            (set! stacks (cons (cons reg (list x)) stacks))))))
    (define (pop reg)
      (let ((s (assoc reg stacks)))
        (if (not s)
          (error "stack does not exist -- POP" reg)
          (if (null? s)
              (error "Empty stack -- POP")
              (let ((top (cadr s)))
                (set-cdr! s (cddr s))
                top)))))
    (define (initialize)
      (set! stacks '())
      '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 stack-test-machine
  (make-machine
    '(a b c)
    '()
    '(controller
       (assign a (const 1))
       (assign b (const 2))
       (assign c (const 3))
       ; order doesn't matter
       (save a)
       (save c)
       (save b)
       (assign a (const 4))
       (assign b (const 5))
       (assign c (const 6))
       (save b)
       (save a)
       (save c)
       (assign a (const 0))
       (assign b (const 0))
       (assign c (const 0))
       (restore a)
       (restore a)
       (restore b)
       (restore c)
       stack-test-machine-done)))

(start stack-test-machine)
(assert (get-register-contents stack-test-machine 'a) 1)
(assert (get-register-contents stack-test-machine 'b) 5)
(assert (get-register-contents stack-test-machine 'c) 6)

(display "\nex-5.12 - machine-analyzer\n")

; I don't want to change the assembler. That's why I implement the analyzer
; seperately.

(define (insert x xs)
  (cond
    ((null? xs) (list x))
    ((eq? (car x) (car (car xs))) (cons x xs))
    (else (cons (car xs) (insert x (cdr xs))))))

(define (analyze-controller controller-text)
  (let ((insts (filter pair? controller-text))
        (unique-insts '())
        (entry-regs '())
        (stack-regs '())
        (sources '()))

    (define (add-unique-inst inst)
      (if (not (member inst unique-insts))
        (set! unique-insts (insert inst unique-insts))))

    (define (add-entry-point inst)
      (if (and (eq? (car inst) 'goto)
               (register-exp? (goto-dest inst)))
        (let ((reg-name (register-exp-reg (goto-dest inst))))
          (if (not (member reg-name entry-regs))
            (set! entry-regs (insert reg-name entry-regs))))))

    (define (add-stack-reg inst)
      (if (or (eq? (car inst) 'save) (eq? (car inst) 'restore))
        (let ((reg-name (stack-inst-reg-name inst)))
          (if (not (member reg-name stack-regs))
            (set! stack-regs (cons reg-name stack-regs))))))

    (define (add-source inst)
      (if (eq? (car inst) 'assign)
        (let ((source (list (assign-reg-name inst)
                            (assign-value-exp inst))))
          (if (not (member source sources))
            (set! sources (insert source sources))))))

    (map add-unique-inst insts)
    (map add-entry-point insts)
    (map add-stack-reg insts)
    (map add-source insts)

    ;; Code to display the analyzer-results
    ; (define (display-bullet b)
    ;   (display "- ") (display b) (newline))
    ; (display "unique-insts:\n")
    ; (map display-bullet unique-insts)
    ; (newline)
    ; (display "entry-regs:\n")
    ; (map display-bullet entry-regs)
    ; (newline)
    ; (display "stack-regs:\n")
    ; (map display-bullet stack-regs)
    ; (newline)
    ; (display "sources:\n")
    ; (map display-bullet sources)
    ; (newline)

    (list unique-insts entry-regs stack-regs sources)))

(analyze-controller
  '((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)
      ;; set up to compute Fib(n - 2)
      (assign n (op -) (reg n) (const 2))
      (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 n)                        ; ex-5.11 - save one instruction
      (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
              (op +) (reg val) (reg n))
      (restore continue)
      (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))

(display "[ok]\n")

(display "\nex-5.13 - dynamic-registers\n")

(define (lookup-register name)
  (let ((val (assoc name register-table)))
    (if val
        (cadr val)
        (begin  ;; Allocate register dynamically if needed
          (allocate-register name)
          (lookup-register name)))))

(display "[ok]\n")