xref call-tree

xref.lisp

(defun call-tree (function output-file &optional allow-packages)
  (with-open-file (stream output-file :if-exists :supersede
                                      :if-does-not-exist :create
                                      :direction :output)
    (write-line "digraph G {" stream)
    (write-line "node [fontname = \"monospace\"];" stream)
    (write-line "node [shape=box];" stream)
    (let ((id 0)
          (ids (make-hash-table :test #'eq))
          (allow-packages (mapcar #'find-package allow-packages)))
      (labels ((id (fun)
                 (or (gethash fun ids)
                     (setf (gethash fun ids) (incf id))))
               (output (fun)
                 (let* ((name (sb-kernel:%fun-name fun))
                        (package (symbol-package 
                                  (if (consp name)
                                      (second name)
                                      name))))
                   (cond ((and (or (eq package (find-package :cl))
                                   (sb-int:system-package-p package))
                               (not (member package allow-packages)))
                          nil)
                         ((member name '(sb-pcl::intern-pv-table sb-pcl::make-method-call
                                         sb-pcl::set-fun-name sb-pcl::get-pv sb-mop:method-function))
                          nil)
                         ((gethash fun ids))
                         (t
                          (format stream "~a [label = \"~a\"];~%" (id fun) name)
                          (loop for callee in (sb-introspect:find-function-callees fun)
                                do
                                (when 
                                    (output callee)
                                  (format stream "~a -> ~a;~%" (id fun) (id callee))))
                          t)))))
        (output function)))
    (write-line "}" stream)))