Implement 5.12

2021-03-28 12:14:57 -04:00
parent 3f95e84e84
commit 284ccb26ad
2 changed files with 104 additions and 2 deletions
--- a/ex-5_07-13.scm
+++ b/ex-5_07-13.scm
@@ -0,0 +1,362 @@
+(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")
+;; (load "misc/sicp-regsim.scm")
+
+(display "TBD!\n")