(load "misc/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")