(in-package #:cc-bmir-to-blir)

;;; Transform an instruction. Called for effect.
(defgeneric reduce-instruction (instruction)
  ;; Default method: Do nothing.
  (:method ((instruction bir:instruction))))

(defmethod reduce-instruction ((primop bir:primop))
  (case (cleavir-primop-info:name (bir:info primop))
    ((cleavir-primop:car)
     (let ((in (bir:inputs primop))
           (nout (make-instance 'bir:output)))
       (change-class primop 'cc-blir:load :inputs ())
       (let ((mr (make-instance 'cc-blir:memref2
                   :inputs in :outputs (list nout)
                   :offset (- cmp:+cons-car-offset+ cmp:+cons-tag+)
                   :origin (bir:origin primop)
                   :policy (bir:policy primop))))
         (bir:insert-instruction-before mr primop)
         (setf (bir:inputs primop) (list nout)))))
    ((cleavir-primop:cdr)
     (let ((in (bir:inputs primop))
           (nout (make-instance 'bir:output)))
       (change-class primop 'cc-blir:load :inputs ())
       (let ((mr (make-instance 'cc-blir:memref2
                   :inputs in :outputs (list nout)
                   :offset (- cmp:+cons-cdr-offset+ cmp:+cons-tag+)
                   :origin (bir:origin primop)
                   :policy (bir:policy primop))))
         (bir:insert-instruction-before mr primop)
         (setf (bir:inputs primop) (list nout)))))
    ((cleavir-primop:rplaca)
     (let ((in (bir:inputs primop))
           (nout (make-instance 'bir:output)))
       (change-class primop 'cc-blir:store :inputs ())
       (let ((mr (make-instance 'cc-blir:memref2
                   :inputs (list (first in)) :outputs (list nout)
                   :offset (- cmp:+cons-car-offset+ cmp:+cons-tag+)
                   :origin (bir:origin primop)
                   :policy (bir:policy primop))))
         (bir:insert-instruction-before mr primop)
         (setf (bir:inputs primop) (list (second in) nout)))))
    ((cleavir-primop:rplacd)
     (let ((in (bir:inputs primop))
           (nout (make-instance 'bir:output)))
       (change-class primop 'cc-blir:store :inputs ())
       (let ((mr (make-instance 'cc-blir:memref2
                   :inputs (list (first in)) :outputs (list nout)
                   :offset (- cmp:+cons-cdr-offset+ cmp:+cons-tag+)
                   :origin (bir:origin primop)
                   :policy (bir:policy primop))))
         (bir:insert-instruction-before mr primop)
         (setf (bir:inputs primop) (list (second in) nout)))))))

(defun reduce-instructions (function)
  (bir:map-local-instructions #'reduce-instruction function))

(defun reduce-module-instructions (module)
  (cleavir-set:mapset nil #'reduce-instructions (bir:functions module)))
