;;;
;;; WHY:  Tells more about dependencies between program units.
;;;
;;; ----------------------------------------------------------------------
;;;
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; $Header: /nfs/talk/work/talk/contrib/src/RCS/why.t,v 1.14 1996/03/14 16:41:20 v16admin Exp $
;;; ----------------------------------------------------------------------
;;;

(defun why-imports (user used .key: (analyzep t) (stream (stdout)))
  ;; Tells why the program unit USER requires the program unit USED
  ;; in its execution environment. Typically called for USER = library
  ;; or module and USED = library or module.
  (dynamic-let ((.*analyzep* analyzep)
		(.*stream* stream))
    (.why-imports user used ())))

(defun why-links (user used .key: (analyzep t) (stream (stdout)))
  ;; Tells why the program unit USED is linked into the program unit USER.
  ;; Typically called for USER = executable and USED = library or module.
  (dynamic-let ((.*analyzep* analyzep)
		(.*stream* stream))
    (.why-links user used ())))

(defun why-includes (user used .key: (analyzep t) (stream (stdout)))
  ;; Tells why the program unit USER requires the program unit USED
  ;; in its compilation environment. Typically called for USER = module
  ;; and USED = library or module.
  (dynamic-let ((.*analyzep* analyzep)
		(.*stream* stream))
    (.why-includes user used ())))

