[Openmcl-devel] persistence of xref info in fasl files.

[Alan Ruttenberg]

Here's an implementation. Gary, I don't really know which what the best 
place to put the hooks, so I've used advise where it seemed 
appropriate. Please feel free to fix or tell me how to.

I came across one issue when doing this.  If you have (defun foo () 
(flet ((bar ())) *baz*))
then you get a recorded xref from bar to *baz*. I think this should be 
foo to *baz* since bar isn't global. If you disagree with that policy 
the code needs to be reworked a bit.

The bit about (add-pre-xref-xrefs) is for bootstrapping.

BTW, what does "indirect calls" mean?

-Alan


(in-package :ccl)

(defvar *compiling-xrefs*)
(defvar *clear-fasl-xrefs* nil)

(defun maybe-load-fasl-xrefs (function)
   (when (and (fboundp '%add-xref-entry)
	     *load-xref-info*
	     function
	     (getf (%lfun-info function) :xrefs))
       (add-fasl-xrefs (getf (%lfun-info function) :xrefs)))
   (when (and *clear-fasl-xrefs* function (getf (%lfun-info function) 
:xrefs))
     (clear-fasl-xref-info function)))

(defun %add-xref-entry (relation name1 name2)
   (when (and *record-xref-info* relation name1 name2)
     (if (boundp '*compiling-xrefs*)
       (push (list relation name1 name2) *compiling-xrefs*))
     (pushnew (make-xref-entry name2 relation)
	     (gethash name1 (%xref-table relation nil))
	     :test #'xref-entry-equal)
     (pushnew (make-xref-entry name1 relation)
	     (gethash name2 (%xref-table relation t))
	     :test #'xref-entry-equal)
     t))

(defun xrefs-for-fasl (name xrefs)
   (let ((table nil))
     (loop for (relation name1 name2) in xrefs
	  when (symbolp name2) ;; should track down why this isn't always 
true. But it isn't.
	  do
	  (pushnew name2 (getf table relation))
	  (identity name1)
	  '(if (null name) (setq name name1) (assert (eq name name1)))
	  )
     (loop for spot on table
	  when (listp (car spot))
	  do (setf (car spot) (coerce (cons name (car spot)) 'vector)))
     (if table (coerce table 'vector))))

(defun add-fasl-xrefs (xrefs)
   (loop for (relation refs) on (coerce xrefs 'list) by #'cddr
	for (name1 . name2s) = (coerce refs 'list)
	do (dolist (name2 name2s) (%add-xref-entry relation name1 name2))))

(defun clear-fasl-xref-info (function)
   (let ((found (member :xrefs (%lfun-info function))))
     (when found
       (setf (second found) nil))))

(defun add-pre-xref-xrefs ()
   (%map-lfuns
    (lambda(f)
      (when (and (plistp (%lfun-info f)) (getf (%lfun-info f) :xrefs))
        (add-fasl-xrefs (getf (%lfun-info f) :xrefs))
        (when *clear-fasl-xrefs* (clear-fasl-xref-info f))))))

(defun clear-all-fasl-xref-info ()
   (%map-lfuns
    (lambda(f)
      (when (and (plistp (%lfun-info f)) (getf (%lfun-info f) :xrefs))
        (clear-fasl-xref-info f)))))

(advise compile-named-function
	  (if *compile-file-pathname*
	    (let ((*compiling-xrefs* nil))
	      (multiple-value-bind (lfun warnings) (:do-it)
		(when (and lfun *compiling-xrefs*)
		  (nconc (%lfun-info lfun) (list :xrefs (xrefs-for-fasl (second 
arglist) *compiling-xrefs*))))
		(values lfun warnings)
		))
	    (:do-it))
	:when :around
	:name :xref)

(advise %defun
	(maybe-load-fasl-xrefs (car arglist))
	:when :after
	:name :xref)

(advise %macro
	(maybe-load-fasl-xrefs (car arglist))
	:when :after
	:name :xref)

(add-pre-xref-xrefs)
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: text/enriched
Size: 3350 bytes
Desc: not available
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20040103/f99eedd9/attachment.bin>