From 9426911cd9689cc3729f533bc4416df07251ab69 Mon Sep 17 00:00:00 2001 From: Correl Roush Date: Mon, 30 Mar 2015 23:07:22 -0400 Subject: [PATCH] 5 --- 5-1.org | 13 ++ 5-2.org | 595 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 608 insertions(+) create mode 100644 5-1.org create mode 100644 5-2.org diff --git a/5-1.org b/5-1.org new file mode 100644 index 0000000..6ef8473 --- /dev/null +++ b/5-1.org @@ -0,0 +1,13 @@ +#+TITLE: 5.1 - Designing Register Machines +#+STARTUP: indent +#+OPTIONS: num:nil + +Building a lisp machine in lisp to execute simple instructions modeled +in lisp to evaluate, execute, and eventually compile our lisp written +written in lisp. + +* A Language for Describing Register Machines +* Abstraction in Machine Design +* Subroutines +* Using a Stack to Implement Recursion +* Instruction Summary diff --git a/5-2.org b/5-2.org new file mode 100644 index 0000000..790af93 --- /dev/null +++ b/5-2.org @@ -0,0 +1,595 @@ +#+TITLE: 5.2 - A Register-Machine Simulator +#+STARTUP: indent +#+OPTIONS: num:nil +#+PROPERTY: header-args:scheme :tangle yes + +#+name: gcd-machine +#+BEGIN_SRC scheme :tangle no + (define gcd-machine + (make-machine + '(a b t) + (list (list 'rem remainder) (list '= =)) + '(test-b + (test (op =) (reg b) (const 0)) + (branch (label gcd-done)) + (assign t (op rem) (reg a) (reg b)) + (assign a (reg b)) + (assign b (reg t)) + (goto (label test-b)) + gcd-done))) +#+END_SRC + +* COMMENT Set up source file +#+BEGIN_SRC scheme :tangle yes + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; 5.2 - A Register-Machine Simulator + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +#+END_SRC +* The Machine Model +#+BEGIN_SRC scheme + (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)) +#+END_SRC + +** Registers +#+BEGIN_SRC scheme + (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)) + + (define (get-contents register) + (register 'get)) + + (define (set-contents! register value) + ((register 'set) value)) +#+END_SRC + +** The stack +#+BEGIN_SRC scheme + (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)) + + (define (pop stack) (stack 'pop)) + (define (push stack value) + ((stack 'push) value)) +#+END_SRC + +** The basic machine +#+BEGIN_SRC scheme + (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))) + + (define (start machine) + (machine 'start)) + + (define (get-register-contents + machine register-name) + (get-contents + (get-register machine register-name))) + + (define (set-register-contents! + machine register-name value) + (set-contents! + (get-register machine register-name) + value) + 'done) + + (define (get-register machine reg-name) + ((machine 'get-register) reg-name)) +#+END_SRC + +* The Assembler +#+BEGIN_SRC scheme + (define (assemble controller-text machine) + (extract-labels controller-text + (lambda (insts labels) + (update-insts! insts labels machine) + insts))) + + (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) + (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 (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)) + + (define (make-label-entry label-name insts) + (cons label-name insts)) + + (define (lookup-label labels label-name) + (let ((val (assoc label-name labels))) + (if val + (cdr val) + (error "Undefined label: ASSEMBLE" + label-name)))) +#+END_SRC + +** Exercise 5.8 +The following register-machine code is ambiguous, +because the label `here' is defined more than once: + +#+BEGIN_EXAMPLE + start + (goto (label here)) + here + (assign a (const 3)) + (goto (label there)) + here + (assign a (const 4)) + (goto (label there)) + there +#+END_EXAMPLE + +With the simulator as written, what will the contents of register `a' +be when control reaches `there'? Modify the `extract-labels' +procedure so that the assembler will signal an error if the same label +name is used to indicate two different locations. + +---------------------------------------------------------------------- + +The contents of register =a= will always be =3=. Labels are looked up +using =assoc=, which will always return the first match in the lookup +table. + +#+BEGIN_SRC scheme + (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. AVENGERS, ASSEMBLE!") + (receive + insts + (cons + (make-label-entry + next-inst + insts) + labels))) + (receive + (cons (make-instruction + next-inst) + insts) + labels))))))) +#+END_SRC +* Generating Execution Procedures for Instructions +#+BEGIN_SRC scheme + (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)))) +#+END_SRC + +** =Assign= instructions +#+BEGIN_SRC scheme + (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 () ; execution procedure + ; for assign + (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)))) +#+END_SRC + +** =Test=, =branch= and =goto= instructions +#+BEGIN_SRC scheme + (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)) +#+END_SRC + +** Other instructions +#+BEGIN_SRC scheme + (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)) +#+END_SRC + +** Execution procedures for subexpressions +#+BEGIN_SRC scheme + (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 (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)))) +#+END_SRC + +* Monitoring Machine Performance +#+BEGIN_SRC scheme + (define (make-stack) + (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 stack: 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) + (newline) + (display (list 'total-pushes + '= + number-pushes + 'maximum-depth + '= + max-depth))) + (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: STACK" + message)))) + dispatch)) +#+END_SRC