ir1vis.lisp

#.(progn
    (ql:quickload '(:alexandria :cl-dot))
    '(ql:quickload '(:alexandria :cl-dot)))

;; TODO: look at http://metamodular.com/Rewrite/rewrite.html for inspiration

#|
digraph G {
compound=true;
subgraph cluster_foo {
1 [label="1 in foo"];

}
subgraph cluster_bar {
2 [label="2 in bar"];
}
1 -> 2 [ltail=cluster_foo,
lhead=cluster_bar];
}
|#

(cl:defpackage #:sb-ir1-visualization
  (:use
   #:cl
   #:cl-dot))

(cl:in-package #:sb-ir1-visualization)

;;; Utility functions

(defun list-no-nil (&rest args)
  (remove nil args))

(defun attributify-edge (object &rest attribute-plist)
  (make-instance 'attributed :object object
                 :attributes attribute-plist))

(defun boldify-edge (object &rest attribute-plist)
  (apply #'attributify-edge object
         :style :bold :weight 10000
         attribute-plist))

(defun color-edge (object color &rest attribute-plist)
  (apply #'attributify-edge object
         :color color
         attribute-plist))

;;; Graph class

(defclass ir1-graph ()
  ())

(defparameter *ctrans?* nil)
(defparameter *lvars?* nil)

;;;

(defmethod graph-object-node ((graph ir1-graph) (object null))
  nil)

#+no (defmethod graph-object-node :around ((graph ir1-graph) (object sb-c::node))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

#+no (defmethod graph-object-node :around ((graph ir1-graph) (object sb-c::ctran))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

#+no (defmethod graph-object-node :around ((graph ir1-graph) (object sb-c::cblock))
  (let ((node (call-next-method)))
    (values node (sb-c::block-number (sb-c::block-or-lose object)))))

;; COMPONENT
(defmethod graph-object-node ((graph ir1-graph) (object sb-c:component))
  (let ((label (format nil "Component ~A" (sb-c::component-name object))))
    (make-instance 'cl-dot::cluster :attributes `(:label ,label))))

(defmethod graph-object-contains #+no knows-of ((graph ir1-graph) (c sb-c:component))
  (list* (sb-c::component-head c)
         (sb-c::component-lambdas c)))

;; CBLOCK
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::cblock))
  (let ((label (format nil "Block ~A" (sb-c::block-number c))))
    (make-instance 'cl-dot::cluster :attributes `(:label ,label))))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::cblock))
  (mapcar #'boldify-edge (sb-c::block-succ c)))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::cblock))
  (append (sb-c::block-pred c)
          (sb-c::block-succ c)
          (sb-int:awhen (sb-c::block-component c) (list sb-int:it))
          (sb-int:awhen (sb-c::block-start c) (list sb-int:it))))

(defmethod graph-object-contained-by ((graph ir1-graph) (c sb-c::cblock))
  (sb-c::block-component c))

;; CLAMBDA
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::clambda))
  (let ((label (format nil "Lambda ~A" (sb-c::lambda-%source-name c))))
    (make-instance 'cl-dot::cluster :attributes `(:label ,label))))

(defmethod graph-object-contains ((graph ir1-graph) (c sb-c::clambda))
  (sb-c::lambda-vars c))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::clambda))
  (sb-c::lambda-vars c))

;; LAMBDA-VAR
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::lambda-var))
  (let ((label (format nil "Var ~A" (sb-c::lambda-var-%source-name c))))
    (make-instance 'node :attributes `(:label ,label))))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::lambda-var))
  #+no (sb-c::lambda-var-refs c))

;; CTRAN
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::ctran))
  (when *ctrans?*
    (let ((label (format nil "CTRAN ~D ~A"
                         (sb-c::cont-num c)
                         (sb-c::ctran-kind c))))
      (make-instance 'cl-dot::cluster :attributes `(:label ,label)))))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::ctran))
  (list-no-nil (sb-c::ctran-next c)))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::ctran))
  (list-no-nil #+no (sb-c::ctran-use c)))

(defmethod graph-object-contains ((graph ir1-graph) (c sb-c::ctran))
  (list-no-nil (sb-c::ctran-next c)))

(defmethod graph-object-contained-by ((graph ir1-graph) (c sb-c::ctran))
  (sb-c::ctran-block c))

;; NODE

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::node))
  (list-no-nil (sb-int:awhen (sb-c::node-next c)
                 (boldify-edge (if *ctrans?* sb-int:it (sb-c::ctran-next sb-int:it))))))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::node))
  (list-no-nil (sb-c::node-prev c)))

;; REF
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::ref))
  (make-instance 'node :attributes '(:label     "REF"
                                     :fillcolor "#ddffbb"
                                     :style     :filled
                                     :shape     :diamond)))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::ref))
  (append (call-next-method) (list-no-nil (sb-c::ref-lvar c))))

;; BIND
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::bind))
  (make-instance 'node :attributes `(:label ,"BIND")))

;; GLOBAL-VAR
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::global-var))
  (let ((label (format nil "GLOBAL-VAR\\n~A\\n~A"
                       (sb-c::global-var-%source-name c)
                       (sb-c::global-var-kind c))))
    (make-instance 'node :attributes `(:label ,label :shape :box))))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::global-var))
  (sb-c::global-var-refs c))

;; CONSTANT
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::constant))
  (let ((label (format nil "CONSTANT ~A"
                       #+nil (sb-c::lvar- source c)
                       (sb-c::constant-value c))))
    (make-instance 'node :attributes `(:label     ,label
                                       :style     :filled
                                       :fillcolor "#ffffe0"
                                       :shape     :box))))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::constant))
  (sb-c::constant-refs c))

