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

;;; Printing

(defmethod print-ir-inst (inst)
  (cond ((and (listp (inputs inst))
              (not (null (output inst))))
         (format t "  ~A ~A -> ~A~%" (class-name (class-of inst))
                 (inputs inst) (output inst)))
        (t
         (format t "  ~A~%" (class-name (class-of inst))))))

(defmethod print-ir-inst ((inst ir-assign))
  (format t "  ASSIGN ~A -> ~A~%" (input inst) (output inst)))

(defmethod print-ir-inst ((inst ir-test-equal))
  (format t "  ~A == ~A -> ~A~%" (first (inputs inst)) (second (inputs inst))
          (output inst)))

(defmethod print-ir-inst ((inst ir-call))
  (format t "  IR-CALL ~A ~A -> ~A~%" (callee inst) (inputs inst) (output inst)))

(defmethod print-ir-inst ((inst ir-if))
  (format t "  ~A ~A ~A~%" (class-name (class-of inst))
          (first (inputs inst)) (destinations inst)))

(defmethod print-ir-inst ((inst ir-terminator))
  (format t "  ~A ~A~%" (class-name (class-of inst)) (destinations inst)))

(defun print-iblock (iblock)
  (format t "~A:~%" (name iblock))
  (loop :for inst := (start iblock) :then (next inst)
        :do (print-ir-inst inst)
        :until (eql inst (end iblock))))

(defun print-iblocks (start-iblock)
  (loop :for iblock := start-iblock :then (next iblock)
        :until (null iblock)
        :do (print-iblock iblock)))

;;; Compilation setup

(defun fix-iblock-flow (iblock)
  (let ((reached '()))
    (labels
        ((fix (iblock prev)
           (unless (member iblock reached)
             (push iblock reached)
             (setf (next iblock)
                   (first (successors iblock))
                   (prev iblock) prev)
             (loop :for prev := iblock :then s
                   :for s :in (successors iblock)
                   :do (fix s prev)))))
      (fix iblock nil))))

(defmacro with-compilation-setup ((iblock builder &key add-return-p) &body body)
  `(let ((,iblock (make-instance 'iblock :name "toplevel" :program (make-instance 'ir-program)))
         (,builder (make-instance 'builder)))
     (build-begin ,builder ,iblock)
     (prog1
         (progn
           ,@body)
       (when ,add-return-p
         (build-insert-end (make-instance 'ir-return) ,builder))
       (fix-iblock-flow ,iblock))))

;;; Some quick example code

#+(or)
(with-input-from-string (source-stream "for x do 12 times
if x == 5 then
pixeldraw(x, x)
pixeldraw(x, sqrt(5))
pixeldraw(0, 0)
end
end")
  (let ((*token-stream* (make-token-stream (tokenize source-stream))))
    (let ((rb (with-compilation-setup (root-block builder)
                (compile-node (match-syntax program) builder)
                root-block)))
      (do-iblocks (ib rb)
        (optim-call-duplicate-args ib)
        (optim-remove-unused ib))
      (print-iblocks rb)
      rb)))