371 lines
12 KiB
Scheme
371 lines
12 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/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")
|
|
|