448 lines
14 KiB
Scheme
448 lines
14 KiB
Scheme
(load "shared/sicp-compiler.scm")
|
|
|
|
(define (compile-to-file code target linkage file-name)
|
|
(set! label-counter 0)
|
|
(define (write-list-to-port xs port)
|
|
(if (null? xs)
|
|
'()
|
|
(begin
|
|
(display (car xs) port)
|
|
(display "\n" port)
|
|
(write-list-to-port (cdr xs) port))))
|
|
(if #f ; #t means write to file; #f means don't write to file
|
|
(let* ((compile-result (compile code target linkage))
|
|
(assembly-insts (statements compile-result))
|
|
(port (open-output-file file-name)))
|
|
(write-list-to-port assembly-insts port)
|
|
(display "[")
|
|
(display file-name)
|
|
(display "]\n")
|
|
(close-output-port port))
|
|
(begin
|
|
(display "[")
|
|
(display file-name)
|
|
(display "]\n"))))
|
|
|
|
(display "\nex-5.31 - save-and-restore-for-apply\n")
|
|
|
|
; 1. save and restore env around operator
|
|
; 2. save and restore env around each operand (except last)
|
|
; 3. save and restore argl around each operand
|
|
; 4. save and restore proc around operand sequence
|
|
|
|
; (f 'x 'y)
|
|
; 1-4 are superfluous
|
|
|
|
; ((f) 'x 'y)
|
|
; 1-4 are superfluous
|
|
; no need to save env because compound-apply without args does
|
|
; not change env
|
|
|
|
; (f (g 'x) y)
|
|
; 1 is superfluous
|
|
; we need 2 because (g 'x) changes the env for y
|
|
; we need 3 because (g 'x) changes argl
|
|
; we need 4 because (g 'x) changes proc
|
|
|
|
; (f (g 'x) 'y) ; 1 is superfluous
|
|
; 1-2 are superfluous
|
|
; (g 'x) changes the env but we don't need it later (better save it anyway)
|
|
; 3-4 are still needed
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-5.32 - optimize-eceval-application\n")
|
|
|
|
'(
|
|
ev-application
|
|
(save continue)
|
|
(assign unev (op operands) (reg exp))
|
|
(assign exp (op operator) (reg exp))
|
|
(assign continue (label ev-appl-did-operator-no-restore))
|
|
(test (op variable?) (reg exp))
|
|
(branch (label ev-variable))
|
|
(save env)
|
|
(save unev)
|
|
(assign continue (label ev-appl-did-operator))
|
|
(goto (label eval-dispatch))
|
|
ev-appl-did-operator
|
|
(restore unev)
|
|
(restore env)
|
|
ev-appl-did-operator-no-restore
|
|
(assign argl (op empty-arglist))
|
|
(assign proc (reg val))
|
|
(test (op no-operands?) (reg unev))
|
|
(branch (label apply-dispatch))
|
|
(save proc)
|
|
)
|
|
|
|
(display "[ok]\n")
|
|
|
|
; b. Applying all the optimizations make sense, but the compiled code will
|
|
; still run faster because the interpreter has to analyze the code every time
|
|
; it executes and the analysis itself adds overhead that the compiler can do
|
|
; before runtime
|
|
(display "[answered]\n")
|
|
|
|
|
|
(display "\nex-5.33 - compare-factorial-definitions\n")
|
|
|
|
; Uncomment the following lines to write the assembly code for the to methods
|
|
; into files.
|
|
|
|
(compile-to-file
|
|
'(define (factorial n)
|
|
(if (= n 1)
|
|
1
|
|
(* (factorial (- n 1)) n)))
|
|
'val 'next "factorial.sicp-asm")
|
|
|
|
(compile-to-file
|
|
'(define (factorial-alt n)
|
|
(if (= n 1)
|
|
1
|
|
(* n (factorial-alt (- n 1)))))
|
|
'val 'next "factorial-alt.sicp-asm")
|
|
|
|
; $ diff factorial.sicp-asm factorial-alt.sicp-asm
|
|
; 33,36c33,34
|
|
; < (assign val (op lookup-variable-value) (const n) (reg env))
|
|
; < (assign argl (op list) (reg val))
|
|
; < (save argl)
|
|
; ---
|
|
; > (save env)
|
|
; > (assign proc (op lookup-variable-value) (const factorial-alt) (reg env))
|
|
; 63c61,63
|
|
; < (restore argl)
|
|
; ---
|
|
; > (assign argl (op list) (reg val))
|
|
; > (restore env)
|
|
; > (assign val (op lookup-variable-value) (const n) (reg env))
|
|
|
|
; The regular factorial needs an additional save-and-restore for argl before
|
|
; the recursive call. Argl must be saved because it contains the value of n
|
|
; before the recursive call.
|
|
|
|
; The alternative factorial needs an additional save-and-restore for env before
|
|
; the recursive call. Env must be saved for other the evaluation of the
|
|
; remaining arguments. In this case, the look-up of n which comes second for
|
|
; the alternative implementation.
|
|
|
|
; Neither version executes more efficiently and they have the same number of
|
|
; instructions.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-5.34 - factorial-iter\n")
|
|
|
|
(compile-to-file
|
|
'(define (factorial n)
|
|
(define (iter product counter)
|
|
(if (> counter n)
|
|
product
|
|
(iter (* counter product)
|
|
(+ counter 1))))
|
|
(iter 1 1))
|
|
'val 'next "factorial-iter.sicp-asm")
|
|
|
|
; ;; construct code for factorial
|
|
; (assign val (op make-compiled-procedure) (label entry2) (reg env))
|
|
; (goto (label after-lambda1))
|
|
;
|
|
; ;; entry to factorial
|
|
; entry2
|
|
; (assign env (op compiled-procedure-env) (reg proc))
|
|
; (assign env (op extend-environment) (const (n)) (reg argl) (reg env))
|
|
;
|
|
; ;; construct the iter procedure within factorial
|
|
; (assign val (op make-compiled-procedure) (label entry7) (reg env))
|
|
; (goto (label after-lambda6))
|
|
;
|
|
; ;; entry to iter
|
|
; entry7
|
|
; (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))
|
|
;
|
|
; ;; dead code
|
|
; compiled-branch21
|
|
; (assign continue (label after-call20))
|
|
; (assign val (op compiled-procedure-entry) (reg proc))
|
|
; (goto (reg val))
|
|
; ;; dead code end
|
|
;
|
|
; 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
|
|
; ;; load end result into val and return
|
|
; (assign val (op lookup-variable-value) (const product) (reg env))
|
|
; (goto (reg continue))
|
|
;
|
|
; false-branch9
|
|
; ;; setup for next iteration
|
|
; (assign proc (op lookup-variable-value) (const iter) (reg env))
|
|
; (save continue)
|
|
; (save proc)
|
|
; (save env)
|
|
;
|
|
; ;; compute first argument for iter call
|
|
; (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
|
|
; (assign argl (op list) (reg val))
|
|
;
|
|
; ;; compute second argument for iter call
|
|
; (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
|
|
; (restore argl)
|
|
; (assign argl (op cons) (reg val) (reg argl))
|
|
;
|
|
; ;; prepare for tail-recursive call to iter
|
|
; (restore proc)
|
|
; ;; restore the original continue label
|
|
; (restore continue)
|
|
; (test (op primitive-procedure?) (reg proc))
|
|
; (branch (label primitive-branch19))
|
|
; compiled-branch18
|
|
; (assign val (op compiled-procedure-entry) (reg proc))
|
|
; ;; jump to entry 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
|
|
; ;; after definition of iter
|
|
; (perform (op define-variable!) (const iter) (reg val) (reg env))
|
|
; (assign val (const ok))
|
|
;
|
|
; ;; call iter with the initial arguments
|
|
; (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)) ;; jump to entry of iter
|
|
; ;; primitive branch not taken
|
|
; primitive-branch5
|
|
; (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
|
|
; (goto (reg continue))
|
|
; after-call3
|
|
; after-lambda1
|
|
; ;; after definition of factorial
|
|
; (perform (op define-variable!) (const factorial) (reg val) (reg env))
|
|
; (assign val (const ok))
|
|
|
|
; The iterative procedure restores the continue register before the next
|
|
; recursive call to iter. This allows the based case to return directly to the
|
|
; original caller of factorial. The recursive implementation requires each call
|
|
; to return to the original to the previous caller which builds up the stack.
|
|
|
|
(display "[answered]\n")
|
|
|
|
|
|
(display "\nex-5.35 - reverse-engineer-compiled-procedure\n")
|
|
|
|
(compile-to-file
|
|
'(define (f x)
|
|
(+ x (g (+ x 2))))
|
|
'val 'next "f-reversed.sicp-asm")
|
|
(display "[ok]\n")
|
|
|
|
|
|
(display "\nex-5.36 - order-of-evaluation\n")
|
|
|
|
; The compiler produces code the evaluates in right-to-left order.
|
|
|
|
; To change the order to left-to-right we can remove the reverse from
|
|
; construct-arglist. We then have to construct the arglist with append instead
|
|
; of cons. That means we have to put the current arg val into a list and then
|
|
; call the append procedure. Consequently, the performance is worse because of
|
|
; the additional list instruction and because append is more expensive than
|
|
; cons.
|
|
|
|
; (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 val (op list) (reg val)) ;; ** left-to-right evaluation
|
|
; (assign argl (op append) (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))))))
|
|
|
|
(display "[answered]\n")
|
|
|
|
|
|
(display "\nex-5.37 - preserving-mechanism-evaluation\n")
|
|
|
|
; Uncomment the following code to compile a version with optimized and
|
|
; unoptimzed stack usage for a simple program.
|
|
|
|
(compile-to-file
|
|
'(+ 1 1)
|
|
'val 'next "f-add.scm")
|
|
|
|
;(define (preserving regs seq1 seq2)
|
|
; (if (null? regs)
|
|
; (append-instruction-sequences seq1 seq2)
|
|
; (let ((first-reg (car regs)))
|
|
; (if #t ; preserve all registers no matter what
|
|
; ; (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)))))
|
|
|
|
(compile-to-file
|
|
'(+ 1 1)
|
|
'val 'next "f-add-unoptimized-stack-usage.scm")
|
|
|
|
; $ diff f-add.scm f-add-unoptimized-stack-usage.scm
|
|
; 0a1,3
|
|
; > (save continue)
|
|
; > (save env)
|
|
; > (save continue)
|
|
; 1a5,11
|
|
; > (restore continue)
|
|
; > (restore env)
|
|
; > (restore continue)
|
|
; > (save continue)
|
|
; > (save proc)
|
|
; > (save env)
|
|
; > (save continue)
|
|
; 2a13
|
|
; > (restore continue)
|
|
; 3a15,17
|
|
; > (restore env)
|
|
; > (save argl)
|
|
; > (save continue)
|
|
; 4a19,20
|
|
; > (restore continue)
|
|
; > (restore argl)
|
|
; 5a22,23
|
|
; > (restore proc)
|
|
; > (restore continue)
|
|
; 12a31
|
|
; > (save continue)
|
|
; 13a33
|
|
; > (restore continue)
|
|
|
|
; Even for the simple program (+ 1 1) the stack-preserving-mechanism saves 20
|
|
; stack operations. Pretty impressive.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-5.38 - optimize-procedure-application\n")
|
|
|
|
(define (spread-arguments operand-list)
|
|
(define (compile-operands operand-list operand-number)
|
|
(cond
|
|
((null? operand-list) (empty-instruction-sequence))
|
|
((and (= operand-number 1))
|
|
(preserving
|
|
'(arg1)
|
|
(compile (car operand-list) 'arg1 'next)
|
|
(compile-operands (cdr operand-list) (+ operand-number 1))))
|
|
((and (= operand-number 2))
|
|
(preserving
|
|
'(arg1 arg2)
|
|
(compile (car operand-list) 'arg2 'next)
|
|
(compile-operands (cdr operand-list) (+ operand-number 1))))
|
|
(else
|
|
(error "Only two arg registers supported -- SPREAD-ARGUMENTS"))))
|
|
(let ((operand-codes (compile-operands operand-list 1)))
|
|
operand-codes))
|
|
|
|
(define (primitive-procedure? exp)
|
|
(define primitive-procedures '(= * - +))
|
|
(and (pair? exp)
|
|
(= (length exp) 3) ;; only support two args for now
|
|
(memq (car exp) primitive-procedures)
|
|
))
|
|
|
|
(define (compile-primitive-call op target linkage)
|
|
(end-with-linkage linkage
|
|
(make-instruction-sequence
|
|
'(arg1 arg2)
|
|
`(,target)
|
|
`((assign ,target (op ,op) (reg arg1) (reg arg2))))))
|
|
|
|
(define (compile-primitive exp target linkage)
|
|
(let ((proc-code (compile-primitive-call (operator exp) target linkage))
|
|
(operand-codes (spread-arguments (operands exp))))
|
|
(preserving '(env continue)
|
|
operand-codes
|
|
proc-code)))
|
|
|
|
(compile-to-file
|
|
'(define (factorial n)
|
|
(if (= n 1)
|
|
1
|
|
(* (factorial (- n 1)) n)))
|
|
'val 'next "factorial-opt.sicp-asm")
|
|
|
|
; c. The optimization saves 39 instructions
|
|
; λ symposium sicp → λ git master* → wc -l factorial.sicp-asm factorial-opt.sicp-asm
|
|
; 79 factorial.sicp-asm
|
|
; 40 factorial-opt.sicp-asm
|
|
; 119 total
|
|
|
|
(display "[answered]\n")
|
|
|