diff options
| -rw-r--r-- | chap5/part1.rkt | 2 | ||||
| -rw-r--r-- | chap5/part2.rkt | 516 |
2 files changed, 517 insertions, 1 deletions
diff --git a/chap5/part1.rkt b/chap5/part1.rkt index e878ace..394c3d0 100644 --- a/chap5/part1.rkt +++ b/chap5/part1.rkt @@ -317,7 +317,7 @@ (define expt-controller '(controller - (assign (continue (label expt-done))) + (assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) (branch (label base-case)) diff --git a/chap5/part2.rkt b/chap5/part2.rkt new file mode 100644 index 0000000..1f4a551 --- /dev/null +++ b/chap5/part2.rkt @@ -0,0 +1,516 @@ +#lang sicp +(#%require (only racket/base print-as-expression print-mpair-curly-braces)) +(print-as-expression #f) +(print-mpair-curly-braces #f) + +;; Chapter 5 +;; Computing with Register Machines + +;; 5.2 +;; A Register-Machine Simulator + +#| 5.7 |# + +(#%provide expt-controller) +(define expt-controller + '(controller + (assign continue (label expt-done)) + expt-loop + (test (op =) (reg n) (const 0)) + (branch (label base-case)) + (save continue) + (save n) + (assign n (op -) (reg n) (const 1)) + (assign continue (label after-expt)) + (goto (label expt-loop)) + after-expt + (restore n) + (restore continue) + (assign val (op *) (reg b) (reg val)) + (goto (reg continue)) + base-case + (assign val (const 1)) + (goto (reg continue)) + expt-done)) + +(#%provide expt-iter-controller) +(define expt-iter-controller + '(controller + (assign counter (reg n)) + (assign product (const 1)) + test-counter + (test (op =) (reg counter) (const 0)) + (branch (label expt-done)) + (assign counter (op -) (reg counter) (const 1)) + (assign product (op *) (reg b) (reg product)) + (goto (label test-counter)) + expt-done)) + +(#%provide test-expt) +(define (test-expt) + (let + ((expt-machine + (make-machine + '(n b val continue) + (list (list '- -) (list '* *) (list '= =)) + expt-controller))) + (set-register-contents! expt-machine 'b 5) + (set-register-contents! expt-machine 'n 4) + (start expt-machine) + (get-register-contents expt-machine 'val))) + +(#%provide test-expt-iter) +(define (test-expt-iter) + (let + ((expt-machine + (make-machine + '(n b product counter) + (list (list '- -) (list '* *) (list '= =)) + expt-iter-controller))) + (set-register-contents! expt-machine 'b 10) + (set-register-contents! expt-machine 'n 4) + (start expt-machine) + (get-register-contents expt-machine 'product))) + +;; The Machine Model + +(#%provide make-register) +(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)) + +(#%provide get-contents) +(define (get-contents register) + (register 'get)) + +(#%provide set-contents!) +(define (set-contents! register value) + ((register 'set) value)) + +(#%provide make-stack) +(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)) + +(#%provide pop) +(define (pop stack) + (stack 'pop)) + +(#%provide push) +(define (push stack value) + ((stack 'push) value)) + +(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)) + +(#%provide make-new-machine) +(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))) + +(#%provide start) +(define (start machine) + (machine 'start)) + +(define (get-register machine reg-name) + ((machine 'get-register) reg-name)) + +(#%provide get-register-contents) +(define (get-register-contents machine register-name) + (get-contents (get-register machine register-name))) + +(#%provide set-register-contents!) +(define (set-register-contents! machine register-name value) + (set-contents! (get-register machine register-name) value) + 'done) + +(#%provide make-machine) +(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)) + +;; The Assembler + +(define (make-label-entry label-name insts) + (cons label-name insts)) + +(#%provide lookup-label) +(define (lookup-label labels label-name) + (let ((val (assoc label-name labels))) + (if val + (cdr val) + (error "Undefined label -- ASSEMBLE" label-name)))) + +(#%provide extract-labels) +(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 -- ASSEMBLE" 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 (assemble controller-text machine) + (extract-labels + controller-text + (lambda (insts labels) + (update-insts! insts labels machine) + insts))) + +#| 5.8 |# + +(#%provide ambiguous-labels) +(define ambiguous-labels + '(start + (goto (label here)) + here + (assign a (const 3)) + (goto (label there)) + here + (assign a (const 4)) + (goto (label there)) + there)) + +#| (if (assoc next-inst labels) |# +#| (error "Duplicate label -- ASSEMBLE" next-inst) |# +#| (receive |# +#| insts |# +#| (cons |# +#| (make-label-entry next-inst insts) |# +#| labels))) |# + +;; Generating Execution Procedures for Instructions + +(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)))) + +(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 () + (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 () + (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)) + +(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)) + +(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 (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(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)))) + +#| 5.9 |# +#| 5.10 |# +#| 5.11 |# +#| 5.12 |# +#| 5.13 |# + +;; Monitoring Machine Performance + +#| 5.14 |# +#| 5.15 |# +#| 5.16 |# +#| 5.17 |# +#| 5.18 |# +#| 5.19 |# |