Permalink
Browse files

Add solutions to 5.5.5

  • Loading branch information...
fastred committed Jan 17, 2013
1 parent 7e47584 commit ef61d3ccbd3abc4d9495ea63b983c0d1a0298187
Showing with 752 additions and 0 deletions.
  1. +77 −0 5_33.scm
  2. +104 −0 5_34.scm
  3. +4 −0 5_35.scm
  4. +7 −0 5_36.scm
  5. +54 −0 5_37.scm
  6. +129 −0 5_38.scm
  7. +377 −0 ch5-eceval-compiler-extended.scm
View
@@ -0,0 +1,77 @@
+(load "ch5-compiler.scm")
+(define (displayln line) (display line) (newline))
+(define (show-formatted code)
+ (let ((insts (caddr code)))
+ (newline)
+ (for-each (lambda (x) (if (not (null? x))
+ (if (not (symbol? x))
+ (begin (display " ") (displayln x))
+ (displayln x))))
+ insts)))
+
+;(* (factorial (- n 1)) n)))
+;false-branch4
+ ;(assign proc (op lookup-variable-value) (const *) (reg env))
+ ;(save continue)
+ ;(save proc)
+ ;(assign val (op lookup-variable-value) (const n) (reg env))
+ ;(assign argl (op list) (reg val))
+ ;(save argl)
+ ;(assign proc (op lookup-variable-value) (const factorial) (reg env))
+ ;(save proc)
+ ;(assign proc (op lookup-variable-value) (const -) (reg env))
+ ;(assign val (const 1))
+ ;(assign argl (op list) (reg val))
+ ;(assign val (op lookup-variable-value) (const n) (reg env))
+ ;(assign argl (op cons) (reg val) (reg argl))
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch8))
+;...
+;after-call9
+ ;(restore argl)
+ ;(assign argl (op cons) (reg val) (reg argl))
+ ;(restore proc)
+ ;(restore continue)
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch14))
+
+
+;(* n (factorial-alt (- n 1)))))
+;false-branch4
+ ;(assign proc (op lookup-variable-value) (const *) (reg env))
+ ;(save continue)
+ ;(save proc)
+ ;(save env)
+ ;(assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
+ ;(save proc)
+ ;(assign proc (op lookup-variable-value) (const -) (reg env))
+ ;(assign val (const 1))
+ ;(assign argl (op list) (reg val))
+ ;(assign val (op lookup-variable-value) (const n) (reg env))
+ ;(assign argl (op cons) (reg val) (reg argl))
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch8))
+;...
+;after-call9
+ ;(assign argl (op list) (reg val))
+ ;(restore env)
+ ;(assign val (op lookup-variable-value) (const n) (reg env))
+ ;(assign argl (op cons) (reg val) (reg argl))
+ ;(restore proc)
+ ;(restore continue)
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch14))
+
+
+;Difference in produced outputs is caused by different order of arguments to '*' application.
+;Recall that arguments are evaluated from right to left.
+;In 'factorial' we have to save 'argl', because we're in the middle of building
+;argument list when we stumble on the procedure ('factorial') application.
+;On the other hand in factorial-alt we don't need to save 'argl' because application
+;of 'factorial-alt' is first to be evaluated in argument list building. But we need
+;to save 'env' because it may be changed by procedure application (we don't need
+;to save it in 'factorial' because evaluation of last argument can alter current environment).
+;
+;Performance of both procedures is the same. We have the same numbers of instructions
+;and stack operations.
+
View
104 5_34.scm
@@ -0,0 +1,104 @@
+ (assign val (op make-compiled-procedure) (label entry2) (reg env))
+ (goto (label after-lambda1))
+entry2
+ (assign env (op compiled-procedure-env) (reg proc))
+ (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
+ (assign val (op make-compiled-procedure) (label entry7) (reg env))
+ (goto (label after-lambda6))
+entry7 ; definition of 'iter'
+ (assign env (op compiled-procedure-env) (reg proc))
+ (assign env (op extend-environment) (const (product counter)) (reg argl) (reg env))
+ (save continue)
+ (save env)
+ (assign proc (op lookup-variable-value) (const >) (reg env))
+ (assign val (op lookup-variable-value) (const n) (reg env))
+ (assign argl (op list) (reg val))
+ (assign val (op lookup-variable-value) (const counter) (reg env))
+ (assign argl (op cons) (reg val) (reg argl))
+ (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
+ (restore env)
+ (restore continue)
+ (test (op false?) (reg val))
+ (branch (label false-branch9))
+true-branch10
+ (assign val (op lookup-variable-value) (const product) (reg env))
+ (goto (reg continue))
+false-branch9 ; executing: (iter (* counter product) (+ counter 1))))
+ (assign proc (op lookup-variable-value) (const iter) (reg env))
+ (save continue)
+ (save proc)
+ (save env)
+ (assign proc (op lookup-variable-value) (const +) (reg env))
+ (assign val (const 1))
+ (assign argl (op list) (reg val))
+ (assign val (op lookup-variable-value) (const counter) (reg env))
+ (assign argl (op cons) (reg val) (reg argl))
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-branch16))
+compiled-branch15
+ (assign continue (label after-call14))
+ (assign val (op compiled-procedure-entry) (reg proc))
+ (goto (reg val))
+primitive-branch16
+ (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+after-call14 ; after (+ counter 1)
+ (assign argl (op list) (reg val))
+ (restore env)
+ (save argl)
+ (assign proc (op lookup-variable-value) (const *) (reg env))
+ (assign val (op lookup-variable-value) (const product) (reg env))
+ (assign argl (op list) (reg val))
+ (assign val (op lookup-variable-value) (const counter) (reg env))
+ (assign argl (op cons) (reg val) (reg argl))
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-branch13))
+compiled-branch12
+ (assign continue (label after-call11))
+ (assign val (op compiled-procedure-entry) (reg proc))
+ (goto (reg val))
+primitive-branch13
+ (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+after-call11 ; after (* counter product)
+ (restore argl)
+ (assign argl (op cons) (reg val) (reg argl))
+ (restore proc)
+ (restore continue)
+ ; all items pushed to stack during evaluation of 'iter' are now removed
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-branch19))
+compiled-branch18
+ (assign val (op compiled-procedure-entry) (reg proc)) ; application of 'iter'
+ (goto (reg val))
+primitive-branch19
+ (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+ (goto (reg continue))
+after-call17
+after-if8
+after-lambda6
+ (perform (op define-variable!) (const iter) (reg val) (reg env))
+ (assign val (const ok))
+ (assign proc (op lookup-variable-value) (const iter) (reg env))
+ (assign val (const 1))
+ (assign argl (op list) (reg val))
+ (assign val (const 1))
+ (assign argl (op cons) (reg val) (reg argl))
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-branch5))
+compiled-branch4
+ (assign val (op compiled-procedure-entry) (reg proc))
+ (goto (reg val))
+primitive-branch5
+ (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+ (goto (reg continue))
+after-call3
+after-lambda1
+ (perform (op define-variable!) (const factorial) (reg val) (reg env))
+ (assign val (const ok))
View
@@ -0,0 +1,4 @@
+(define f
+ (lambda (x)
+ (+ x (g (+ x 2)))))
+
View
@@ -0,0 +1,7 @@
+;Arguments are evaluated from right to left. It's in the procedure 'construct-arglist'.
+;
+;Current complexity of argument list building is O(n). If we were to build
+;this list from the beginning appending each new element to the end of the list
+;we would end up with O(n^2).
+
+; TODO: code for left to right evaluation
View
@@ -0,0 +1,54 @@
+(load "5_33.scm")
+
+(define (preserving regs seq1 seq2)
+ (if (null? regs)
+ (append-instruction-sequences seq1 seq2)
+ (let ((first-reg (car regs)))
+ (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))))
+
+
+; code for (+ 1 2)
+ (save continue) ; 3 not needed operations
+ (save env)
+ (save continue)
+ (assign proc (op lookup-variable-value) (const +) (reg env))
+ (restore continue) ; 3 not needed operations
+ (restore env)
+ (restore continue)
+ (save continue) ; 4 not needed operations
+ (save proc)
+ (save env)
+ (save continue)
+ (assign val (const 2))
+ (restore continue) ; not neeed
+ (assign argl (op list) (reg val))
+ (restore env) ; 3 not needed operations
+ (save argl)
+ (save continue)
+ (assign val (const 1))
+ (restore continue) ; 2 not needed operations
+ (restore argl)
+ (assign argl (op cons) (reg val) (reg argl))
+ (restore proc) ; 2 not needed operations
+ (restore continue)
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-branch3))
+compiled-branch2
+ (assign continue (label after-call1))
+ (assign val (op compiled-procedure-entry) (reg proc))
+ (goto (reg val))
+primitive-branch3
+ (save continue) ; not needed
+ (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+ (restore continue) ; not needed
+after-call1
+
View
129 5_38.scm
@@ -0,0 +1,129 @@
+(load "load-eceval-compiler.scm")
+(load "ch5-eceval-compiler-extended.scm")
+(load "5_33.scm")
+
+(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)))
+
+(define (selected-primitive? exp)
+ (and (pair? exp) (memq (car exp) '(+ - * /))))
+
+(define (spread-arguments operands)
+ (let ((op1 (compile (car operands) 'arg1 'next))
+ (op2 (compile (cadr operands) 'arg2 'next)))
+ (list
+ op1
+ op2)))
+
+(define (compile-sel-primitive exp target linkage)
+ (let ((operands-code (spread-arguments (operands exp)))
+ (operator (operator exp))
+ (after-call (make-label 'after-call)))
+ (end-with-linkage linkage
+ (preserving '(continue env)
+ (car operands-code)
+ (preserving '(arg1)
+ (cadr operands-code)
+ (make-instruction-sequence '(arg1 arg2) (list target)
+ `((assign ,target (op ,operator) (reg arg1) (reg arg2)))))))))
+
+(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))
+ ((selected-primitive? exp)
+ (compile-sel-primitive exp target linkage))
+ ((application? exp)
+ (compile-application exp target linkage))
+ (else
+ (error "Unknown expression type -- COMPILE" exp))))
+
+(define code
+ '(define (factorial n)
+ (if (= n 1)
+ 1
+ (* (factorial (- n 1)) n))))
+;(compile-and-go code)
+
+
+; c) Two procedure calls ('*' and '-') are now replaced with open code. Thanks to that
+; resulting output is shorter and we save some pushing and popping from the stack.
+; Factorial output:
+;
+ ;(assign val (op make-compiled-procedure) (label entry2) (reg env))
+ ;(goto (label after-lambda1))
+;entry2
+ ;(assign env (op compiled-procedure-env) (reg proc))
+ ;(assign env (op extend-environment) (const (n)) (reg argl) (reg env))
+ ;(save continue)
+ ;(save env)
+ ;(assign proc (op lookup-variable-value) (const =) (reg env))
+ ;(assign val (const 1))
+ ;(assign argl (op list) (reg val))
+ ;(assign val (op lookup-variable-value) (const n) (reg env))
+ ;(assign argl (op cons) (reg val) (reg argl))
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch14))
+;compiled-branch13
+ ;(assign continue (label after-call12))
+ ;(assign val (op compiled-procedure-entry) (reg proc))
+ ;(goto (reg val))
+;primitive-branch14
+ ;(assign val (op apply-primitive-procedure) (reg proc) (reg argl))
+;after-call12
+ ;(restore env)
+ ;(restore continue)
+ ;(test (op false?) (reg val))
+ ;(branch (label false-branch4))
+;true-branch5
+ ;(assign val (const 1))
+ ;(goto (reg continue))
+;false-branch4
+ ;(save continue)
+ ;(save env)
+ ;(assign proc (op lookup-variable-value) (const factorial) (reg env))
+ ;(assign arg1 (op lookup-variable-value) (const n) (reg env))
+ ;(assign arg2 (const 1))
+ ;(assign val (op -) (reg arg1) (reg arg2))
+ ;(assign argl (op list) (reg val))
+ ;(test (op primitive-procedure?) (reg proc))
+ ;(branch (label primitive-branch10))
+;compiled-branch9
+ ;(assign continue (label proc-return11))
+ ;(assign val (op compiled-procedure-entry) (reg proc))
+ ;(goto (reg val))
+;proc-return11
+ ;(assign arg1 (reg val))
+ ;(goto (label after-call8))
+;primitive-branch10
+ ;(assign arg1 (op apply-primitive-procedure) (reg proc) (reg argl))
+;after-call8
+ ;(restore env)
+ ;(assign arg2 (op lookup-variable-value) (const n) (reg env))
+ ;(assign val (op *) (reg arg1) (reg arg2))
+ ;(restore continue)
+ ;(goto (reg continue))
+;after-if3
+;after-lambda1
+ ;(perform (op define-variable!) (const factorial) (reg val) (reg env))
+ ;(assign val (const ok))
Oops, something went wrong.

0 comments on commit ef61d3c

Please sign in to comment.