diff options
| -rw-r--r-- | chap5/part1.rkt | 2 | ||||
| -rw-r--r-- | chap5/part2.rkt | 495 |
2 files changed, 468 insertions, 29 deletions
diff --git a/chap5/part1.rkt b/chap5/part1.rkt index 394c3d0..3bd5009 100644 --- a/chap5/part1.rkt +++ b/chap5/part1.rkt @@ -254,7 +254,7 @@ (define fact-controller '(controller - (assign (continue (label fact-done))) + (assign continue (label fact-done)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) diff --git a/chap5/part2.rkt b/chap5/part2.rkt index 1f4a551..be9321e 100644 --- a/chap5/part2.rkt +++ b/chap5/part2.rkt @@ -51,12 +51,15 @@ (let ((expt-machine (make-machine - '(n b val continue) + #| '(n b val continue) |# (list (list '- -) (list '* *) (list '= =)) expt-controller))) (set-register-contents! expt-machine 'b 5) (set-register-contents! expt-machine 'n 4) + #| (expt-machine 'trace-on) |# + (trace-reg expt-machine 'val 'on) (start expt-machine) + (expt-machine 'reset-inst-count) (get-register-contents expt-machine 'val))) (#%provide test-expt-iter) @@ -64,18 +67,20 @@ (let ((expt-machine (make-machine - '(n b product counter) + #| '(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) + (expt-machine 'trace-on) (start expt-machine) + (expt-machine 'reset-inst-count) (get-register-contents expt-machine 'product))) ;; The Machine Model -(#%provide make-register) -(define (make-register name) +(#%provide make-register-) +(define (make-register- name) (let ((contents '*unassigned*)) (define (dispatch message) (cond @@ -125,30 +130,45 @@ ((stack 'push) value)) (define (make-instruction text) - (cons text '())) + (list text false '())) (define (instruction-text inst) (car inst)) +(define (instruction-label inst) + (cadr inst)) + (define (instruction-execution-proc inst) - (cdr inst)) + (caddr inst)) + +(define (set-instruction-label! inst label) + (set-cdr! inst (cons label (cddr inst)))) (define (set-instruction-execution-proc! inst proc) - (set-cdr! inst proc)) + (set-cdr! (cdr inst) (list proc))) (#%provide make-new-machine) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) - (stack (make-stack)) - (the-instruction-sequence '())) + (stack (make-statck)) + (the-instruction-sequence '()) + (instructions-used '()) + (entry-regs '()) + (stack-regs '()) + (reg-assignments '()) + (inst-count 0) + (trace? false)) (let ((the-ops (list (list 'initialize-stack - (lambda () (stack 'initialize))))) + (lambda () (stack 'initialize))) + (list + 'print-stack-statistics + (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) @@ -164,13 +184,68 @@ (if val (cadr val) (error "Unknown register:" name)))) + (define (lookup-register- name) + (let ((val (assoc name register-table))) + (if val + (cadr val) + (begin + (allocate-register name) + (lookup-register name))))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin + (if trace? + (begin + (if (instruction-label (car insts)) + (begin + (display (instruction-label (car insts))) + (newline))) + (display " ") + (display (instruction-text (car insts))) + (newline))) ((instruction-execution-proc (car insts))) + (set! inst-count (+ inst-count 1)) (execute))))) + (define (write-datapath-info insts) + (set! instructions-used (list-insts insts)) + (set! entry-regs + (dedup + (map + cadr + (filter + (lambda (x) (eq? (car x) 'reg)) + (map + goto-dest + (filter + (lambda (inst) (eq? (car inst) 'goto)) + instructions-used)))))) + (set! stack-regs + (dedup + (map + stack-inst-reg-name + (filter + (lambda (inst) + (or + (eq? (car inst) 'save) + (eq? (car inst) 'restore))) + instructions-used)))) + (set! reg-assignments + (map + (lambda (r) + (list + r + (map + assign-value-exp + (filter + (lambda (assign-inst) + (eq? (assign-reg-name assign-inst) r)) + (filter + (lambda (inst) (eq? (car inst) 'assign)) + instructions-used))))) + (map car register-table))) + 'done) (define (dispatch message) (cond ((eq? message 'start) @@ -180,10 +255,22 @@ (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) + ((eq? message 'get-register-alloc) lookup-register-) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) + ((eq? message 'instructions-used) instructions-used) + ((eq? message 'entry-regs) entry-regs) + ((eq? message 'stack-regs) stack-regs) + ((eq? message 'reg-assigns) reg-assignments) ((eq? message 'operations) the-ops) + ((eq? message 'write-info) write-datapath-info) + ((eq? message 'reset-inst-count) + (display (list inst-count 'instructions 'executed)) + (newline) + (set! inst-count 0)) + ((eq? message 'trace-on) (set! trace? true)) + ((eq? message 'trace-off) (set! trace? false)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) @@ -204,15 +291,17 @@ 'done) (#%provide make-machine) -(define (make-machine register-names ops controller-text) +(define (make-machine ops controller-text) +#| (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) + #| (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 'write-info) controller-text) machine)) ;; The Assembler @@ -238,11 +327,14 @@ (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))) + (begin + (if (not (null? insts)) + (set-instruction-label! (car insts) next-inst)) + (receive + insts + (cons + (make-label-entry next-inst insts) + labels)))) (receive (cons (make-instruction next-inst) @@ -329,7 +421,7 @@ (define (make-assign inst machine labels operations pc) (let ((target - (get-register machine (assign-reg-name inst))) + (get-register-alloc machine (assign-reg-name inst))) (value-exp (assign-value-exp inst))) (let ((value-proc @@ -396,7 +488,7 @@ (lambda () (set-contents! pc insts)))) ((register-exp? dest) (let - ((reg (get-register machine (register-exp-reg dest)))) + ((reg (get-register-alloc machine (register-exp-reg dest)))) (lambda () (set-contents! pc (get-contents reg))))) (else (error "Bad GOTO instruction -- ASSEMBLE" inst))))) @@ -406,7 +498,7 @@ (define (make-save inst machine stack pc) (let ((reg - (get-register + (get-register-alloc machine (stack-inst-reg-name inst)))) (lambda () @@ -416,7 +508,7 @@ (define (make-restore inst machine stack pc) (let ((reg - (get-register + (get-register-alloc machine (stack-inst-reg-name inst)))) (lambda () @@ -452,7 +544,7 @@ (let ((insts (lookup-label labels (label-exp-label exp)))) (lambda () insts))) ((register-exp? exp) - (let ((r (get-register machine (register-exp-reg exp)))) + (let ((r (get-register-alloc machine (register-exp-reg exp)))) (lambda () (get-contents r)))) (else (error "Unknown expression type -- ASSEMBLE" exp)))) @@ -480,7 +572,7 @@ (aprocs (map (lambda (e) - (make-primitive-exp e machine labels)) + (make-op-primitive-exp e machine labels)) (operation-exp-operands exp)))) (lambda () (apply op (map (lambda (p) (p)) aprocs))))) @@ -501,16 +593,363 @@ (error "Unknown operation -- ASSEMBLE" symbol)))) #| 5.9 |# -#| 5.10 |# + +(define (make-op-primitive-exp exp machine labels) + (cond + ((constant-exp? exp) + (let ((c (constant-exp-value exp))) + (lambda () c))) + ((register-exp? exp) + (let ((r (get-register-alloc machine (register-exp-reg exp)))) + (lambda () (get-contents r)))) + ((label-exp? exp) + (error "Label in operator expression" exp)) + (else + (error "Unknown expression type -- ASSEMBLE" exp)))) + #| 5.11 |# + +(define (make-save- inst machine stack pc) + (let ((reg-name (stack-inst-reg-name inst))) + (let ((reg (get-register-alloc machine reg-name))) + (lambda () + (push stack (list reg-name (get-contents reg))) + (advance-pc pc))))) + +(define (make-restore- inst machine stack pc) + (let ((reg-name (stack-inst-reg-name inst))) + (let ((reg (get-register-alloc machine reg-name))) + (lambda () + (let ((name-val (pop stack))) + (if (eq? (car name-val) reg-name) + (begin + (set-contents! reg (cadr name-val)) + (advance-pc pc)) + (error "Restore intro wrong register" inst))))))) + #| 5.12 |# + +(#%provide sort-insts) +(define (sort-insts insts) + (define (number inst) + (cond + ((symbol? inst) 0) + ((eq? (car inst) 'assign) 1) + ((eq? (car inst) 'test) 2) + ((eq? (car inst) 'branch) 3) + ((eq? (car inst) 'goto) 4) + ((eq? (car inst) 'save) 5) + ((eq? (car inst) 'restore) 6) + ((eq? (car inst) 'perform) 7) + (else 8))) + (define (compare inst1 inst2) + (cond + ((< (number inst1) (number inst2)) 'LT) + ((= (number inst1) (number inst2)) 'EQ) + (else 'GT))) + (define (split xs) + (cond + ((null? xs) (list '() '())) + ((null? (cdr xs)) (list xs '())) + (else + (let ((rest-parted (split (cddr xs)))) + (list + (cons (car xs) (car rest-parted)) + (cons (cadr xs) (cadr rest-parted))))))) + (define (merge insts1 insts2) + (cond + ((null? insts1) insts2) + ((null? insts2) insts1) + (else + (let + ((i1 (car insts1)) + (i2 (car insts2))) + (cond + ((eq? (compare i1 i2) 'LT) + (cons i1 (merge (cdr insts1) insts2))) + ((eq? (compare i1 i2) 'EQ) + (cons i1 (cons i2 (merge (cdr insts1) (cdr insts2))))) + (else + (cons i2 (merge insts1 (cdr insts2))))))))) + (if (or (null? insts) (null? (cdr insts))) + insts + (let ((parted (split insts))) + (merge + (sort-insts (car parted)) + (sort-insts (cadr parted)))))) + +(define (flatten xss) + (if (null? xss) + '() + (append + (car xss) + (flatten (cdr xss))))) + +(define (filter pred xs) + (cond + ((null? xs) '()) + ((pred (car xs)) + (cons (car xs) (filter pred (cdr xs)))) + (else + (filter pred (cdr xs))))) + +(define (nub xs) + (cond + ((null? xs) '()) + ((null? (cdr xs)) xs) + ((equal? (car xs) (cadr xs)) + (nub (cons (car xs) (cddr xs)))) + (else + (cons (car xs) (nub (cdr xs)))))) + +(#%provide list-insts) +(define (list-insts insts) + (nub + (filter + (lambda (x) (not (symbol? x))) + (sort-insts insts)))) + +(#%provide dedup) +(define (dedup syms) + (cond + ((null? syms) '()) + ((memq (car syms) (cdr syms)) + (dedup (cdr syms))) + (else (cons (car syms) (dedup (cdr syms)))))) + #| 5.13 |# +(define (inst-regs inst) + (cond + ((symbol? inst) '()) + ((eq? (car inst) 'assign) + (cons + (assign-reg-name inst) + (let ((value-exp (assign-value-exp inst))) + (if (operation-exp? value-exp) + (operation-exp-regs value-exp) + (prim-exp-regs (car value-exp)))))) + ((eq? (car inst) 'test) + (operation-exp-regs (test-condition inst))) + ((and + (eq? (car inst) 'goto) + (register-exp? (goto-dest inst))) + (list (register-exp-reg (goto-dest inst)))) + ((eq? (car inst) 'save) + (list (stack-inst-reg-name inst))) + ((eq? (car inst) 'restore) + (list (stack-inst-reg-name inst))) + ((eq? (car inst) 'perform) + (operation-exp-regs (perform-action inst))) + (else '()))) + +(define (operation-exp-regs exp) + (flatten + (map + prim-exp-regs + (operation-exp-operands exp)))) + +(define (prim-exp-regs exp) + (if (register-exp? exp) + (list (register-exp-reg exp)) + '())) + +(#%provide find-regs) +(define (find-regs controller-text) + (dedup + (flatten + (map inst-regs controller-text)))) + +#| (define (lookup-register- name) |# +#| (let ((val (assoc name register-table))) |# +#| (if val |# +#| (cadr val) |# +#| (begin |# +#| (allocate-register name) |# +#| (lookup-register name))))) |# + +(define (get-register-alloc machine reg-name) + ((machine 'get-register-alloc) reg-name)) + ;; Monitoring Machine Performance #| 5.14 |# + +#| (list |# +#| (list |# +#| 'initialize-stack |# +#| (lambda () (stack 'initialize))) |# +#| (list |# +#| 'print-stack-statistics |# +#| (lambda () (stack 'print-statistics)))) |# + +(define (make-statck) + (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 statck -- 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) + (display + (list + 'total-pushes '= number-pushes + 'maximum-depth '= max-depth)) + (newline)) + (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 -- STATCK" message)))) + dispatch)) + +(#%provide fact-controller) +(define fact-controller + '(controller + fact-loop + (perform (op initialize-stack)) + (assign n (op read)) + (assign continue (label fact-done)) + fact + (test (op =) (reg n) (const 1)) + (branch (label base-case)) + (save continue) + (save n) + (assign n (op -) (reg n) (const 1)) + (assign continue (label after-fact)) + (goto (label fact)) + after-fact + (restore n) + (restore continue) + (assign val (op *) (reg n) (reg val)) + (goto (reg continue)) + base-case + (assign val (const 1)) + (goto (reg continue)) + fact-done + (perform (op print) (reg val)) + (perform (op print-stack-statistics)) + (goto (label fact-loop)))) + +(#%provide run-fact) +(define (run-fact) + (let + ((fact-machine + (make-machine + (list + (list '- -) + (list '* *) + (list '= =) + (list 'read read) + (list 'print (lambda (x) (display x) (newline)))) + fact-controller))) + (fact-machine 'trace-on) + (start fact-machine))) + +(#%provide fact-stack-pushes) +(define (fact-stack-pushes n) + (* (- n 1) 2)) + #| 5.15 |# + +#| (inst-count 0) |# + +#| ((eq? message 'reset-inst-count) |# +#| (display (list inst-count 'instructions 'executed)) |# +#| (newline) |# +#| (set! inst-count 0)) |# + #| 5.16 |# + +#| (trace? false)) |# + +#| (if trace? |# +#| (begin |# +#| (display (instruction-text (car insts))) |# +#| (newline))) |# + +#| ((eq? message 'trace-on) (set! trace? true)) |# +#| ((eq? message 'trace-off) (set! trace? false)) |# + #| 5.17 |# + +#| (define (make-instruction text) |# +#| (list text false '())) |# + +#| (define (instruction-text inst) |# +#| (car inst)) |# + +#| (define (instruction-label inst) |# +#| (cadr inst)) |# + +#| (define (instruction-execution-proc inst) |# +#| (caddr inst)) |# + +#| (define (set-instruction-label! inst label) |# +#| (set-cdr! inst (cons label (cddr inst)))) |# + +#| (define (set-instruction-execution-proc! inst proc) |# +#| (set-cdr! (cdr inst) (list proc))) |# + +#| (if (instruction-label (car insts)) |# +#| (begin |# +#| (display (instruction-label (car insts))) |# +#| (newline))) |# + +#| (begin |# + #| (if (not (null? insts)) |# + #| (set-instruction-label! (car insts) next-inst)) |# + #| 5.18 |# -#| 5.19 |# + +(define (make-register name) + (let + ((contents '*unassigned*) + (trace? false)) + (define (dispatch message) + (cond + ((eq? message 'get) contents) + ((eq? message 'set) + (lambda (value) + (if trace? + (begin + (display + (list + name + 'old-contents '= contents + 'new-contents '= value)) + (newline))) + (set! contents value))) + ((eq? message 'trace-on) (set! trace? true)) + ((eq? message 'trace-off) (set! trace? false)) + (else + (error "Unknown request -- REGISTER" message)))) + dispatch)) + +(define (trace-reg machine reg-name on?) + (let ((reg (get-register machine reg-name))) + (cond + ((eq? on? 'on) (reg 'trace-on)) + ((eq? on? 'off) (reg 'trace-off)) + (else "Unknown request - TRACE-REG" on?)))) |