;;; -*- Mode:LISP; Base:10; Readtable:CL; Package:HUNLA -*- ;;; (WHO-CALLS-INTERNAL SYMBOL) ;;; Returns a (new) alist of callers and keywords indicating how they are called, ;;; including :FUNCTION, :VARIABLE, :CONSTANT, and :MACRO-EXPANDED. ;;; ;;; (WHO-CALLS SYMBOL) prints it out nicely. ;;; (PRINT-WHO-CALLS-ITEM (CALLER-INFO &OPTIONAL (STREAM *STANDARD-OUTPUT*)) is a subroutine. ;;; ;;; (UPDATE-WHO-CALLS REMAKE-FROM-WORLD?) ;;; Sets up the database, optionally rebuilding it from scratch. ;;; Otherwise, processes outstanding update requests. ;;; Only one process at a time should call UPDATE-WHO-CALLS, which actually ;;; updates the database. The locking only allows people to access the ;;; database during updates; it does not support multiple updaters. ;;; Requests are PUSHed onto the *WHO-CALLS-QUEUE*. ;;; These are lists beginning with an keyword specifying the operation to be performed. ;;; The rest of the request's elements are arguments for the operation. ;;; ;;; ;;; +++TO DO: ;;; More analyzers ;;; COMPILER interface ;;; ZWEI interface ;;; Documented interface (change documentation, probably) ;;; IWBNI the compiler, when expanding macros, could somehow figure out which ones ;;; were really in the source code, and mark those specially on the debugging info. ;;; As it is now, who-calls a macro generates massive spurious results. (defvar *who-calls-area* (zl:make-area :name 'who-calls-area :gc :dynamic :room t) "Area for WHO-CALLS database.") (defparameter *who-calls-database-size* 1500.) (defvar *who-calls-database* nil "The WHO-CALLS database.") (defvar *who-calls-lock* nil "Keeps *WHO-CALLS-DATABASE* consistent during read-modify-write.") (defvar *who-calls-queue* nil) (defun who-calls-internal (symbol) (check-type symbol symbol) (unless *who-calls-database* (error "The WHO-CALLS database has not been initialized.")) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (copy-list (gethash symbol *who-calls-database*)))) (defmacro printing-package-names (&body body) `(let ((*package* nil)) ,@body)) (defun who-calls (symbol) (printing-package-names (let ((callers (who-calls-internal symbol))) (cond (callers (format t "~&Callers of ~S:" symbol) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (sort callers #'string-lessp :key #'(lambda (x) (si:get-pname (car x))))) (dolist (caller-info callers) (format t "~& ") (print-who-calls-item caller-info))) (t (format t "~&No callers of ~S found." symbol))))) (terpri) (values)) (defparameter *who-calls-descriptions* '((:function "function") (:macro-expanded "macro expanded") (:flavor "flavor definition") (:value "variable") (:constant "constant"))) (defun print-who-calls-item (caller-info &optional (stream *standard-output*)) (let ((caller-name (car caller-info))) (printing-package-names (format stream "~S (" caller-name) (let ((how (cdr caller-info)) (prev-flag nil)) ;; Print out the HOWs we know in a canonical order. (dolist (which-one *who-calls-descriptions*) (when (member (car which-one) how) (format stream "~:[~;, ~]~A" prev-flag (cadr which-one)) (setq prev-flag t))) ;; Then do the ones we never heard of. (dolist (x how) (when (not (assoc x *who-calls-descriptions*)) (format stream "~:[~;, ~]~S" prev-flag x) (setq prev-flag t)))) (write-string ")" stream)) caller-name)) ;;;; Update functions (defun update-who-calls (&key remake-from-world) (when (null *who-calls-database*) (si:without-interrupts (setq *who-calls-lock* nil *who-calls-database* (make-hash-table :test #'equal :size (si:pkg-good-size *who-calls-database-size*) :area *who-calls-area*)))) (cond (remake-from-world (setq *who-calls-lock* nil) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (clrhash *who-calls-database*) (setq *who-calls-queue* nil)) (si:report-elapsed-time t 0 "building the who-calls database" #'(lambda () (dolist (pkg (list-all-packages)) (do-symbols (s pkg) (analyze-symbol s #'record-caller-consing))))) (fresh-line) (break "- Ready to compact the database") (si:report-elapsed-time t 0 "cdr-coding the who-calls database" #'(lambda () (maphash #'copy-tree *who-calls-database*)))) (*who-calls-queue* (let (requests) (si:without-interrupts ;Gobble down the list of requests. (setq requests (reverse *who-calls-queue*) *who-calls-queue* nil)) (dolist (request requests) (case (first request) (:record-compiled-function (analyze-fef (second request) (third request) #'record-caller)) (:erase-compiled-function (analyze-fef (second request) (third request) #'erase-caller)))))))) ;;; The hash table is keyed by callee; each entry is an alist of callers ;;; telling how they are called. Entires are fully cdr-coded, and thrown ;;; away upon update. (defun record-caller (caller callee how) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (let ((si:default-cons-area *who-calls-area*) (alist (gethash callee *who-calls-database*))) (if (null alist) (setf (gethash callee *who-calls-database*) (list (list caller how))) (let ((known-caller (assoc caller alist))) (setf (gethash callee *who-calls-database*) (if known-caller (when (not (member how (cdr known-caller))) (append (delete known-caller alist) (list (append (list caller) (cdr known-caller) (list how))))) (append alist (list (list caller how)))))))))) ;;; Non-cdr-coded version (good for building initial database) (defun record-caller-consing (caller callee how) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (let ((si:default-cons-area *who-calls-area*) (alist (gethash callee *who-calls-database*))) (if (null alist) (setf (gethash callee *who-calls-database*) (acons caller (list how) nil)) (let ((known-caller (assoc caller alist))) (if known-caller (when (not (member how (cdr known-caller))) (rplacd known-caller (nconc (cdr known-caller) (list how)))) (rplacd alist (acons caller (list how) nil)))))))) (defun erase-caller (caller callee &rest ignore) (si:with-lock (*who-calls-lock* :whostate "Who Calls Lock") (let ((si:default-cons-area *who-calls-area*) (alist (gethash callee *who-calls-database*))) (when alist (let ((known-caller (assoc caller alist))) (when known-caller (setf (gethash callee *who-calls-database*) (delete known-caller alist)))))))) ;;;; Analysis routines (culled from the versions in ANALYZE) ;;; ANALYZE-SYMBOL is the toplevel analyzer. (defun analyze-symbol (symbol fun) (declare (sys:downward-funarg fun)) (when (and (fboundp symbol) (eq (symbol-function symbol) (si:follow-cell-forwarding (si:locf (symbol-function symbol)) t))) (let ((definition (symbol-function (si:unencapsulate-function-spec symbol)))) (typecase definition (compiled-function (analyze-fef symbol definition fun)) ;; +++ Add cases: FLAVOR, LIST (LAMBDA), SELECT-METHOD, CLOSURE, MACRO (?) ))) (when (and (symbol-plist symbol) (eq (symbol-plist symbol) (si:follow-cell-forwarding (si:locf (symbol-plist symbol)) t))) (when (get symbol 'si:flavor) (analyze-flavor symbol (get symbol 'si:flavor) fun)) (analyze-plist symbol (symbol-plist symbol) fun)) ;Check for any other random properties. ;; Values. (when (and (boundp symbol) (eq (symbol-value symbol) (si:follow-cell-forwarding (si:locf (symbol-value symbol)) t))) (analyze-list symbol (symbol-value symbol) fun) (when (get symbol 'si:initialization-list) (analyze-initialization symbol (symbol-value symbol) fun)))) (defun analyze-flavor (symbol flavor fun) (ignore symbol flavor fun)) ;+++ (defun analyze-plist (symbol plist fun) (ignore symbol plist fun)) ;+++ (defun analyze-list (symbol value fun) (ignore symbol value fun)) ;+++ (defun analyze-initialization (symbol &rest ignore) ;+++ (printing-package-names (format t "~&~S has property ~S  ~S" symbol 'si:initialization-list (get symbol 'si:initialization-list)))) ;+++ What about macro definitions on symbols? ;+++ How about pointers to files? ;+++ MISC instructions? ;+++ ADVICE (currently ignored) (defun analyze-fef (caller fef fun) (declare (sys:downward-funarg fun)) (do ((i si:%fef-header-length (1+ i)) (lim (si:%structure-boxed-size fef))) ((>= i lim) nil) (cond ((= (si:%p-ldb-offset si:%%q-data-type fef i) si:dtp-one-q-forward) ;; Reference to some function or value cell. (let* ((tem (si:%p-contents-as-locative-offset fef i)) (symbol (si:%find-structure-header tem)) (offset (si:%pointer-difference tem symbol))) (if (consp symbol) (setq symbol (car symbol))) (funcall fun caller symbol (ecase offset (2 :function) (1 :value))))) ((= (si:%p-ldb-offset si:%%q-data-type fef i) si:dtp-self-ref-pointer) (let ((fn (si:fef-flavor-name fef))) (when fn (multiple-value-bind (symbol use) (si:flavor-decode-self-ref-pointer fn (si:%p-ldb-offset si:%%q-pointer fef i)) (funcall fun caller symbol (if use :flavor :value)))))) ((eq (si:%p-contents-offset fef i) (si:debugging-info fef))) ;No further processing of such frobs. ((symbolp (si:%p-contents-offset fef i)) (funcall fun caller (si:%p-contents-offset fef i) ':constant)))) ;; Now analyze any internal functions that are part of this one. (loop for offset in (cdr (assoc ':internal-fef-offsets (si:debugging-info fef))) for i from 0 doing (analyze-fef caller (si:%p-contents-offset fef offset) fun)) ;; See if we called any macros. (dolist (macro (cadr (assoc ':macros-expanded (si:debugging-info fef)))) (funcall fun caller (if (atom macro) macro (car macro)) ':macro-expanded))) ;;;; Compiler Interface ;(si:advise compiler:compile :after 'update-who-calls nil ; (let* ((function-spec (first arglist)) ; (fef (if function-spec (si:fdefinition function-spec) (first values)))) ; (with-whostate "Who Calls" ; (analyze-fef function-spec ; fef))))