;;;;COMPILER FROM SECTION 5.5 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS

;;;;Matches code in ch5.scm

;;;;This file can be loaded into Scheme as a whole.
;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
;;;;  from section 4.1.2
;;;;  You may need to change the (load ...) expression to work in your
;;;;  version of Scheme.

;;;;Then you can compile Scheme programs as shown in section 5.5.5

;;**implementation-dependent loading of syntax procedures
(load "shared/sicp-syntax.scm")			;section 4.1.2 syntax procedures


;;;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))
        ((primitive-procedure? exp)
         (compile-primitive 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 '() '() '()))

;; Implemented in 5.38.
(define (primitive-procedure? exp) #f)

;;;SECTION 5.5.2

;;;linkage code

(define (compile-linkage linkage)
  (cond ((eq? linkage 'return)
         (make-instruction-sequence '(continu) '()
          '(("    goto *continu;"))))
        ((eq? linkage 'next)
         (empty-instruction-sequence))
        (else
         (make-instruction-sequence '() '()
          `(("    goto " ,linkage ";"))))))

(define (end-with-linkage linkage instruction-sequence)
  (preserving '(continu)
   instruction-sequence
   (compile-linkage linkage)))


;;;simple expressions

(define (compile-self-evaluating exp target linkage)
  (cond ((number? exp)
          (end-with-linkage linkage
           (make-instruction-sequence '() (list target)
            `(("    " ,target " = const_i32(" ,exp ");")))))
        (else (error "SELF-EVAL -- unsupported type" 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)
    `(("    "
       ,target " " = " " lookup_variable_value
        "(" "\"" ,exp "\"" ", " 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)
       `(("    " ,target " = define_variable(\"" ,var "\", val, env);")
         ))))))


;;;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 'truebranch))
        (f-branch (make-label 'falsebranch))
        (after-if (make-label 'afterif)))
    (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 continu)
         p-code
         (append-instruction-sequences
          (make-instruction-sequence '(val) '()
           `(("    if(is_false(val))")
             ("        goto " ,f-branch ";")
             ("    goto " ,t-branch ";")
             ))
          (parallel-instruction-sequences
           (append-instruction-sequences
             (make-instruction-sequence '() '() `((,t-branch ":")))
             c-code)
           (append-instruction-sequences
             (make-instruction-sequence '() '() `((,f-branch ":")))
             a-code))
          (make-instruction-sequence '() '() `((,after-if ":")))
          ))))))

;;; sequences

(define (compile-sequence seq target linkage)
  (if (last-exp? seq)
      (compile (first-exp seq) target linkage)
      (preserving '(env continu)
       (compile (first-exp seq) target 'next)
       (compile-sequence (rest-exps seq) target linkage))))

;;;lambda expressions

(define (compile-lambda exp target linkage)
  (let ((proc-entry (make-label 'entry))
        (after-lambda (make-label 'afterlambda)))
    (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)
          `(("    " ,target " = make_compiled_proc(&&" ,proc-entry ", env);"))))
        (compile-lambda-body exp proc-entry))
       (make-instruction-sequence '() '() `((,after-lambda ":")))))))

(define (compile-lambda-body exp proc-entry)
  (define (formals-to-string formals)
    (if (null? formals)
      ""
      (string-append
        "\""
        (string-append
          (symbol->string (car formals))
          (string-append
            "\", "
            (formals-to-string (cdr formals)))))))
  (let ((formals (lambda-parameters exp))
        (argv (make-label 'argv)))
    (append-instruction-sequences
     (make-instruction-sequence '(env proc argl) '(env)
      `(
        (,proc-entry ":")
        ("    env = proc->env;")
        ("    const char *" ,argv "[] = {" ,(formals-to-string formals) "};")
        ("    env = extend_environment(" ,argv ", argl, env);")
        ))
        ;("    env = extend_environment(" (const ,formals) ", argl, 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 continu)
     proc-code
     (preserving '(proc continu)
      (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)
         '(("    argl = NULL;")))
        (let ((code-to-get-last-arg
               (append-instruction-sequences
                (car operand-codes)
                (make-instruction-sequence '(val) '(argl)
                 '(("    argl = cons(val, NULL);"))))))
          (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)
           `(("    argl = cons(val, 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 'primitivebranch))
        (compiled-branch (make-label 'compiledbranch))
        (after-call (make-label 'aftercall)))
    (let ((compiled-linkage
           (if (eq? linkage 'next) after-call linkage)))
      (append-instruction-sequences
       (make-instruction-sequence '(proc) '()
        `(("    if (" primitive_procedure "(proc) == 1)")
          ("        goto " ,primitive-branch ";")
          ("    goto " ,compiled-branch ";")))
       (parallel-instruction-sequences
        (append-instruction-sequences
         (make-instruction-sequence '() '() `((,compiled-branch ":")))
         (compile-proc-appl target compiled-linkage))
        (append-instruction-sequences
         (make-instruction-sequence '() '() `((,primitive-branch ":")))
         (end-with-linkage linkage
          (make-instruction-sequence '(proc argl)
                                     (list target)
           `(("    val = (*proc->primitive_procedure)(argl);"))))))
       (make-instruction-sequence '() '() `((,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
           `(("    continu = &&" ,linkage ";")
             ("    " entry " = " compiled_procedure_entry "(proc);")
             ("    goto *entry;"))))
        ((and (not (eq? target 'val))
              (not (eq? linkage 'return)))
         (let ((proc-return (make-label 'proc-return)))
           (make-instruction-sequence '(proc) all-regs
            `((assign continu (label ,proc-return))
              (assign val (op compiled_procedure_entry)
                          (reg proc))
              ("    goto " (reg val) "// FOO2")
              ,proc-return
              (assign ,target (reg val))
              ("    goto " (label ,linkage) "; // FOO1")))))
        ((and (eq? target 'val) (eq? linkage 'return))
         (make-instruction-sequence '(proc continu) all-regs
          '(("    entry = compiled_procedure_entry(proc);")
            ("    goto *entry;")
            )))
        ((and (not (eq? target 'val)) (eq? linkage 'return))
         (error "return linkage, target not val -- COMPILE"
                target))))

;; footnote
(define all-regs '(env proc val argl continu))


;;;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 ", " ,first-reg "_stack);"))
                      (statements seq1)
                      `(("    " ,first-reg " = restore(" ,first-reg "_stack);"))))
             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))))

'(COMPILER LOADED)