
(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))