(defun who-imports (m1)
  ;; Returns the list of known modules which import m1.
  (.who-has m1 'execution:))

(defun who-includes (m1)
  (.who-has m1 'compilation:))

(defun unused-entities (prunits optional: (ostream (stdout)))
  ;; Returns the list of entities which are exported by any of the
  ;; prunits, but are not referenced by any of them.  This can help
  ;; you prune unneeded definitions from your modules.  The ostream
  ;; argument indicates the stream, if any, to which output is printed.
  (.unused-entities (if (consp prunits) prunits (list prunits))
		    ostream))


(defdynamic .*analyzep* ())
(defdynamic .*stream* (stdout))

(defun .stack-push (stack message rest: arguments)
  (cons (cons message arguments) stack))

(defun .explain-stack (stack)
  (newline (dynamic .*stream*))
  (for ((elt in: (reverse stack)))
    (let ((message (car elt))
	  (args (cdr elt)))
      (apply #'fprintf (dynamic .*stream*) message args)
      (newline (dynamic .*stream*)))))

(defun .why-imports (user used stack)
  (let ((prunit (.find-prunit-td user 'why-imports)))
    (.generic-why-imports prunit user used stack)))

(defgeneric .generic-why-imports (user-prunit user used stack))

(defmethod .generic-why-imports ((user-prunit .<module-desc>) user used stack)
  (ignore user-prunit)
  (cond ((.member used (tdref user 'user-execution:))
	 (.explain-stack (.stack-push stack
				      #!.required-in-module-user-execution
				      user used)))
	((.member used (tdref user 'execution:))
	 (.explain-stack (.stack-push stack
				      #!.required-in-module-execution
				      user used))
	 (when (dynamic .*analyzep*)
	   (.analyze-why-uses user used t ())))))

(defmethod .generic-why-imports ((user-prunit .<library-desc>) user used stack)
  (ignore user-prunit)
  (when (.member used (tdref user 'execution:))
    (for ((m in: (tdref user 'modules:)))
      (.why-imports m used (.stack-push stack
					#!.included-in-library-modules
					user m)))))

(defmethod .generic-why-imports ((user-prunit .<executable-desc>)
				 user used stack)
  (ignore user-prunit user used stack)
  ())

(defun .why-links (user used stack)
  (let ((prunit (.find-prunit-td user 'why-links)))
    (.generic-why-links prunit user used stack)))

(defgeneric .generic-why-links (user-prunit user used stack))

(defmethod .generic-why-links ((user-prunit .<module-desc>) user used stack)
  (ignore user-prunit user used stack)
  ())

(defmethod .generic-why-links ((user-prunit .<library-desc>) user used stack)
  (ignore user-prunit)
  (when (member used (tdref user 'modules:))
    (.explain-stack (.stack-push stack
				 #!.included-in-library-modules
				 user used))) )

(defmethod .generic-why-links ((user-prunit .<executable-desc>)
			       user used stack)
  (ignore user-prunit)
  (let ((units (append (tdref user 'initialize:)
		       (tdref user 'startup:))) )
    (for ((m in: units))
      (unless (eq m used)
	(let ((new-stack (.stack-push stack
				      #!.included-in-executable-keys
				      user m)))
	  (.why-links m used new-stack)
	  (.why-imports m used new-stack))))))

(defdynamic .*tell-why-imports-p* ())
(defdynamic .*tell-why-includes-p* ())
(defdynamic .*imported* ())

(defun .analyze-why-uses (module used importsp includesp)
  ;; Shows the definitions referenced in MODULE which make the module
  ;; USED used.
  (fprintf (dynamic .*stream*) #!.analyzing-module module)
  (newline (dynamic .*stream*))
  (dynamic-let ((.*tell-why-includes-p* includesp)
		(.*tell-why-imports-p* importsp))
    (with-handler .why-uses-handler
      (with ((compiler-verbose-p ()))
	(dynamic-let ((.*imported* (if (consp used) used (cons used ()))))
	  (analyze-program-unit module write-description-p: ()))))))

(defhandler .why-uses-handler)

(define-handler-method .why-uses-handler 
    ((cond walk.<found-execution-exporters>))
  (when (dynamic .*tell-why-imports-p*)
    (.show-exporters cond #!.imports-from)))

(define-handler-method .why-uses-handler 
    ((cond walk.<found-compilation-exporters>))
  (when (dynamic .*tell-why-includes-p*)
    (.show-exporters cond #!.includes-from)))

(defun .show-exporters (cond message)
  (let ((exporters (walk.exporters-found cond)))
    (for ((exp in: exporters))
      (when (.member (caddr exp) (dynamic .*imported*))
	(fprintf (dynamic .*stream*) message (car exp) (cadr exp) (caddr exp))
	(newline (dynamic .*stream*))))))

(defun .why-includes (user used stack)
  (let ((prunit (.find-prunit-td user 'why-includes)))
    (.generic-why-includes prunit user used stack)))

(defgeneric .generic-why-includes (user-prunit user used stack))

(defmethod .generic-why-includes ((user-prunit <object>) user used stack)
  (ignore user-prunit user used stack)
  ())

(defmethod .generic-why-includes ((user-prunit .<module-desc>) user used stack)
  (ignore user-prunit)
  (cond ((.member used (tdref user 'user-compilation:))
	 (.explain-stack (.stack-push stack
				      #!.required-in-module-user-compilation
				      user used)))
	((.member used (tdref user 'compilation:))
	 (.explain-stack (.stack-push stack
				      #!.required-in-module-compilation
				      user used))
	 (when (dynamic .*analyzep*)
	   (.analyze-why-uses user used () t)))))

(defun .member (object list)
  (if (consp object)
      (collecting
	(for ((elt in: object))
	  (collect-or
	   (block found
	     (for ((elt2 in: list))
	       (when (eq elt elt2)
		 (return-from found t)))))))
    (member object list)))


;;; Unused

(defdynamic .*used-ents*
  ;; should be a hash set.
  ())

(defdynamic .*unused-ents*
  ;; hash table with (module, type, name) -> boolean
  ())

(defdynamic .*unused-module* ())

(defun .unused-entities (prunits ostream)
  (dynamic-let ((.*used-ents* (make-hash-table 2))
		(.*unused-ents* (make-hash-table 3)))
    (let ((mods (make-hash-set)))
      (.analyze-for-unused prunits mods ostream)
      (let ((result (.find-unuseds mods
				   (dynamic .*used-ents*)
				   (dynamic .*unused-ents*))))
	(when ostream
	  (.print-unused-result result ostream))
	result))))

(defun .analyze-for-unused (prunits mods ostream)
  (with-handler .unused-handler
    (with ((compiler-verbose-p ()))
      (for ((prunit in: prunits))
	(.generic-unused-analyze prunit mods ostream)))))

(defun .find-unuseds (mods used-ents unused-ents)
  (nlsort (collecting
	    (for (((mod) in-hash-set: mods))
	      (let ((exports (.collect-unused-exports
			      mod unused-ents used-ents)))
		(when exports
		  (collect (cons mod (nlsort exports #'.lsym<)))))))
	  #'.lsym<))

(defun .collect-unused-exports (mod unused-ents used-ents)
  (collecting
    (for (((xtype xnames) in-alist: (cdar (tdref mod 'export:))))
      (let ((names
	     (collecting
	       (for ((xname in: xnames))
		 (unless (htref used-ents xtype xname)
		   (collect
		    (cons xname (htref unused-ents mod xtype xname))))))))
	(when names
	  (collect (cons xtype (nlsort names #'.lsym<))))))))

(defun .generic-unused-analyze (prunit done ostream)
  (ignore ostream)
  (if (which prunit 'td)
      (case (tdref prunit 'type:)
	(module
	 (unless (hsref done prunit)
	   (hsset done prunit)
	   (fprintf (stderr) #!.analyzing-module prunit)
	   (newline (stderr))
	   (dynamic-let ((.*unused-module* prunit))
	     (analyze-program-unit prunit write-description-p: ()))))
	(library
	 (fprintf (stderr) #!.analyzing-lib prunit)
	 (for ((m in: (tdref prunit 'modules:)))
	   (.generic-unused-analyze m done (stderr))))
	(executable
	 (fprintf (stderr) #!.analyzing-exec prunit)
	 (for ((m in: (tdref prunit 'initialize:)))
	   (.generic-unused-analyze m done (stderr)))
	 (for ((m in: (tdref prunit 'startup:)))
	   (.generic-unused-analyze m done (stderr))))
	(workspace
	 (fprintf (stderr) #!.analyzing-ws prunit)
	 (unless (member prunit (workspaces))
           (in-workspaces (cons prunit (workspaces))))
	 (for ((pu in: (tdref prunit 'program-units:)))
	   (.generic-unused-analyze pu done (stderr)))))
    (warn 'unused-entities #!.prunit-not-found prunit)))

(defhandler .unused-handler)

(define-handler-method .unused-handler ((c walk.<condition>))
  (ignore c)
  ())

(define-handler-method .unused-handler
  ((c walk.<external-execution-definitions>))
  (.handle-external-defs c))

(define-handler-method .unused-handler
  ((c walk.<external-compilation-definitions>))
  (.handle-external-defs c))

(define-handler-method .unused-handler ((c walk.<module-definitions>))
  (let ((defs (walk.condition-module-definitions c)))
    (for ((def in: defs))
      (unless (walk.definition-used-p def)
	(setf (htref (dynamic .*unused-ents*) (dynamic .*unused-module*)
		     (walk.type def) (walk.name def))
	  t)))))

(defun .handle-external-defs (c)
  (let ((table (walk.external-definitions c))
	(used-ents (dynamic .*used-ents*)))
    (when table
      (for (((name type place) in-hash-table: table))
	(setf (htref used-ents type name) t)))))

(defun .print-unused-result (result ostream)
  (fprintf ostream
	   "\nUnused exported entities (* = used internally only):\n")
  (fprintf ostream
	   "======================================================\n\n")
  (for (((mod unused1) in-alist: result))
    (fprintf ostream "In module %A:\n" mod)
    (for (((type names) in-alist: unused1))
      (fprintf ostream " %A unused:\n" type)
      (for ((name in: names))
	(if (cdr name)
	    (fprintf ostream " %A *\n" (car name))
	  (fprintf ostream "  %A\n" (car name)))))))

(defun .sym< (s1 s2)
  (let ((p1 (id-package s1))
	(p2 (id-package s2)))
    (cond ((and (null p1) (null p2)) (string< (id-name s1) (id-name s2)))
	  ((and p1 p2) (.sym< p1 p2))
	  ((and p1 (null p2)) s2)
	  ((and p2 (null p1)) s1))))

(defun .lsym< (l1 l2) (.sym< (car l1) (car l2)))

;;; More who's

(defun .who-has (m1 field)
  (let ((result ()))
    (for ((ws in: (workspaces)))
      (for ((mod in: (tdref ws 'program-units:)))
	(when (and (eq (program-unit-workspace mod) ws)
		   (eq (tdref mod 'type:) 'module)
		   (member m1 (tdref mod field)))
	  (unless (member mod result) (pushf result mod)))))
    (nlsort result (lambda (s1 s2) (string< (id-name s1) (id-name s2))))))

;;; messages

(defmessage .required-in-module-user-execution
  english: "The module `%A' imports `%A' in its key `user-execution:'")

(defmessage .required-in-module-execution
  english: "The module `%A' imports `%A' in its key `execution:'")

(defmessage .included-in-library-modules
  english: "The library `%A' contains `%A' in its key `modules:'")

(defmessage .included-in-executable-keys
  english:
  "The executable `%A' contains `%A' in its key `initialize' or `startup:'")

(defmessage .required-in-module-user-compilation
  english: "The module `%A' includes `%A' in its key `user-compilation:'")

(defmessage .required-in-module-compilation
  english: "The module `%A' includes `%A' in its key `compilation:'")

(defmessage .imports-from
  english: "  -> Imports %A `%A' from `%A'")

(defmessage .includes-from
  english: "  -> Includes %A `%A' from `%A'")

(defmessage .analyzing-module
  english: "  Analyzing module %A")

(defmessage .analyzing-lib
  english: "  Analyzing modules in library %A\n")

(defmessage .analyzing-exec
  english: "  Analyzing program units in executable %A\n")

(defmessage .analyzing-ws
  english: "  Analyzing program units in workspace %A\n")

(defmessage .prunit-not-found
  english: "program unit %A not in (path)")
