Giannandrea Castaldi g.castal@tiscali.it writes:
Any suggestion?
You have to enable xref recording by setting c:*record-xref-info* to T.
The xref support in CMUCL is a bit experimental and the information is only stored in memory and not in fasls files, i.e., xref info is only available if you compile the file in the same session.
In case someone wants to improve the situation, below is some code to dump the xref tables to fasl files. You have to compile and load the patch with xref-recording and package locks disabled. I haven't used it very much and it may well break some things.
Helmut.
(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute) (assert (not c:*record-xref-info*)))
(in-package :c)
;; xref := (kind from location to)
;;; should be in main.lisp
(defun sub-compile-file (info &optional d-s-info) (declare (type source-info info)) (with-ir1-namespace (let* ((*block-compile* *block-compile-argument*) (start-errors *compiler-error-count*) (start-warnings *compiler-warning-count*) (start-notes *compiler-note-count*) (*package* *package*) (*initial-package* *package*) (*initial-cookie* *default-cookie*) (*initial-interface-cookie* *default-interface-cookie*) (*default-cookie* (copy-cookie *initial-cookie*)) (*default-interface-cookie* (copy-cookie *initial-interface-cookie*)) (*lexical-environment* (make-null-environment)) (*converting-for-interpreter* nil) (*source-info* info) (*compile-file-pathname* nil) (*compile-file-truename* nil) (*top-level-lambdas* ()) (*pending-top-level-lambdas* ()) (*compiler-error-bailout* #'(lambda () (compiler-mumble "~2&Fatal error, aborting compilation...~%") (return-from sub-compile-file :error))) (*current-path* nil) (*last-source-context* nil) (*last-original-source* nil) (*last-source-form* nil) (*last-format-string* nil) (*last-format-args* nil) (*last-message-count* 0) (*info-environment* (or (backend-info-environment *backend*) *info-environment*)) (*gensym-counter* 0) (xref::*who-calls* (make-hash-table :test #'eq)) (xref::*who-is-called* (make-hash-table :test #'eq)) (xref::*who-references* (make-hash-table :test #'eq)) (xref::*who-binds* (make-hash-table :test #'eq)) (xref::*who-sets* (make-hash-table :test #'eq)) (xref::*who-macroexpands* (make-hash-table :test #'eq)) (*macroexpand-hook* (lambda (fn form env) (when (or (not env) (not (lexenv-lambda env))) (let ((cxt (xref:make-xref-context :name :toplevel))) (setf (xref::xref-context-source-path cxt) (or (cddr (gethash form *source-paths*)) *current-path*)) (xref:register-xref :macroexpands (car form) cxt))) (funcall fn form env)))) (with-debug-counters (clear-stuff) (with-compilation-unit () (process-sources info)
(finish-block-compilation) (compile-top-level-lambdas () t) (let ((object *compile-object*)) (etypecase object (fasl-file (fasl-dump-source-info info object) (fasl-dump-xref-info object xref::*who-calls* xref::*who-macroexpands* xref::*who-references* xref::*who-binds* xref::*who-sets*)) (core-object (fix-core-source-info info object d-s-info)) (null)))
(cond ((> *compiler-error-count* start-errors) :error) ((> *compiler-warning-count* start-warnings) :warning) ((> *compiler-note-count* start-notes) :note) (t nil)))))))
;;; should be in dump.lisp
(defun fasl-dump-xref-info (file who-calls who-macroexpands who-references who-binds who-sets) (flet ((htab-vector (htab) (let ((vector (make-array (* 2 (hash-table-count htab)))) (i 0)) (maphash (lambda (key list) (setf (aref vector i) key) (setf (aref vector (incf i)) (mapcar (lambda (c) (vector (xref::xref-context-name c) (namestring (xref::xref-context-file c)) (xref::xref-context-source-path c))) list)) (incf i)) htab) vector))) (let ((htabs (list who-calls who-macroexpands who-references who-binds who-sets))) (dump-object 'xref::merge-xref-info-from-fasl-file file) (dump-object (mapcar #'htab-vector htabs) file) (dump-fop 'lisp::fop-funcall-for-effect file) (dump-byte 1 file) )))
(in-package :xref)
;;; should be in xref.lisp
(defun database-for-type (type) (ecase type (:calls *who-calls*) (:called *who-is-called*) (:references *who-references*) (:binds *who-binds*) (:sets *who-sets*) (:macroexpands *who-macroexpands*)))
(defun register-xref (type target context) (declare (type xref-context context)) (format *debug-io* "; Registering xref[~S]: ~S -> ~S~%" type (xref-context-name context) target) (let ((database (database-for-type type))) (if (gethash target database) (pushnew context (gethash target database) :test 'equal) (setf (gethash target database) (list context))) context))
(defun remove-xref-info (type caller) (format *debug-io* "; Removing xref[~S]: ~S -> ...~%" type caller) (let ((db (database-for-type type))) (maphash (lambda (callee contexts) (setf (gethash callee db) ; update during traversal? (delete caller contexts :key #'xref-context-name :test #'equal))) db)))
(defun merge-xref-info-from-fasl-file (vectors) (destructuring-bind (who-calls who-macroexpands who-references who-binds who-sets) vectors (labels ((map-fasl-vector (vector fn) (do ((max (length vector)) (i 0 (+ i 2))) ((= i max)) (let ((callee (aref vector i))) (dolist (ctx (aref vector (1+ i))) (let ((caller (aref ctx 0)) (file (aref ctx 1)) (source-path (aref ctx 2))) (funcall fn callee caller file source-path)))))) (clear (type vector) (map-fasl-vector vector (lambda (callee caller file source-path) (declare (ignore callee file source-path)) (remove-xref-info type caller)))) (insert (type vector) (map-fasl-vector vector (lambda (callee caller file source-path) (register-xref type callee (make-xref-context :name caller :file file :source-path source-path))))) (update (vector type) (clear type vector) (insert type vector))) (update who-calls :calls) (update who-macroexpands :macroexpands) (update who-references :references) (update who-binds :binds) (update who-sets :sets))))
(in-package :c)
;;; sbould be in xref.lisp
(defun prettiest-caller-name (lambda-node toplevel-name) (cond ((not lambda-node) (list :anonymous toplevel-name))
;; LET and FLET bindings introduce new unnamed LAMBDA nodes. ;; If the home slot contains a lambda with a nice name, we use ;; that; otherwise fall back on the toplevel-name. ((or (not (eq (lambda-home lambda-node) lambda-node)) (lambda-contains-calls-p lambda-node)) (let ((home (lambda-name (lambda-home lambda-node))) (here (lambda-name lambda-node))) (cond ((and home here) (list :internal home here)) ((and here (symbolp here)) here) ((and home (symbolp home)) home) (t (or here home toplevel-name)))))
((and (consp (lambda-name lambda-node)) (eq :macro (first (lambda-name lambda-node)))) (lambda-name lambda-node))
;; a reference from a macro is named (:macro name) #+nil ((eql 0 (search "defmacro" toplevel-name :test 'char-equal)) (list :macro (subseq toplevel-name 9)))
;; probably "Top-Level Form" ((stringp (lambda-name lambda-node)) (lambda-name lambda-node))
;; probably (setf foo) ((consp (lambda-name lambda-node)) (lambda-name lambda-node))
(t ;; distinguish between nested functions (FLET/LABELS) and ;; global functions by checking whether the node has a HOME ;; slot that is different from itself. Furthermore, a LABELS ;; node at the first level inside a lambda may have a ;; self-referential home slot, but still be internal. (cond ((not (eq (lambda-home lambda-node) lambda-node)) (list :internal (lambda-name (lambda-home lambda-node)) (lambda-name lambda-node))) ((lambda-contains-calls-p lambda-node) (list :internal/calls (lambda-name (lambda-home lambda-node)) (lambda-name lambda-node))) (t (or (lambda-name lambda-node) toplevel-name))))))
(defun record-node-xrefs (node toplevel-name) (declare (type node node)) (let ((context (xref:make-xref-context))) (when *compile-file-truename* (setf (xref:xref-context-source-path context) (reverse (source-path-original-source (node-source-path node))))) (typecase node (ref (let* ((leaf (ref-leaf node)) (lexenv (ref-lexenv node)) (lambda (lexenv-lambda lexenv)) (home (node-home-lambda node)) (caller (or (and home (lambda-name home)) (prettiest-caller-name lambda toplevel-name)))) (setf (xref:xref-context-name context) caller) (typecase leaf ;; a reference to a LEAF of type GLOBAL-VAR (global-var (let ((called (global-var-name leaf))) ;; a reference to #'C::%SPECIAL-BIND means that we are ;; binding a special variable. The information on which ;; variable is being bound, and within which function, is ;; available in the ref's LEXENV object. (cond ((eq called 'c::%special-bind) (setf (xref:xref-context-name context) (caar (lexenv-blocks lexenv))) (xref:register-xref :binds (caar (lexenv-variables lexenv)) context)) ;; we're not interested in lexical environments ;; that have no name; they are mostly due to code ;; inserted by the compiler (eg calls to %VERIFY-ARGUMENT-COUNT) ((not caller) :no-caller) ;; we're not interested in lexical environments ;; named "Top-Level Form". ((and (stringp caller) (string= "Top-Level Form" caller)) :top-level-form) ;; ((not (eq 'original-source-start ;; (first (node-source-path node)))) ;; #+(or) ;; (format *debug-io* " ;;Ignoring compiler-generated call with source-path ~A~%" ;; (node-source-path node)) ;; :compiler-generated) ((not called) :no-called) ((eq :global-function (global-var-kind leaf)) (xref:register-xref :calls called context) (xref:register-xref :called caller context)) ((eq :special (global-var-kind leaf)) (xref:register-xref :references called context)) (t ;;(break) )))) ;; a reference to a LEAF of type CONSTANT (constant (let ((called (constant-name leaf))) (and called (not (eq called t)) ; ignore references to trivial variables caller (not (and (stringp caller) (string= "Top-Level Form" caller))) (xref:register-xref :references called context)))))))
;; a variable is being set (cset (let* ((variable (set-var node)) (lexenv (set-lexenv node))) (and (global-var-p variable) (eq :special (global-var-kind variable)) (let* ((lblock (first (lexenv-blocks lexenv))) (user (or (and lblock (car lblock)) toplevel-name)) (used (global-var-name variable))) (setf (xref:xref-context-name context) user) (and user used (xref:register-xref :sets used context))))))
;; nodes of type BIND are used to bind symbols to LAMBDA objects ;; (including for macros), but apparently not for bindings of ;; variables. (bind t))))
;; (let ((c:*record-xref-info* nil)) (compile-file "lxref" :load t))