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

;;; This is typically called a register allocator, but since the only real
;;; registers we're working with are special purpose, and there's some special
;;; 6502-related nonsense going on as well, it feels better to call it a value
;;; allocator instead.

(defun calls-exist-between-p (start end)
  (cond ((eql start end)
         nil)
        ((typep start 'ir-call)
         start)
        ((null start)
         (error "Calls check crossed iblock boundary. This should not happen."))
        (t
         (calls-exist-between-p (next start) end))))

(defclass value-allocation ()
  ((%data :accessor data :initarg :data)
   (%strategy :accessor strategy :initform :temporary-variable)
   (%varvec-index :accessor varvec-index :initform nil)))

(defmethod choose-allocation-strategy ((alc value-allocation))
  (setf
   (strategy alc)
   (let ((data (data alc)))
     (cond ((null (users data))
            :do-not-save)
           ((typep data 'ir-constant)
            :constant)
           ((typep data 'ir-variable)
            :named-variable)
           ((and (eql (next (definition data)) (last-use data))
                 (not (typep (last-use data) 'ir-call)))
            :accumulator)
           ((and (not (typep data 'ir-reusable))
                 (typep (last-use data) 'ir-call)
                 (not (calls-exist-between-p (definition data) (last-use data))))
            :direct-to-argvec)
           (t
            :temporary-variable)))))

(defun allocate-values (start-iblock)
  (compute-lifetime-knowledge start-iblock)
  (let ((allocations '()))
    (do-iblocks (iblock start-iblock)
      (do-instructions (inst iblock)
        (unless (or (null (output inst))
                    (find (output inst) allocations :key #'data))
          (let ((allocation (make-instance 'value-allocation :data (output inst))))
            (choose-allocation-strategy allocation)
            (push allocation allocations)))))
    (setf allocations (nreverse allocations))
    (let ((counter -1)
          (named (remove :named-variable allocations
                         :test-not #'eql :key #'strategy))
          (temporary (remove :temporary-variable allocations
                         :test-not #'eql :key #'strategy)))
      (loop :for allocation :in (append named temporary)
            :do (setf (varvec-index allocation) (incf counter))))
    allocations))