rewrite.lisp

(in-package #:cleavir-bir-transformations)

(defgeneric compute-ctype (datum system))

(defvar *derived-ctypes*)

(defun ctype (datum system)
  (or (gethash datum *derived-ctypes*)
      (progn (compute-ctype datum system)
             (multiple-value-bind (ctype presentp)
                 (gethash datum *derived-ctypes*)
               (unless presentp
                 (error "BUG: compute-ctype did not do its job on ~a"
                        datum))
               ctype))))

(defun ctyper (system) (lambda (datum) (ctype datum system)))

(defgeneric update-ctype (new-ctype datum system)
  (:argument-precedence-order datum system new-ctype))
(defmethod update-ctype (new-ctype (datum cleavir-bir:ssa) system)
  (declare (ignore system))
  (multiple-value-bind (old-ctype presentp) (gethash datum *derived-ctypes*)
    (if presentp
        (error "BUG: Doubly defined ctype for ~a - new ~a old ~a"
               datum new-ctype old-ctype)
        (setf (gethash datum *derived-ctypes*) new-ctype))))
(defmethod update-ctype (new-ctype (datum cleavir-bir:datum) system)
  (multiple-value-bind (old-ctype presentp) (gethash datum *derived-ctypes*)
    (setf (gethash datum *derived-ctypes*)
          (if presentp
              (cleavir-ctype:disjoin system old-ctype new-ctype)
              new-ctype))))
;; Incorporate declarations                                                                                                                                         
(defmethod update-ctype :around (new-ctype (datum cleavir-bir:datum) system)
  #+(or)                                                                                                                                                            
  (if (cleavir-bir:ctyped-p datum)                                                                                                                                  
      (format t "~&~a Declared as ~a~%" datum (cleavir-bir:ctype datum))                                                                                            
      (format t "~&~a undeclared~%" datum))
  (if (cleavir-bir:ctyped-p datum)
      (call-next-method (cleavir-ctype:conjoin system
                                               (cleavir-bir:ctype datum)
                                               new-ctype)
                        datum system)
      (call-next-method)))

(defmethod compute-ctype ((datum cleavir-bir:constant) system)
  (update-ctype
   (cleavir-ctype:member system (cleavir-bir:constant-value datum))
   datum system))

(defgeneric propagate (instruction system))

(defmethod compute-ctype ((datum cleavir-bir:datum) system)
  (cleavir-set:mapset
   nil
   (lambda (definition) (propagate definition system))
   (cleavir-bir:definitions datum)))
(defmethod compute-ctype ((datum cleavir-bir:ssa) system)
  (propagate (cleavir-bir:definition datum) system))
(defmethod compute-ctype ((datum cleavir-bir:argument) system)
  (update-ctype (cleavir-ctype:top system) datum system))
(defmethod compute-ctype ((datum cleavir-bir:immediate) system)
  (update-ctype (cleavir-ctype:top system) datum system))

(defmethod propagate :around ((instruction cleavir-bir:computation) system)
  (update-ctype (call-next-method) instruction system))
(defmethod propagate :around ((instruction cleavir-bir:operation) system)
  (multiple-value-call
      (lambda (&rest ctypes)
        (loop for ctype in ctypes
              for output in (cleavir-bir:outputs instruction)
              do (update-ctype ctype output system)))
    (call-next-method)))

(defmethod propagate ((instruction cleavir-bir:computation) system)
  (cleavir-ctype:top system))
(defmethod propagate ((instruction cleavir-bir:operation) system)
  (values-list (loop repeat (length (cleavir-bir:outputs instruction))
                     collect (cleavir-ctype:top system))))

(defmethod propagate ((instruction cleavir-bir:enclose) system)
  ;; generic function type                                                                                                                                          
  (cleavir-ctype:function nil nil (cleavir-ctype:top system) nil nil nil
                          (cleavir-ctype:coerce-to-values
                           (cleavir-ctype:top system)
                           system)
                          system))

(defmethod propagate ((instruction cleavir-bir:writevar) system)
  (ctype (first (cleavir-bir:inputs instruction)) system))
(defmethod propagate ((instruction cleavir-bir:readvar) system)
  (ctype (first (cleavir-bir:inputs instruction)) system))

(defmethod propagate ((instruction cleavir-bir:abstract-call) system)
  (cleavir-ctype:function-returns (ctype (cleavir-bir:callee instruction)
                                         system)
                                  system))

(defmethod propagate ((instruction cleavir-bir:unwind) system)
  (values-list (mapcar (ctyper system) (rest (cleavir-bir:inputs instruction)))))

(defmethod propagate ((instruction cleavir-bir:jump) system)
  (values-list (mapcar (ctyper system) (cleavir-bir:inputs instruction))))

(defmethod propagate ((instruction cleavir-bir:fixed-to-multiple) system)
  (cleavir-ctype:values
   (mapcar (ctyper system) (cleavir-bir:inputs instruction))
   nil
   (cleavir-ctype:bottom system)
   system))

(defmethod propagate ((instruction cleavir-bir:multiple-to-fixed) system)
  (values-list
   (loop with inp-ct = (cleavir-ctype:coerce-to-values
                        (ctype (first (cleavir-bir:inputs instruction)) system)
                        system)
         with required = (cleavir-ctype:values-required inp-ct system)
         with optional = (cleavir-ctype:values-optional inp-ct system)
         with rest = (cleavir-ctype:values-rest inp-ct system)
         repeat (length (cleavir-bir:outputs instruction))
         collect (if (null required)
                     (if (null optional)
                         rest
                         (pop optional))
                     (pop required)))))

(in-package #:cleavir-bir-transformations)

(defun maybe-rewrite-call (call)
  (loop for transform in (cleavir-bir:transforms call)
        when (funcall transform call)
          do (format t "~&Transformed!~%")
          return t))

(defun rewrite-calls (ir)
  (let ((*derived-ctypes* (make-hash-table :test #'eq)))
    (cleavir-bir:map-instructions
     (lambda (inst)
       (when (typep inst 'cleavir-bir:call)
         (maybe-rewrite-call inst)))
     ir)))

(in-package #:cleavir-bir-transformations)

(defun car->primop-car (call)
  (let ((callee (cleavir-bir:callee call))
        (arguments (rest (cleavir-bir:inputs call)))
        (cleavir-bir:*origin* (cleavir-bir:origin call))
        (cleavir-bir:*policy* (cleavir-bir:policy call)))
    (let ((cons (first arguments)))
      (when (and (null (rest arguments))
                 (cleavir-ctype:subtypep (ctype cons clasp-cleavir::*clasp-system*)
                                         'cons
                                         clasp-cleavir::*clasp-system*))
        (let ((ftm (make-instance 'cleavir-bir:fixed-to-multiple)))
          (cleavir-bir:insert-instruction-before ftm call)
          (cleavir-bir:replace-uses ftm call)
          (cleavir-bir:delete-computation call)
          (cleavir-bir:delete-computation callee)
          (let ((car (make-instance 'cleavir-bir:vprimop
                       :inputs (list cons)
                       :info (cleavir-bir:primop-info 'cleavir-primop:car))))
            (cleavir-bir:insert-instruction-before car ftm)
            (setf (cleavir-bir:inputs ftm) (list car))
            (when (and (not (cleavir-bir:unused-p ftm))
                       (typep (cleavir-bir:use ftm)
                              'cleavir-bir:multiple-to-fixed))
              (cleavir-bir:delete-transmission ftm (cleavir-bir:use ftm)))))
        t))))