;; ENTRY
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::entry))
  (make-instance 'node :attributes `(:label ,"ENTRY")))
;; cleanup

;; COMBINATION
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::basic-combination))
  (let ((label (format nil "~(~A~A ~A\\n~A~)"
                       (if (sb-c::node-tail-p c) "tail " "")
                       (sb-c::basic-combination-kind c)
                       (type-of c)
                       (sb-c::lvar-fun-name
                        (sb-c::basic-combination-fun c)))))
    (make-instance 'node :attributes `(:label     ,label
                                       :shape     :octagon
                                       :style     :filled
                                       :fillcolor "#ccffff"))))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::basic-combination))
  (append (call-next-method)
          (apply #'list-no-nil
                 (sb-int:awhen (sb-c::basic-combination-lvar c)
                   (attributify-edge sb-int:it :style :bold :color "#9999ff"))
                 (sb-int:awhen (sb-c::basic-combination-fun c)
                   (attributify-edge sb-int:it :style :bold :color "#0000ff"))
                 #+no (sb-c::basic-combination-args c)
                 '())))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::basic-combination))
  (append (call-next-method) (sb-c::basic-combination-args c)))

;; CIF
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::cif))
    (make-instance 'node :attributes '(:label "CIF")))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::cif))
  (list-no-nil #+no (sb-c::if-test c)
               (boldify-edge (sb-c::if-consequent c) :color "green")
               (boldify-edge (sb-c::if-alternative c) :color "red")))

(defmethod graph-object-pointed-to-by ((graph ir1-graph) (c sb-c::cif))
  (list-no-nil (sb-c::if-test c)))

;; CRETURN
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::creturn))
  (make-instance 'node :attributes '(:label "CRETURN")))

(defmethod graph-object-knows-of ((graph ir1-graph) (c sb-c::creturn))
  (append (call-next-method) (list-no-nil (sb-c::return-result c))))

;; EXIT
(defmethod graph-object-node ((graph ir1-graph) (c sb-ext:exit))
  (make-instance 'node :attributes '(:label "EXIT")))

#+no (defmethod graph-object-knows-of ((graph ir1-graph) (c sb-ext:exit))
  (list-no-nil (sb-c::exit- c)
               (sb-c::return-result c)))

;; CAST
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::cast))
  (let ((label (format nil "CAST\\n~A" (sb-c::cast-asserted-type c))))
    (make-instance 'node :attributes `(:label     ,label
                                       :style     :filled
                                       :fillcolor "#ffccff"))))

;; CSET
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::cset))
  (make-instance 'node :attributes '(:label "CSET")))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::cset))
  (append (call-next-method) (list-no-nil (sb-c::set-value c))))

;; LVAR
(defmethod graph-object-node ((graph ir1-graph) (c sb-c::lvar))
  (when *lvars?*
    (let* (#+no (combination-result-p (let ((use (sb-c::principal-lvar-use c)))
                                        (typep use 'sb-c::basic-combination)))
                (combination-fun-p (let ((dest (sb-c::lvar-dest c)))
                                     (and (typep dest 'sb-c::basic-combination)
                                          (eq (sb-c::basic-combination-fun dest) c))))
                (leaf (let ((ref (sb-c::lvar-uses c)))
                        (when (sb-c::ref-p ref)
                          (let ((leaf (sb-c::ref-leaf ref)))
                            (when (sb-c::leaf-has-source-name-p leaf)
                              (sb-c::leaf-source-name leaf))))))
                (label (format nil "~A ~A"
                               (cond
                                 (combination-fun-p "FUN LVAR")
                                 (t "LVAR"))
                               leaf)))
      (make-instance 'node :attributes `(:label     ,label
                                                    :style     :filled
                                                    :fillcolor "#ffcc99"
                                                    :shape     :hexagon)))))

(defmethod graph-object-points-to ((graph ir1-graph) (c sb-c::lvar))
  (let ((dest (sb-c::lvar-dest c)))
    (mapcar (lambda (o) (attributify-edge o :color "brown" :weight 0))
            (list-no-nil dest)))        ; TODO color
  #+nil
  (cond
    ((typep dest 'sb-c::basic-combination)
     (if (member c (sb-c::basic-combination-args dest))
         nil
         (list-no-nil (sb-c::lvar-dest c))))
    (t (list-no-nil (sb-c::lvar-dest c))))
  )

(defmethod graph-object-pointed-to-by ((graph ir1-graph) (c sb-c::lvar))
  (let ((uses (sb-c::lvar-uses c)))
    (remove-if (lambda (x) (typep x 'sb-c::basic-combination))
               (if (listp uses)
                   uses
                   (list-no-nil uses)))))

;;;

(defun graph-component (component)
  (let ((graph (generate-graph-from-roots (make-instance 'ir1-graph) (list component)
                                          '(:compound t ; TODO automate compound in cl-dot?
                                            :rankdir "LR"))))
    (cl-dot:print-graph graph)
    (cl-dot:dot-graph graph "/tmp/graph.png" :format :png)))

(unwind-protect
     (progn
       (trace sb-c::ir1-phases :print (block nil
                                        (handler-bind
                                            ((error (lambda (c)
                                                      (princ c)
                                                      (terpri)
                                                      (sb-debug:print-backtrace)
                                                      (break)
                                                      (return-from nil))))
                                          (graph-component (sb-debug:arg 0)))))
       (compile nil '(lambda (x) (when (integerp x) (setf x (1+ x))))))
  (untrace))