(define-library (csc codegen)
  (export cps->bytecode)
  (import (scheme base)
          (prefix (csc gensym) gensym.)
          (prefix (csc ir) ir.)
          (prefix (csc list) list.)
          (prefix (csc map) map.))
  (import (scheme write))
  (begin


    (define (const? x)
      (or (ir.const? x)
          (ir.void? x)
          (ir.label? x)))


    (define (const->bytecode atom)
      (cond
        ((ir.const? atom)
          (let ((x (ir.const-val atom)))
            (cond
              ((and (integer? x)
                    (> x (- (expt 2 30) 1)))  ; out of range for a small int
                (error "I don't support big ints yet"))
              ((or (integer? x)
                   (boolean? x)
                   (null? x))
                (list 'const x))
              (else (error "Only small ints and bool constants are supported for now" x)))))
        ((ir.void? atom)
          'void)
        ((ir.label? atom)
          (list 'label (gensym.gensym->int (ir.label-var atom))))
        (else (error "unexpected form in const->bytecode" atom))))


    (define (atom->bytecode atom translate)
      (if (gensym.gensym? atom)
        (translate atom)
        (const->bytecode atom)))


    (define *temp-reg* 255)


    ; https://en.wikipedia.org/wiki/Topological_sorting
    (define (topological-sort g)
      (define s
        (list.filter
          (lambda (x) (not (memv x (map cdr g))))
          (map car g)))
      (let loop ((s s)
                 (g g))
        (if (null? s)
          (if (null? g)
            '()
            (let ((n (caar g)))
              (cons (list 'mov (list 'local *temp-reg*) (list 'local n))
                (loop (list n)
                  (map
                    (lambda (p)
                      (if (= n (cdr p))
                        (cons (car p) *temp-reg*)
                        p))
                    g)))))
          (let ((n (car s))
                (s (cdr s)))
            (define g* (list.filter (lambda (p) (not (= n (car p)))) g))
            (cond
              ((assv n g) => (lambda (p)
                (define m (cdr p))
                (cons (list 'mov (list 'local n) (list 'local m))
                  (if (list.any (lambda (p) (= m (cdr p))) g*)
                    (loop s g*)
                    (loop (cons m s) g*)))))
              (else (loop s g*)))))))


    (define (check-primop-args op args vals conts)
      (unless (and (= args (length (ir.primop-args op)))
                   (= vals (length (ir.primop-vals op)))
                   (= conts (length (ir.primop-ks op))))
        (error "wrong number of arguments passed to primop" op)))


    (define (convert-cexpr expr translate)
      (define (a->b atom)
        (atom->bytecode atom translate))
      (cond
        ((ir.apply? expr)
          (let ((args (cons (ir.apply-func expr) (ir.apply-args expr))))
            (define constants
              (let loop ((args args)
                         (i 0))
                (if (null? args)
                  '()
                  (let ((x (car args)))
                    (if (const? x)
                      (cons (list 'mov (list 'local i) (const->bytecode x))
                        (loop (cdr args) (+ 1 i)))
                      (loop (cdr args) (+ 1 i)))))))
            (define g
              (let loop ((args args)
                         (i 0)
                         (g '()))
                (if (null? args)
                  g
                  (let ((x (car args)))
                    (define y (translate x))
                    (if (and (gensym.gensym? x) (not (= y i)))
                      (loop (cdr args) (+ 1 i)
                        (cons (cons i y) g))
                      (loop (cdr args) (+ 1 i) g))))))
            (append
              constants
              (topological-sort g)
              (list (list 'jmp (list 'local 0))))))
        ((and (ir.primop? expr) (symbol=? 'exit (ir.primop-name expr)))
          (unless (= 1 (length (ir.primop-args expr)))
            (error "wrong number of arguments passed to primop" expr))
          (list (list 'exit (atom->bytecode (car (ir.primop-args expr)) translate))))
        ((and (ir.primop? expr)
              (memq (ir.primop-name expr)
                '(peek
                  cons)))
          (check-primop-args expr 2 1 1)
          (cons
            (list 'peek (a->b (car (ir.primop-vals expr)))
                        (a->b (car (ir.primop-args expr)))
                        (a->b (cadr (ir.primop-args expr))))
            (convert-cexpr (car (ir.primop-ks expr)) translate)))
        (else (error "unexpected form in convert-cexpr" expr))))


    (define (make-translate args)
      (define m (map.empty -))
      (define next-local 0)
      (define (translate x)
        (if (gensym.gensym? x)
          (let ((n (gensym.gensym->int x)))
            (or (map.lookup m n #f)
                (let ((l next-local))
                  (set! m (map.insert m n l))
                  (set! next-local (+ 1 l))
                  l)))
          x))
      (for-each translate args)
      translate)


    (define (cps->bytecode expr)
      (apply append
        (convert-cexpr (ir.letrec-body expr) (make-translate '()))
        (map
          (lambda (p)
            (define name (car p))
            (define func (cdr p))
            (cons (const->bytecode name)
              (convert-cexpr (ir.lambda-body func) (make-translate (ir.lambda-vars func)))))
          (ir.letrec-funcs expr))))))