(in-package #:user-side-compiler)

(defclass ir-inline (ir-inst) ())

(defclass ir-inline-bitand (ir-inline ir-operation) ())
(defclass ir-inline-bitxor (ir-inline ir-operation) ())

(defparameter *inline-functions*
  '(("bitand" . ir-inline-bitand)
    ("bitxor" . ir-inline-bitxor)))

(defun optim-inline (start-iblock)
  (do-iblocks (iblock start-iblock)
    (do-instructions (inst iblock)
      (when (typep inst 'ir-call)
        (let ((inline-equivalent (cdr (assoc (name (callee inst))
                                             *inline-functions*
                                             :test #'string-equal))))
          (unless (null inline-equivalent)
            (let* ((inputs (inputs inst))
                   (output (output inst)))
              (setf (inputs inst) '()
                    (output inst) nil)
              (let ((new (make-instance inline-equivalent
                                        :source (source inst)
                                        :inputs inputs
                                        :output output)))
                (insert-instruction-above new inst)
                (delete-instruction inst)
                (setf inst new))))))))
  (print-iblocks start-iblock))

(defun optim-reuse-temporary-slots (start-iblock allocations)
  (let ((free '()))
    (do-iblocks (iblock start-iblock)
      (do-instructions (inst iblock)
        (let ((ending (find inst allocations
                            :key (alexandria:compose #'last-use
                                                     #'data)))
              (beginning (find (output inst) allocations :key #'data)))
          (cond ((and ending
                      (eql (strategy ending) :temporary-variable)
                      (not (null (varvec-index ending))))
                 (pushnew (varvec-index ending) free))
                ((and beginning
                      (eql (strategy beginning) :temporary-variable)
                      (not (null (varvec-index beginning)))
                      (not (null free)))
                 (setf (varvec-index beginning) (pop free)))))))))

(defun optim-prepare-direct-instructions (iblock)
  (do-instructions (inst iblock)
    (when (typep inst 'ir-operation)
      (assert (= (length (inputs inst)) 2))
      (destructuring-bind (accumulator operand)
          (inputs inst)
        (when (typep (definition accumulator) '(or ir-fetchvar ir-getconst))
          (move-instruction-above (definition accumulator) inst))
        (when (typep (definition operand) '(or ir-fetchvar ir-getconst))
          (when (typep (definition operand) 'ir-fetchvar)
            (setf (inputs inst)
                  (substitute (input (definition operand)) operand
                              (inputs inst))))
          (delete-instruction (definition operand)))))))

(defparameter *operation-routines*
  '((ir-mult . "mult")
    (ir-div . "div")))

(defun pre-assembly-software-operations (start-iblock)
  (do-iblocks (ib start-iblock)
    (do-instructions (inst ib)
      (when (member (type-of inst) *operation-routines* :key #'car)
        (let ((inputs (inputs inst))
              (output (output inst))
              (implementation (get-asm-function
                               (cdr (assoc (type-of inst)
                                           *operation-routines*)))))
          (setf (inputs inst) '()
                (output inst) nil)
          (let ((new (make-instance 'ir-call
                                    :callee implementation
                                    :inputs inputs :output output)))
            (insert-instruction-above new inst)
            (delete-instruction inst)
            ;; To ensure that the code walking continues correctly
            (setf inst new)))))))

(defun pre-assembly (iblock)
  (pre-assembly-software-operations iblock)
  (optim-inline iblock)
  (do-iblocks (ib iblock)
    (optim-prepare-direct-instructions ib))
  (let ((allocs (allocate-values iblock)))
    (optim-reuse-temporary-slots iblock allocs)
    allocs))