;;;;CODE FROM CHAPTER 5 OF STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS ;;;;**DON'T TRY TO LOAD THIS FILE INTO SCHEME** ;;;; It contains lots of non-Scheme things, such as machine controllers ;;;; in section 5.1, garbage-collection and explicit-control evaluator ;;;; controller code in sections 5.3 and 5.4 ;;;; ;;;; The code for the major subsystems in this chapter has been ;;;; extracted and organized into loadable/runnable Scheme files. ;;;; Those files contain runnable versions of ;;;; -- the register machine simulator (section 5.2) ;;;; -- the explicit-control evaluator (section 5.4) ;;;; -- the compiler (section 5.5) ;;;; -- the explicit-control evaluator (section 5.4) augmented to ;;;; interface with the compiler (section 5.5.7) ;;;SECTION 5.1 (define (gcd a b) (if (= b 0) a (gcd b (remainder a b)))) ;;EXERCISE 5.1 (define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) ;;;SECTION 5.1.1 (controller 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) ;;FIGURE 5.4 ;; (appears physically in 5.1.2, but logically is in 5.1.1) (controller gcd-loop (assign a (op read)) (assign b (op read)) 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 (perform (op print) (reg a)) (goto (label gcd-loop))) ;;;SECTION 5.1.2 (define (remainder n d) (if (< n d) n (remainder (- n d) d))) ;;FIGURE 5.6 (controller test-b (test (op =) (reg b) (const 0)) (branch (label gcd-done)) (assign t (reg a)) rem-loop (test (op <) (reg t) (reg b)) (branch (label rem-done)) (assign t (op -) (reg t) (reg b)) (goto (label rem-loop)) rem-done (assign a (reg b)) (assign b (reg t)) (goto (label test-b)) gcd-done) ;;EXERCISE 5.3 (define (sqrt x) (define (good-enough? guess) (< (abs (- (square guess) x)) 0.001)) (define (improve guess) (average guess (/ x guess))) (define (sqrt-iter guess) (if (good-enough? guess) guess (sqrt-iter (improve guess)))) (sqrt-iter 1.0)) ;;;SECTION 5.1.4 (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) (define (gcd a b) (if (= b 0) a (gcd b (remainder a b)))) ;;FIGURE 5.11 (controller (assign continue (label fact-done)) ; set up final return address fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) ;; Set up for the recursive call by saving n and continue. ;; Set up continue so that the computation will continue ;; at after-fact when the subroutine returns. (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) ; val now contains n(n-1)! (goto (reg continue)) ; return to caller base-case (assign val (const 1)) ; base case: 1!=1 (goto (reg continue)) ; return to caller fact-done) ;; A double recursion (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) ;;FIGURE 5.12 (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) (restore continue) ;; set up to compute Fib(n-2) (assign n (op -) (reg n) (const 2)) (save continue) (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 continue) (assign val ; Fib(n-1)+Fib(n-2) (op +) (reg val) (reg n)) (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) ;;EXERCISE 5.4 (define (expt b n) (if (= n 0) 1 (* b (expt b (- n 1))))) (define (expt b n) (define (expt-iter counter product) (if (= counter 0) product (expt-iter (- counter 1) (* b product)))) (expt-iter n 1)) ;;;SECTION 5.2 ;;; **SEE ALSO** ch5-regsim.scm (loadable/runnable simulator) (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))) (set-register-contents! gcd-machine 'a 206) (set-register-contents! gcd-machine 'b 40) (start gcd-machine) (get-register-contents gcd-machine 'a) ;;;SECTION 5.2.1 (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)) ;;;Registers (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)) ;;;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)) (define (pop stack) (stack 'pop)) (define (push stack value) ((stack 'push) value)) ;;;Basic machine ;;FIGURE 5.13 (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)) ;;;SECTION 5.2.2 (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))))))) ;; FOOTNOTE (define (extract-labels text) (if (null? text) (cons '() '()) (let ((result (extract-labels (cdr text)))) (let ((insts (car result)) (labels (cdr result))) (let ((next-inst (car text))) (if (symbol? next-inst) (cons insts (cons (make-label-entry next-inst insts) labels)) (cons (cons (make-instruction next-inst) insts) labels))))))) (define (assemble controller-text machine) (let ((result (extract-labels controller-text))) (let ((insts (car result)) (labels (cdr result))) (update-insts! insts labels machine) insts))) ;; END FOOTNOTE (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)))) ;;EXERCISE 5.8 start (goto (label here)) here (assign a (const 3)) (goto (label there)) here (assign a (const 4)) (goto (label there)) there ;;;SECTION 5.2.3 (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 () ; 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)))) (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 (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)))) ;;;SECTION 5.2.4 (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statistics (lambda () (stack 'print-statistics)))) (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)) ;;;SECTION 5.3 ;;;SECTION 5.3.1 ;;EXERCISE 5.20 (define x (cons 1 2)) (define y (list x x)) ;;EXERCISE 5.21 (define (count-leaves tree) (cond ((null? tree) 0) ((not (pair? tree)) 1) (else (+ (count-leaves (car tree)) (count-leaves (cdr tree)))))) (define (count-leaves tree) (define (count-iter tree n) (cond ((null? tree) n) ((not (pair? tree)) (+ n 1)) (else (count-iter (cdr tree) (count-iter (car tree) n))))) (count-iter tree 0)) ;;;SECTION 5.3.2 (accumulate + 0 (filter odd? (enumerate-interval 0 n))) begin-garbage-collection (assign free (const 0)) (assign scan (const 0)) (assign old (reg root)) (assign relocate-continue (label reassign-root)) (goto (label relocate-old-result-in-new)) reassign-root (assign root (reg new)) (goto (label gc-loop)) gc-loop (test (op =) (reg scan) (reg free)) (branch (label gc-flip)) (assign old (op vector-ref) (reg new-cars) (reg scan)) (assign relocate-continue (label update-car)) (goto (label relocate-old-result-in-new)) update-car (perform (op vector-set!) (reg new-cars) (reg scan) (reg new)) (assign old (op vector-ref) (reg new-cdrs) (reg scan)) (assign relocate-continue (label update-cdr)) (goto (label relocate-old-result-in-new)) update-cdr (perform (op vector-set!) (reg new-cdrs) (reg scan) (reg new)) (assign scan (op +) (reg scan) (const 1)) (goto (label gc-loop)) relocate-old-result-in-new (test (op pointer-to-pair?) (reg old)) (branch (label pair)) (assign new (reg old)) (goto (reg relocate-continue)) pair (assign oldcr (op vector-ref) (reg the-cars) (reg old)) (test (op broken-heart?) (reg oldcr)) (branch (label already-moved)) (assign new (reg free)) ;new location for pair ;; update free pointer (assign free (op +) (reg free) (const 1)) ;; Copy the car and cdr to new memory. (perform (op vector-set!) (reg new-cars) (reg new) (reg oldcr)) (assign oldcr (op vector-ref) (reg the-cdrs) (reg old)) (perform (op vector-set!) (reg new-cdrs) (reg new) (reg oldcr)) ;; Construct the broken heart. (perform (op vector-set!) (reg the-cars) (reg old) (const broken-heart)) (perform (op vector-set!) (reg the-cdrs) (reg old) (reg new)) (goto (reg relocate-continue)) already-moved (assign new (op vector-ref) (reg the-cdrs) (reg old)) (goto (reg relocate-continue)) gc-flip (assign temp (reg the-cdrs)) (assign the-cdrs (reg new-cdrs)) (assign new-cdrs (reg temp)) (assign temp (reg the-cars)) (assign the-cars (reg new-cars)) (assign new-cars (reg temp)) ;;;SECTION 5.4 ;;;SECTION 5.4.1 eval-dispatch (test (op self-evaluating?) (reg exp)) (branch (label ev-self-eval)) (test (op variable?) (reg exp)) (branch (label ev-variable)) (test (op quoted?) (reg exp)) (branch (label ev-quoted)) (test (op assignment?) (reg exp)) (branch (label ev-assignment)) (test (op definition?) (reg exp)) (branch (label ev-definition)) (test (op if?) (reg exp)) (branch (label ev-if)) (test (op lambda?) (reg exp)) (branch (label ev-lambda)) (test (op begin?) (reg exp)) (branch (label ev-begin)) (test (op application?) (reg exp)) (branch (label ev-application)) (goto (label unknown-expression-type)) ev-self-eval (assign val (reg exp)) (goto (reg continue)) ev-variable (assign val (op lookup-variable-value) (reg exp) (reg env)) (goto (reg continue)) ev-quoted (assign val (op text-of-quotation) (reg exp)) (goto (reg continue)) ev-lambda (assign unev (op lambda-parameters) (reg exp)) (assign exp (op lambda-body) (reg exp)) (assign val (op make-procedure) (reg unev) (reg exp) (reg env)) (goto (reg continue)) ev-application (save continue) (save env) (assign unev (op operands) (reg exp)) (save unev) (assign exp (op operator) (reg exp)) (assign continue (label ev-appl-did-operator)) (goto (label eval-dispatch)) ;; footnote (define (empty-arglist) '()) (define (adjoin-arg arg arglist) (append arglist (list arg))) (define (last-operand? ops) (null? (cdr ops))) ev-appl-did-operator (restore unev) ; the operands (restore env) (assign argl (op empty-arglist)) (assign proc (reg val)) ; the operator (test (op no-operands?) (reg unev)) (branch (label apply-dispatch)) (save proc) ev-appl-operand-loop (save argl) (assign exp (op first-operand) (reg unev)) (test (op last-operand?) (reg unev)) (branch (label ev-appl-last-arg)) (save env) (save unev) (assign continue (label ev-appl-accumulate-arg)) (goto (label eval-dispatch)) ev-appl-accumulate-arg (restore unev) (restore env) (restore argl) (assign argl (op adjoin-arg) (reg val) (reg argl)) (assign unev (op rest-operands) (reg unev)) (goto (label ev-appl-operand-loop)) ev-appl-last-arg (assign continue (label ev-appl-accum-last-arg)) (goto (label eval-dispatch)) ev-appl-accum-last-arg (restore argl) (assign argl (op adjoin-arg) (reg val) (reg argl)) (restore proc) (goto (label apply-dispatch)) apply-dispatch (test (op primitive-procedure?) (reg proc)) (branch (label primitive-apply)) (test (op compound-procedure?) (reg proc)) (branch (label compound-apply)) (goto (label unknown-procedure-type)) primitive-apply (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (restore continue) (goto (reg continue)) compound-apply (assign unev (op procedure-parameters) (reg proc)) (assign env (op procedure-environment) (reg proc)) (assign env (op extend-environment) (reg unev) (reg argl) (reg env)) (assign unev (op procedure-body) (reg proc)) (goto (label ev-sequence)) ;;;SECTION 5.4.2 ev-begin (assign unev (op begin-actions) (reg exp)) (save continue) (goto (label ev-sequence)) ev-sequence (assign exp (op first-exp) (reg unev)) (test (op last-exp?) (reg unev)) (branch (label ev-sequence-last-exp)) (save unev) (save env) (assign continue (label ev-sequence-continue)) (goto (label eval-dispatch)) ev-sequence-continue (restore env) (restore unev) (assign unev (op rest-exps) (reg unev)) (goto (label ev-sequence)) ev-sequence-last-exp (restore continue) (goto (label eval-dispatch)) (define (sqrt-iter guess x) (if (good-enough? guess x) guess (sqrt-iter (improve guess x) x))) ;; footnote ;;for non-tail-recursive sequences (define (no-more-exps? seq) (null? seq)) ;; non-tail-recursive version ev-sequence (test (op no-more-exps?) (reg unev)) (branch (label ev-sequence-end)) (assign exp (op first-exp) (reg unev)) (save unev) (save env) (assign continue (label ev-sequence-continue)) (goto (label eval-dispatch)) ev-sequence-continue (restore env) (restore unev) (assign unev (op rest-exps) (reg unev)) (goto (label ev-sequence)) ev-sequence-end (restore continue) (goto (reg continue)) (define (count n) (newline) (display n) (count (+ n 1))) ;;;SECTION 5.4.3 ev-if (save exp) ; save expression for later (save env) (save continue) (assign continue (label ev-if-decide)) (assign exp (op if-predicate) (reg exp)) (goto (label eval-dispatch)) ; evaluate the predicate ev-if-decide (restore continue) (restore env) (restore exp) (test (op true?) (reg val)) (branch (label ev-if-consequent)) ev-if-alternative (assign exp (op if-alternative) (reg exp)) (goto (label eval-dispatch)) ev-if-consequent (assign exp (op if-consequent) (reg exp)) (goto (label eval-dispatch)) ev-assignment (assign unev (op assignment-variable) (reg exp)) (save unev) ; save variable for later (assign exp (op assignment-value) (reg exp)) (save env) (save continue) (assign continue (label ev-assignment-1)) (goto (label eval-dispatch)) ; evaluate the assignment value ev-assignment-1 (restore continue) (restore env) (restore unev) (perform (op set-variable-value!) (reg unev) (reg val) (reg env)) (assign val (const ok)) (goto (reg continue)) ev-definition (assign unev (op definition-variable) (reg exp)) (save unev) ; save variable for later (assign exp (op definition-value) (reg exp)) (save env) (save continue) (assign continue (label ev-definition-1)) (goto (label eval-dispatch)) ; evaluate the definition value ev-definition-1 (restore continue) (restore env) (restore unev) (perform (op define-variable!) (reg unev) (reg val) (reg env)) (assign val (const ok)) (goto (reg continue)) ;;;SECTION 5.4.4 ;;footnote (define the-global-environment (setup-environment)) (define (get-global-environment) the-global-environment) read-eval-print-loop (perform (op initialize-stack)) (perform (op prompt-for-input) (const ";;; EC-Eval input:")) (assign exp (op read)) (assign env (op get-global-environment)) (assign continue (label print-result)) (goto (label eval-dispatch)) print-result (perform (op announce-output) (const ";;; EC-Eval value:")) (perform (op user-print) (reg val)) (goto (label read-eval-print-loop)) unknown-expression-type (assign val (const unknown-expression-type-error)) (goto (label signal-error)) unknown-procedure-type (restore continue) ; clean up stack (from apply-dispatch) (assign val (const unknown-procedure-type-error)) (goto (label signal-error)) signal-error (perform (op user-print) (reg val)) (goto (label read-eval-print-loop)) (define eceval (make-machine '(exp env val proc argl continue unev) eceval-operations '( read-eval-print-loop ;;** entire machine controller as given above ))) (define the-global-environment (setup-environment)) (start eceval) (define (append x y) (if (null? x) y (cons (car x) (append (cdr x) y)))) (append '(a b c) '(d e f)) print-result (perform (op print-stack-statistics)) (perform (op announce-output) (const ";;; EC-Eval value:")) (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) (factorial 5) ;;EXERCISE 5.26 (define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) ;;EXERCISE 5.27 (define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) ;;EXERCISE 5.29 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) ;;;SECTION 5.5 ;;; **SEE ALSO** ch5-compiler.scm (loadable/runnable compiler) ;;;SECTION 5.5.1 (define (compile exp target linkage) (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage)) ((quoted? exp) (compile-quoted exp target linkage)) ((variable? exp) (compile-variable exp target linkage)) ((assignment? exp) (compile-assignment exp target linkage)) ((definition? exp) (compile-definition exp target linkage)) ((if? exp) (compile-if exp target linkage)) ((lambda? exp) (compile-lambda exp target linkage)) ((begin? exp) (compile-sequence (begin-actions exp) target linkage)) ((cond? exp) (compile (cond->if exp) target linkage)) ((application? exp) (compile-application exp target linkage)) (else (error "Unknown expression type -- COMPILE" exp)))) (define (make-instruction-sequence needs modifies statements) (list needs modifies statements)) (define (empty-instruction-sequence) (make-instruction-sequence '() '() '())) ;;EXERCISE 5.31 (f 'x 'y) ((f) 'x 'y) (f (g 'x) y) (f (g 'x) 'y) ;;;SECTION 5.5.2 ;; footnote `((goto (label ,linkage))) `(1 2 ,(car x)) ;;;linkage code (define (compile-linkage linkage) (cond ((eq? linkage 'return) (make-instruction-sequence '(continue) '() '((goto (reg continue))))) ((eq? linkage 'next) (empty-instruction-sequence)) (else (make-instruction-sequence '() '() `((goto (label ,linkage))))))) (define (end-with-linkage linkage instruction-sequence) (preserving '(continue) instruction-sequence (compile-linkage linkage))) ;;;simple expressions (define (compile-self-evaluating exp target linkage) (end-with-linkage linkage (make-instruction-sequence '() (list target) `((assign ,target (const ,exp)))))) (define (compile-quoted exp target linkage) (end-with-linkage linkage (make-instruction-sequence '() (list target) `((assign ,target (const ,(text-of-quotation exp))))))) (define (compile-variable exp target linkage) (end-with-linkage linkage (make-instruction-sequence '(env) (list target) `((assign ,target (op lookup-variable-value) (const ,exp) (reg env)))))) (define (compile-assignment exp target linkage) (let ((var (assignment-variable exp)) (get-value-code (compile (assignment-value exp) 'val 'next))) (end-with-linkage linkage (preserving '(env) get-value-code (make-instruction-sequence '(env val) (list target) `((perform (op set-variable-value!) (const ,var) (reg val) (reg env)) (assign ,target (const ok)))))))) (define (compile-definition exp target linkage) (let ((var (definition-variable exp)) (get-value-code (compile (definition-value exp) 'val 'next))) (end-with-linkage linkage (preserving '(env) get-value-code (make-instruction-sequence '(env val) (list target) `((perform (op define-variable!) (const ,var) (reg val) (reg env)) (assign ,target (const ok)))))))) ;;;conditional expressions ;;;labels (from footnote) (define label-counter 0) (define (new-label-number) (set! label-counter (+ 1 label-counter)) label-counter) (define (make-label name) (string->symbol (string-append (symbol->string name) (number->string (new-label-number))))) ;; end of footnote (define (compile-if exp target linkage) (let ((t-branch (make-label 'true-branch)) (f-branch (make-label 'false-branch)) (after-if (make-label 'after-if))) (let ((consequent-linkage (if (eq? linkage 'next) after-if linkage))) (let ((p-code (compile (if-predicate exp) 'val 'next)) (c-code (compile (if-consequent exp) target consequent-linkage)) (a-code (compile (if-alternative exp) target linkage))) (preserving '(env continue) p-code (append-instruction-sequences (make-instruction-sequence '(val) '() `((test (op false?) (reg val)) (branch (label ,f-branch)))) (parallel-instruction-sequences (append-instruction-sequences t-branch c-code) (append-instruction-sequences f-branch a-code)) after-if)))))) ;;; sequences (define (compile-sequence seq target linkage) (if (last-exp? seq) (compile (first-exp seq) target linkage) (preserving '(env continue) (compile (first-exp seq) target 'next) (compile-sequence (rest-exps seq) target linkage)))) ;; footnote (define (make-compiled-procedure entry env) (list 'compiled-procedure entry env)) (define (compiled-procedure? proc) (tagged-list? proc 'compiled-procedure)) (define (compiled-procedure-entry c-proc) (cadr c-proc)) (define (compiled-procedure-env c-proc) (caddr c-proc)) ;; end of footnote ;;;lambda expressions (define (compile-lambda exp target linkage) (let ((proc-entry (make-label 'entry)) (after-lambda (make-label 'after-lambda))) (let ((lambda-linkage (if (eq? linkage 'next) after-lambda linkage))) (append-instruction-sequences (tack-on-instruction-sequence (end-with-linkage lambda-linkage (make-instruction-sequence '(env) (list target) `((assign ,target (op make-compiled-procedure) (label ,proc-entry) (reg env))))) (compile-lambda-body exp proc-entry)) after-lambda)))) (define (compile-lambda-body exp proc-entry) (let ((formals (lambda-parameters exp))) (append-instruction-sequences (make-instruction-sequence '(env proc argl) '(env) `(,proc-entry (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const ,formals) (reg argl) (reg env)))) (compile-sequence (lambda-body exp) 'val 'return)))) ;;;SECTION 5.5.3 ;;;combinations (define (compile-application exp target linkage) (let ((proc-code (compile (operator exp) 'proc 'next)) (operand-codes (map (lambda (operand) (compile operand 'val 'next)) (operands exp)))) (preserving '(env continue) proc-code (preserving '(proc continue) (construct-arglist operand-codes) (compile-procedure-call target linkage))))) (define (construct-arglist operand-codes) (let ((operand-codes (reverse operand-codes))) (if (null? operand-codes) (make-instruction-sequence '() '(argl) '((assign argl (const ())))) (let ((code-to-get-last-arg (append-instruction-sequences (car operand-codes) (make-instruction-sequence '(val) '(argl) '((assign argl (op list) (reg val))))))) (if (null? (cdr operand-codes)) code-to-get-last-arg (preserving '(env) code-to-get-last-arg (code-to-get-rest-args (cdr operand-codes)))))))) (define (code-to-get-rest-args operand-codes) (let ((code-for-next-arg (preserving '(argl) (car operand-codes) (make-instruction-sequence '(val argl) '(argl) '((assign argl (op cons) (reg val) (reg argl))))))) (if (null? (cdr operand-codes)) code-for-next-arg (preserving '(env) code-for-next-arg (code-to-get-rest-args (cdr operand-codes)))))) ;;;applying procedures (define (compile-procedure-call target linkage) (let ((primitive-branch (make-label 'primitive-branch)) (compiled-branch (make-label 'compiled-branch)) (after-call (make-label 'after-call))) (let ((compiled-linkage (if (eq? linkage 'next) after-call linkage))) (append-instruction-sequences (make-instruction-sequence '(proc) '() `((test (op primitive-procedure?) (reg proc)) (branch (label ,primitive-branch)))) (parallel-instruction-sequences (append-instruction-sequences compiled-branch (compile-proc-appl target compiled-linkage)) (append-instruction-sequences primitive-branch (end-with-linkage linkage (make-instruction-sequence '(proc argl) (list target) `((assign ,target (op apply-primitive-procedure) (reg proc) (reg argl))))))) after-call)))) ;;;applying compiled procedures (define (compile-proc-appl target linkage) (cond ((and (eq? target 'val) (not (eq? linkage 'return))) (make-instruction-sequence '(proc) all-regs `((assign continue (label ,linkage)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val))))) ((and (not (eq? target 'val)) (not (eq? linkage 'return))) (let ((proc-return (make-label 'proc-return))) (make-instruction-sequence '(proc) all-regs `((assign continue (label ,proc-return)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) ,proc-return (assign ,target (reg val)) (goto (label ,linkage)))))) ((and (eq? target 'val) (eq? linkage 'return)) (make-instruction-sequence '(proc continue) all-regs '((assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val))))) ((and (not (eq? target 'val)) (eq? linkage 'return)) (error "return linkage, target not val -- COMPILE" target)))) ;; footnote (define all-regs '(env proc val argl continue)) ;;;SECTION 5.5.4 (define (registers-needed s) (if (symbol? s) '() (car s))) (define (registers-modified s) (if (symbol? s) '() (cadr s))) (define (statements s) (if (symbol? s) (list s) (caddr s))) (define (needs-register? seq reg) (memq reg (registers-needed seq))) (define (modifies-register? seq reg) (memq reg (registers-modified seq))) (define (append-instruction-sequences . seqs) (define (append-2-sequences seq1 seq2) (make-instruction-sequence (list-union (registers-needed seq1) (list-difference (registers-needed seq2) (registers-modified seq1))) (list-union (registers-modified seq1) (registers-modified seq2)) (append (statements seq1) (statements seq2)))) (define (append-seq-list seqs) (if (null? seqs) (empty-instruction-sequence) (append-2-sequences (car seqs) (append-seq-list (cdr seqs))))) (append-seq-list seqs)) (define (list-union s1 s2) (cond ((null? s1) s2) ((memq (car s1) s2) (list-union (cdr s1) s2)) (else (cons (car s1) (list-union (cdr s1) s2))))) (define (list-difference s1 s2) (cond ((null? s1) '()) ((memq (car s1) s2) (list-difference (cdr s1) s2)) (else (cons (car s1) (list-difference (cdr s1) s2))))) (define (preserving regs seq1 seq2) (if (null? regs) (append-instruction-sequences seq1 seq2) (let ((first-reg (car regs))) (if (and (needs-register? seq2 first-reg) (modifies-register? seq1 first-reg)) (preserving (cdr regs) (make-instruction-sequence (list-union (list first-reg) (registers-needed seq1)) (list-difference (registers-modified seq1) (list first-reg)) (append `((save ,first-reg)) (statements seq1) `((restore ,first-reg)))) seq2) (preserving (cdr regs) seq1 seq2))))) (define (tack-on-instruction-sequence seq body-seq) (make-instruction-sequence (registers-needed seq) (registers-modified seq) (append (statements seq) (statements body-seq)))) (define (parallel-instruction-sequences seq1 seq2) (make-instruction-sequence (list-union (registers-needed seq1) (registers-needed seq2)) (list-union (registers-modified seq1) (registers-modified seq2)) (append (statements seq1) (statements seq2)))) ;;;SECTION 5.5.5 (compile '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n))) 'val 'next) ;;EXERCISE 5.33 (define (factorial-alt n) (if (= n 1) 1 (* n (factorial-alt (- n 1))))) ;;EXERCISE 5.34 (define (factorial n) (define (iter product counter) (if (> counter n) product (iter (* counter product) (+ counter 1)))) (iter 1 1)) ;;EXERCISE 5.35 (FIGURE 5.18) (assign val (op make-compiled-procedure) (label entry16) (reg env)) (goto (label after-lambda15)) entry16 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x)) (reg argl) (reg env)) (assign proc (op lookup-variable-value) (const +) (reg env)) (save continue) (save proc) (save env) (assign proc (op lookup-variable-value) (const g) (reg env)) (save proc) (assign proc (op lookup-variable-value) (const +) (reg env)) (assign val (const 2)) (assign argl (op list) (reg val)) (assign val (op lookup-variable-value) (const x) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch19)) compiled-branch18 (assign continue (label after-call17)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch19 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call17 (assign argl (op list) (reg val)) (restore proc) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch22)) compiled-branch21 (assign continue (label after-call20)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch22 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call20 (assign argl (op list) (reg val)) (restore env) (assign val (op lookup-variable-value) (const x) (reg env)) (assign argl (op cons) (reg val) (reg argl)) (restore proc) (restore continue) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch25)) compiled-branch24 (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch25 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) (goto (reg continue)) after-call23 after-lambda15 (perform (op define-variable!) (const f) (reg val) (reg env)) (assign val (const ok)) ;;end of exercise ;;;SECTION 5.5.6 (let ((x 3) (y 4)) (lambda (a b c d e) (let ((y (* a b x)) (z (+ c d x))) (* x y z)))) ((lambda (x y) (lambda (a b c d e) ((lambda (y z) (* x y z)) (* a b x) (+ c d x)))) 3 4) ;;EXERCISE 5.41 (find-variable 'c '((y z) (a b c d e) (x y))) (find-variable 'x '((y z) (a b c d e) (x y))) (find-variable 'w '((y z) (a b c d e) (x y))) ;;EXERCISE 5.44 (lambda (+ * a b x y) (+ (* a x) (* b y))) ;;;SECTION 5.5.7 (compile-and-go '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) (factorial 5) ;; change to eceval machine apply-dispatch (test (op primitive-procedure?) (reg proc)) (branch (label primitive-apply)) (test (op compound-procedure?) (reg proc)) (branch (label compound-apply)) (test (op compiled-procedure?) (reg proc)) (branch (label compiled-apply)) (goto (label unknown-procedure-type)) compiled-apply (restore continue) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) ;; footnote (define (start-eceval) (set! the-global-environment (setup-environment)) (set-register-contents! eceval 'flag false) (start eceval)) (define (user-print object) (cond ((compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '))) ((compiled-procedure? object) (display ')) (else (display object)))) ;; end of footnote (branch (label external-entry)) ; branches if flag is set read-eval-print-loop (perform (op initialize-stack)) ... external-entry (perform (op initialize-stack)) (assign env (op get-global-environment)) (assign continue (label print-result)) (goto (reg val)) (define (compile-and-go expression) (let ((instructions (assemble (statements (compile expression 'val 'return)) eceval))) (set! the-global-environment (setup-environment)) (set-register-contents! eceval 'val instructions) (set-register-contents! eceval 'flag true) (start eceval))) (compile-and-go '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) (factorial 5) ;;EXERCISE 5.46 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) ;;EXERCISE 5.47 (assign compapp (label compound-apply)) (branch (label external-entry)) ; branches if flag is set read-eval-print-loop ... ;;EXERCISE 5.48 (compile-and-run '(define (factorial n) (if (= n 1) 1 (* (factorial (- n 1)) n)))) (factorial 5)