Skip to content
Snippets Groups Projects
ir1util.lisp 70 KiB
Newer Older
      (do-nodes (node cont block)
	(let* ((path (node-source-path node))
	       (first (first path)))
	  (when (or (eq first 'original-source-start)
		    (and (atom first)
			 (or (not (symbolp first))
			     (let ((pkg (symbol-package first)))
			       (and pkg
				    (not (eq pkg (symbol-package :end))))))
			 (not (member first *deletion-ignored-objects*))
			 (not (typep first '(or fixnum character)))
			 (every #'(lambda (x)
				    (present-in-form first x 0))
				(source-path-forms path))
			 (present-in-form first (find-original-source path)
					  0)))
	    (unless (return-p node)
	      (let ((*compiler-error-context* node))
		(compiler-note "Deleting unreachable code.")))
	    (return))))))
  (undefined-value))


wlott's avatar
wlott committed
;;; Delete-Block  --  Interface
;;;
;;;    This function does what is necessary to eliminate the code in it from
;;; the IR1 representation.  This involves unlinking it from its predecessors
;;; and successors and deleting various node-specific semantic information.
;;;
;;;    We mark the Start as has having no next and remove the last node from
;;; its Cont's uses.  We also flush the DEST for all continuations whose values
;;; are received by nodes in the block.
;;;
(defun delete-block (block)
  (declare (type cblock block))
  (assert (block-component block) () "Block is already deleted.")
wlott's avatar
wlott committed
  (setf (block-delete-p block) t)

  (let* ((last (block-last block))
	 (cont (node-cont last)))
    (delete-continuation-use last)
    (if (eq (continuation-kind cont) :unused)
	(delete-continuation cont)
	(reoptimize-continuation cont)))
wlott's avatar
wlott committed

  (dolist (b (block-pred block))
    (unlink-blocks b block))
  (dolist (b (block-succ block))
    (unlink-blocks block b))

  (do-nodes (node cont block)
    (typecase node
      (ref (delete-ref node))
      (cif
       (flush-dest (if-test node)))
      ;;
      ;; The next two cases serve to maintain the invariant that a LET always
      ;; has a well-formed COMBINATION, REF and BIND.  We delete the lambda
      ;; whenever we delete any of these, but we must be careful that this LET
      ;; has not already been partially deleted.
wlott's avatar
wlott committed
      (basic-combination
       (when (and (eq (basic-combination-kind node) :local)
		  ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
		  (continuation-use (basic-combination-fun node)))
	 (let ((fun (combination-lambda node)))
	   ;; If our REF was the 2'nd to last ref, and has been deleted, then
	   ;; Fun may be a LET for some other combination.
	   (when (and (member (functional-kind fun) '(:let :mv-let))
		      (eq (let-combination fun) node))
	     (delete-lambda fun))))
wlott's avatar
wlott committed
       (flush-dest (basic-combination-fun node))
       (dolist (arg (basic-combination-args node))
	 (when arg (flush-dest arg))))
      (bind
       (let ((lambda (bind-lambda node)))
	 (unless (eq (functional-kind lambda) :deleted)
	   (assert (member (functional-kind lambda)
			   '(:let :mv-let :assignment)))
	   (delete-lambda lambda))))
wlott's avatar
wlott committed
      (exit
       (let ((value (exit-value node))
	     (entry (exit-entry node)))
wlott's avatar
wlott committed
	 (when value
	   (flush-dest value))
	 (when entry
	   (setf (entry-exits entry)
		 (delete node (entry-exits entry))))))
wlott's avatar
wlott committed
      (creturn
       (flush-dest (return-result node))
       (delete-return node))
      (cset
       (flush-dest (set-value node))
       (let ((var (set-var node)))
	 (setf (basic-var-sets var)
	       (delete node (basic-var-sets var))))))

    (delete-continuation (node-prev node)))

  (remove-from-dfo block)
  (undefined-value))


;;; Unlink-Node  --  Interface
;;;
;;;    Delete a node from a block, deleting the block if there are no nodes
;;; left.  We remove the node from the uses of its CONT, but we don't deal with
;;; cleaning up any type-specific semantic attachments.  If the CONT is :UNUSED
;;; after deleting this use, then we delete CONT.  (Note :UNUSED is not the
;;; same as no uses.  A continuation will only become :UNUSED if it was
;;; :INSIDE-BLOCK before.) 
;;;
;;;    If the node is the last node, there must be exactly one successor.  We
;;; link all of our precedessors to the successor and unlink the block.  In
;;; this case, we return T, otherwise NIL.  If no nodes are left, and the block
;;; is a successor of itself, then we replace the only node with a degenerate
;;; exit node.  This provides a way to represent the bodyless infinite loop,
;;; given the prohibition on empty blocks in IR1.
;;;
(defun unlink-node (node)
  (declare (type node node))
  (let* ((cont (node-cont node))
	 (next (continuation-next cont))
	 (prev (node-prev node))
	 (block (continuation-block prev))
	 (prev-kind (continuation-kind prev))
	 (last (block-last block)))
    
    (unless (eq (continuation-kind cont) :deleted)
      (delete-continuation-use node)
      (when (eq (continuation-kind cont) :unused)
	(assert (not (continuation-dest cont)))
	(delete-continuation cont)))
    
    (setf (block-type-asserted block) t)
    (setf (block-test-modified block) t)

    (cond ((or (eq prev-kind :inside-block)
	       (and (eq prev-kind :block-start)
		    (not (eq node last))))
	   (cond ((eq node last)
		  (setf (block-last block) (continuation-use prev))
		  (setf (continuation-next prev) nil))
		 (t
		  (setf (continuation-next prev) next)
		  (setf (node-prev next) prev)))
	   (setf (node-prev node) nil)
	   nil)
	  (t
	   (assert (eq prev-kind :block-start))
	   (assert (eq node last))
	   (let* ((succ (block-succ block))
		  (next (first succ)))
	     (assert (and succ (null (cdr succ))))
	     (cond
	      ((member block succ)
	       (with-ir1-environment node
wlott's avatar
wlott committed
		       (dummy (make-continuation)))
		   (setf (continuation-next prev) nil)
		   (prev-link exit prev)
		   (add-continuation-use exit dummy)
		   (setf (block-last block) exit)))
	       (setf (node-prev node) nil)
	       nil)
	      (t
	       (assert (eq (block-start-cleanup block)
			   (block-end-cleanup block)))
wlott's avatar
wlott committed
	       (unlink-blocks block next)
	       (dolist (pred (block-pred block))
		 (change-block-successor pred block next))
	       (remove-from-dfo block)
	       (cond ((continuation-dest prev)
		      (setf (continuation-next prev) nil)
		      (setf (continuation-kind prev) :deleted-block-start))
		     (t
		      (delete-continuation prev)))
	       (setf (node-prev node) nil)
	       t)))))))


;;; NODE-DELETED  --  Interface
;;;
;;;    Return true if NODE has been deleted, false if it is still a valid part
;;; of IR1.
;;;
(defun node-deleted (node)
  (declare (type node node))
  (let ((prev (node-prev node)))
    (not (and prev
	      (not (eq (continuation-kind prev) :deleted))
	      (let ((block (continuation-block prev)))
		(and (block-component block)
		     (not (block-delete-p block))))))))


;;; DELETE-COMPONENT  --  Interface
;;;
;;;    Delete all the blocks and functions in Component.  We scan first marking
;;; the blocks as delete-p to prevent weird stuff from being triggered by
;;; deletion.
;;;
(defun delete-component (component)
  (declare (type component component))
  (assert (null (component-new-functions component)))
  (setf (component-kind component) :deleted)
  (do-blocks (block component)
    (setf (block-delete-p block) t))
  (dolist (fun (component-lambdas component))
    (setf (functional-kind fun) nil)
    (setf (leaf-refs fun) nil)
    (delete-lambda fun))
  (do-blocks (block component)
    (delete-block block))
  (undefined-value))
wlott's avatar
wlott committed
  

;;; EXTRACT-FUNCTION-ARGS -- interface
;;;
;;; Convert code of the form (foo ... (fun ...) ...) to (foo ... ... ...).
;;; In other words, replace the function combination fun by it's arguments.
;;; If there are any problems with doing this, use GIVE-UP to blow out of
;;; whatever transform called this.  Note, as the number of arguments changes,
;;; the transform must be prepared to return a lambda with a new lambda-list
;;; with the correct number of arguments.
;;; 
(defun extract-function-args (cont fun num-args)
  "If CONT is a call to FUN with NUM-ARGS args, change those arguments
   to feed directly to the continuation-dest of CONT, which must be
   a combination."
  (declare (type continuation cont)
	   (type symbol fun)
	   (type index num-args))
  (let ((outside (continuation-dest cont))
	(inside (continuation-use cont)))
    (assert (combination-p outside))
    (unless (combination-p inside)
      (give-up))
    (let ((inside-fun (combination-fun inside)))
      (unless (eq (continuation-function-name inside-fun) fun)
	(give-up))
      (let ((inside-args (combination-args inside)))
	(unless (= (length inside-args) num-args)
	  (give-up))
	(let* ((outside-args (combination-args outside))
	       (arg-position (position cont outside-args))
	       (before-args (subseq outside-args 0 arg-position))
	       (after-args (subseq outside-args (1+ arg-position))))
	  (dolist (arg inside-args)
	    (setf (continuation-dest arg) outside))
	  (setf (combination-args inside) nil)
	  (setf (combination-args outside)
		(append before-args inside-args after-args))
	  (change-ref-leaf (continuation-use inside-fun)
			   (find-free-function 'list "???"))
	  (setf (combination-kind inside) :full)
	  (setf (node-derived-type inside) *wild-type*)
	  (setf (continuation-asserted-type cont) *wild-type*)
wlott's avatar
wlott committed

;;;; Leaf hackery:

;;; Change-Ref-Leaf  --  Interface
;;;
;;;    Change the Leaf that a Ref refers to.
;;;
(defun change-ref-leaf (ref leaf)
  (declare (type ref ref) (type leaf leaf))
  (unless (eq (ref-leaf ref) leaf)
    (push ref (leaf-refs leaf))
    (delete-ref ref)
    (setf (ref-leaf ref) leaf)
    (let ((ltype (leaf-type leaf)))
      (if (function-type-p ltype)
	  (setf (node-derived-type ref) ltype)
	  (derive-node-type ref ltype)))
wlott's avatar
wlott committed
    (reoptimize-continuation (node-cont ref)))
  (undefined-value))


;;; Substitute-Leaf  --  Interface
;;;
;;;    Change all Refs for Old-Leaf to New-Leaf.
;;;
(defun substitute-leaf (new-leaf old-leaf)
  (declare (type leaf new-leaf old-leaf))
  (dolist (ref (leaf-refs old-leaf))
    (change-ref-leaf ref new-leaf))
  (undefined-value))

;;; SUBSTITUTE-LEAF-IF  --  Interface
;;;
;;;    Like SUBSITIUTE-LEAF, only there is a predicate on the Ref to tell
;;; whether to substitute.
;;;
(defun substitute-leaf-if (test new-leaf old-leaf)
  (declare (type leaf new-leaf old-leaf) (type function test))
  (dolist (ref (leaf-refs old-leaf))
    (when (funcall test ref)
      (change-ref-leaf ref new-leaf)))
  (undefined-value))
wlott's avatar
wlott committed

;;; Find-Constant  --  Interface
;;;
;;;    Return a Leaf which represents the specified constant object.  If the
;;; object is not in *constants*, then we create a new constant Leaf and
;;; enter it.
;;;
(defun find-constant (object)
  (or (gethash object *constants*)
      (setf (gethash object *constants*)
	    (make-constant :value object  :name nil
			   :type (ctype-of object)
			   :where-from :defined))))


;;;; Find-NLX-Info  --  Interface
;;;
;;;    If there is a non-local exit noted in Entry's environment that exits to
;;; Cont in that entry, then return it, otherwise return NIL.
;;;
(defun find-nlx-info (entry cont)
  (declare (type entry entry) (type continuation cont))
  (let ((entry-cleanup (entry-cleanup entry)))
    (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
wlott's avatar
wlott committed
      (when (and (eq (nlx-info-continuation nlx) cont)
		 (eq (nlx-info-cleanup nlx) entry-cleanup))
wlott's avatar
wlott committed
	(return nlx)))))


;;;; Functional hackery:

;;; Main-Entry  --  Interface
;;;
;;;    If Functional is a Lambda, just return it; if it is an
;;; optional-dispatch, return the main-entry.
;;;
(proclaim '(function main-entry (functional) clambda))
wlott's avatar
wlott committed
(defun main-entry (functional)
  (if (lambda-p functional)
      functional
      (optional-dispatch-main-entry functional)))

;;; Looks-Like-An-MV-Bind  --  Interface
;;;
;;;    Returns true if Functional is a thing that can be treated like MV-Bind
;;; when it appears in an MV-Call.  All fixed arguments must be optional with
;;; null default and no supplied-p.  There must be a rest arg with no
;;; references.
;;;
(proclaim '(function looks-like-an-mv-bind (functional) boolean))
(defun looks-like-an-mv-bind (functional)
  (and (optional-dispatch-p functional)
       (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
	   ((null arg) nil)
	 (let ((info (lambda-var-arg-info (car arg))))
	   (unless info (return nil))
	   (case (arg-info-kind info)
	     (:optional
	      (when (or (arg-info-supplied-p info) (arg-info-default info))
		(return nil)))
	     (:rest
	      (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
	     (t
	      (return nil)))))))

;;; External-Entry-Point-P  --  Interface
;;;
;;;    Return true if function is an XEP.  This is true of normal XEPs
;;; (:External kind) and top-level lambdas (:Top-Level kind.)
;;;
(defun external-entry-point-p (fun)
  (declare (type functional fun))
  (not (null (member (functional-kind fun) '(:external :top-level)))))


;;; Continuation-Function-Name  --  Interface
;;;
;;;    If Cont's only use is a non-notinline global function reference, then
;;; return the referenced symbol, otherwise NIL.  If Notinline-OK is true, then
;;; we don't care if the ref is notinline.
wlott's avatar
wlott committed
;;;
(defun continuation-function-name (cont &optional notinline-ok)
wlott's avatar
wlott committed
  (declare (type continuation cont))
  (let ((use (continuation-use cont)))
	     (or (not (eq (ref-inlinep use) :notinline))
		 notinline-ok))
wlott's avatar
wlott committed
	(let ((leaf (ref-leaf use)))
	  (if (and (global-var-p leaf)
		   (eq (global-var-kind leaf) :global-function))
	      (leaf-name leaf)
	      nil))
	nil)))


;;; LET-COMBINATION  --  Interface
;;;
;;;    Return the COMBINATION node that is the call to the let Fun.
;;;
(defun let-combination (fun)
  (declare (type clambda fun))
  (assert (member (functional-kind fun) '(:let :mv-let)))
wlott's avatar
wlott committed
  (continuation-dest (node-cont (first (leaf-refs fun)))))


;;; LET-VAR-INITIAL-VALUE  --  Interface
;;;
;;;    Return the initial value continuation for a let variable or NIL if none.
;;;
(defun let-var-initial-value (var)
  (declare (type lambda-var var))
  (let ((fun (lambda-var-home var)))
    (elt (combination-args (let-combination fun))
	 (position var (lambda-vars fun)))))


;;; COMBINATION-LAMBDA  --  Interface
;;;
;;;    Return the LAMBDA that is called by the local Call.
;;;
(defun combination-lambda (call)
  (declare (type basic-combination call))
  (assert (eq (basic-combination-kind call) :local))
  (ref-leaf (continuation-use (basic-combination-fun call))))


;;;; Compiler error context determination:

(proclaim '(special *current-path*))


;;; We bind print level and length when printing out messages so that we don't
;;; dump huge amounts of garbage.
;;;
(proclaim '(type (or unsigned-byte null) *error-print-level*
		 *error-print-length* *error-print-lines*))

(defvar *error-print-level* 3
  "The value for *Print-Level* when printing compiler error messages.")
(defvar *error-print-length* 5
  "The value for *Print-Length* when printing compiler error messages.")
(defvar *error-print-lines* 5
  "The value for *Print-Lines* when printing compiler error messages.")

(defvar *enclosing-source-cutoff* 1
  "The maximum number of enclosing non-original source forms (i.e. from
  macroexpansion) that we print in full.  For additional enclosing forms, we
  print only the CAR.")
(proclaim '(type unsigned-byte *enclosing-source-cutoff*))


wlott's avatar
wlott committed
;;; We separate the determination of compiler error contexts from the actual
;;; signalling of those errors by objectifying the error context.  This allows
;;; postponement of the determination of how (and if) to signal the error.
wlott's avatar
wlott committed
;;; We take care not to reference any of the IR1 so that pending potential
;;; error messages won't prevent the IR1 from being GC'd.  To this end, we
;;; convert source forms to strings so that source forms that contain IR1
;;; references (e.g. %DEFUN) don't hold onto the IR.
wlott's avatar
wlott committed
;;;
(defstruct (compiler-error-context
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore s d))
	       (format stream "#<Compiler-Error-Context>"))))
  ;;
  ;; A list of the stringified CARs of the enclosing non-original source forms
  ;; exceeding the *enclosing-source-cutoff*.
  (enclosing-source nil :type list)
wlott's avatar
wlott committed
  ;;
  ;; A list of stringified enclosing non-original source forms.
  (source nil :type list)
ram's avatar
ram committed
  ;;
  ;; The stringified form in the original source that expanded into Source.
  (original-source (required-argument) :type simple-string)
ram's avatar
ram committed
  ;;
  ;; A list of prefixes of "interesting" forms that enclose original-source.
  (context nil :type list)
  ;;
  ;; The FILE-INFO-NAME for the relevant FILE-INFO.
  (file-name (required-argument)
	     :type (or simple-string (member :lisp :stream)))
  ;;
  ;; The file position at which the top-level form starts, if applicable.
  (file-position nil :type (or index null))
  ;;
  ;; The original source part of the source path.
  (original-source-path nil :type list))
  
wlott's avatar
wlott committed
  
;;; If true, this is the node which is used as context in compiler warning
;;; messages.
;;;
(proclaim '(type (or null compiler-error-context node)
		 *compiler-error-context*))
(defvar *compiler-error-context* nil)


;;; Hashtable mapping macro names to source context parsers.  Each parser
;;; function returns the source-context list for that form.
;;; 
(defvar *source-context-methods* (make-hash-table))

;;; DEF-SOURCE-CONTEXT  --  Public
;;;
(defmacro def-source-context (name ll &body body)
  "DEF-SOURCE-CONTEXT Name Lambda-List Form*
   This macro defines how to extract an abbreviated source context from the
   Named form when it appears in the compiler input.  Lambda-List is a DEFMACRO
   style lambda-list used to parse the arguments.  The Body should return a
   list of subforms suitable for a \"~{~S ~}\" format string."
  (let ((n-whole (gensym)))
    `(setf (gethash ',name *source-context-methods*)
	   #'(lambda (,n-whole)
	       (destructuring-bind ,ll ,n-whole ,@body)))))

(def-source-context defstruct (name-or-options &rest slots)
  (declare (ignore slots))
  `(defstruct ,(if (consp name-or-options)
		   (car name-or-options)
		   name-or-options)))

(def-source-context function (thing)
  (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
      `(lambda ,(second thing))
      `(function ,thing)))

#+pcl
(def-source-context pcl::defmethod (name &rest stuff)
  (let ((arg-pos (position-if #'listp stuff)))
    (if arg-pos
ram's avatar
ram committed
	`(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos)
	   ,@(nth-value 2 (pcl::parse-specialized-lambda-list
			   (elt stuff arg-pos))))
ram's avatar
ram committed
	`(pcl::defmethod ,name "<illegal syntax>"))))
;;; SOURCE-FORM-CONTEXT  --  Internal
;;;
;;;    Return the first two elements of Form if Form is a list.  Take the car
;;; of the second form if appropriate.
;;;
(defun source-form-context (form)
  (cond ((atom form) nil)
	((>= (length form) 2)
	 (funcall (gethash (first form) *source-context-methods*
			   #'(lambda (x)
			       (declare (ignore x))
			       (list (first form) (second form))))
		  (rest form)))
wlott's avatar
wlott committed
;;; Find-Original-Source  --  Internal
;;;
;;;    Given a source path, return the original source form and a description
;;; of the interesting aspects of the context in which it appeared.  The
;;; context is a list of lists, one sublist per context form.  The sublist is a
;;; list of some of the initial subforms of the context form.
;;;
;;; For now, we use the first two subforms of each interesting form.  A form is
;;; interesting if the first element is a symbol beginning with "DEF" and it is
;;; not the source form.  If there is no DEF-mumble, then we use the outermost
;;; containing form.  If the second subform is a list, then in some cases we
;;; return the car of that form rather than the whole form (i.e. don't show
;;; defstruct options, etc.)
;;;
(defun find-original-source (path)
  (declare (list path))
  (let* ((rpath (reverse (source-path-original-source path)))
	 (tlf (first rpath))
	 (root (find-source-root tlf *source-info*)))
wlott's avatar
wlott committed
    (collect ((context))
      (let ((form root)
	    (current (rest rpath)))
	(loop
	  (when (atom form)
	    (assert (null current))
	    (return))
wlott's avatar
wlott committed
	  (let ((head (first form)))
	    (when (symbolp head)
	      (let ((name (symbol-name head)))
		(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
		  (context (source-form-context form))))))
wlott's avatar
wlott committed
	  (setq form (nth (pop current) form)))
	
	(cond ((context)
	       (values form (context)))
	      ((and path root)
	       (let ((c (source-form-context root)))
		 (values form (if c (list c) nil))))
wlott's avatar
wlott committed
	      (t
	       (values '(unable to locate source)
		       '((some strange place)))))))))


;;; STRINGIFY-FORM  --  Internal
;;;
;;;    Convert a source form to a string, formatted suitably for use in
;;; compiler warnings.
;;;
(defun stringify-form (form &optional (pretty t))
  (let ((*print-level* (or *error-print-level* *print-level*))
	(*print-length* (or *error-print-length* *print-length*))
	(*print-lines* (or *error-print-lines* *print-lines*))
	(*print-pretty* pretty))
    (if pretty
	(format nil "  ~S~%" form)
	(prin1-to-string form))))
wlott's avatar
wlott committed
;;; FIND-ERROR-CONTEXT  --  Interface
;;;
;;;    Return a COMPILER-ERROR-CONTEXT structure describing the current error
;;; context, or NIL if we can't figure anything out.  Args is a list of things
;;; that are going to be printed out in the error message, and can thus be
;;; blown off when they appear in the source context.
wlott's avatar
wlott committed
;;;
(defun find-error-context (args)
wlott's avatar
wlott committed
  (let ((context *compiler-error-context*))
    (if (compiler-error-context-p context)
	context
	(let ((path (or *current-path*
			(if context
			    (node-source-path context)
			    nil))))
wlott's avatar
wlott committed
	  (when (and *source-info* path)
	    (multiple-value-bind (form src-context)
				 (find-original-source path)
	      (collect ((full nil cons)
			(short nil cons))
		(let ((forms (source-path-forms path))
		      (n 0))
		  (dolist (src (if (member (first forms) args)
				   (rest forms)
				   forms))
		    (if (>= n *enclosing-source-cutoff*)
			(short (stringify-form (if (consp src)
						   (car src)
						   src)
					       nil))
			(full (stringify-form src)))
		    (incf n)))

		(let* ((tlf (source-path-tlf-number path))
		       (file (find-file-info tlf *source-info*)))
		  (make-compiler-error-context
		   :enclosing-source (short)
		   :source (full)
		   :original-source (stringify-form form)
		   :context src-context
		   :file-name (file-info-name file)
		   :file-position
		   (multiple-value-bind (ignore pos)
					(find-source-root tlf *source-info*)
		     (declare (ignore ignore))
		     pos)
		   :original-source-path
		   (source-path-original-source path))))))))))
wlott's avatar
wlott committed


;;;; Printing error messages:

;;; A function that is called to unwind out of Compiler-Error.
;;;
(proclaim '(type (function () nil) *compiler-error-bailout*))
(defvar *compiler-error-bailout*
  #'(lambda () (error "Compiler-Error with no bailout.")))

;;; The stream that compiler error output is directed to.
;;;
(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
(proclaim '(type stream *compiler-error-output*))
wlott's avatar
wlott committed

;;; We save the context information that we printed out most recently so that
;;; we don't print it out redundantly.

;;; The last COMPILER-ERROR-CONTEXT that we printed.
;;;
(defvar *last-error-context* nil)
(proclaim '(type (or compiler-error-context null) *last-error-context*))

;;; The format string and args for the last error we printed.
wlott's avatar
wlott committed
;;;
(defvar *last-format-string* nil)
(defvar *last-format-args* nil)
(proclaim '(type (or string null) *last-format-string*))
(proclaim '(type list *last-format-args*))
wlott's avatar
wlott committed

;;; The number of times that the last error message has been emitted, so that
;;; we can compress duplicate error messages.
(defvar *last-message-count* 0)
(proclaim '(type index *last-message-count*))
wlott's avatar
wlott committed

(defvar *compiler-notification-function* nil
  "This is the function called by the compiler to specially note a warning,
   comment, or error.  The function must take four arguments, the severity
   a string for context, the file namestring, and the file position.  The
   severity is one of :note, :warning, or :error.  Except for the severity, all
   of these can be NIL if unavailable or inapplicable.")


;;; COMPILER-NOTIFICATION  --  Internal
;;;
;;;    Call any defined notification function.
;;;
(defun compiler-notification (severity context)
  (declare (type (member :note :warning :error) severity)
	   (type (or compiler-error-context null) context))
  (when *compiler-notification-function*
    (if context
	(let ((*print-level* 2)
	      (*print-pretty* nil)
	      (name (compiler-error-context-file-name context)))
	  (funcall *compiler-notification-function* severity 
		   (format nil "~{~{~S~^ ~}~^ => ~}"
			   (compiler-error-context-context context))
		   (compiler-error-context-file-position context)))
	(funcall *compiler-notification-function* severity nil nil nil)))
  (undefined-value))


wlott's avatar
wlott committed
;;; Note-Message-Repeats  --  Internal
;;;
;;;    If the last message was given more than once, then print out an
;;; indication of how many times it was repeated.  We reset the message count
;;; when we are done.
;;;
ram's avatar
ram committed
(defun note-message-repeats (&optional (terpri t))
  (cond ((= *last-message-count* 1)
	 (when terpri (terpri *compiler-error-output*)))
ram's avatar
ram committed
	((> *last-message-count* 1)
	 (format *compiler-error-output* "[Last message occurs ~D times]~2%"
		 *last-message-count*)))
wlott's avatar
wlott committed
  (setq *last-message-count* 0))


;;; Print-Error-Message  --  Internal
;;;
;;;    Print out the message, with appropriate context if we can find it.  If
;;; If the context is different from the context of the last message we
;;; printed, then we print the context.  If the original source is different
;;; from the source we are working on, then we print the current source in
;;; addition to the original source.
;;;
;;;    We suppress printing of messages identical to the previous, but record
;;; the number of times that the message is repeated.
;;;
(defun print-error-message (what format-string format-args)
  (declare (type (member :error :warning :note) what) (string format-string)
	   (list format-args))
  (let* ((*print-level* (or *error-print-level* *print-level*))
	 (*print-length* (or *error-print-length* *print-length*))
	 (*print-lines* (or *error-print-lines* *print-lines*))
wlott's avatar
wlott committed
	 (stream *compiler-error-output*)
	 (context (find-error-context format-args)))
wlott's avatar
wlott committed
    (cond
     (context
      (let ((file (compiler-error-context-file-name context))
	    (in (compiler-error-context-context context))
wlott's avatar
wlott committed
	    (form (compiler-error-context-original-source context))
ram's avatar
ram committed
	    (enclosing (compiler-error-context-enclosing-source context))
	    (source (compiler-error-context-source context))
	    (last *last-error-context*))
	(compiler-notification what context)

	(unless (and last
		     (equal file (compiler-error-context-file-name last)))
	    (note-message-repeats)
	    (setq last nil)
	    (format stream "~2&File: ~A~%" file)))
wlott's avatar
wlott committed
	
	(unless (and last
		     (equal in (compiler-error-context-context last)))
wlott's avatar
wlott committed
	  (note-message-repeats)
	  (setq last nil)
	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" in))
	(unless (and last
		     (string= form
			      (compiler-error-context-original-source last)))
wlott's avatar
wlott committed
	  (note-message-repeats)
	(unless (and last
		     (equal enclosing
			    (compiler-error-context-enclosing-source last)))
	  (when enclosing
ram's avatar
ram committed
	    (note-message-repeats)
	    (setq last nil)
	    (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
	
	(unless (and last
		     (equal source (compiler-error-context-source last)))
	  (setq *last-format-string* nil)
	  (when source
ram's avatar
ram committed
	    (note-message-repeats)
	    (dolist (src source)
	      (write-line "==>" stream)
	      (write-string src stream))))))
wlott's avatar
wlott committed
     (t
      (compiler-notification what nil)
wlott's avatar
wlott committed
      (note-message-repeats)
      (setq *last-format-string* nil)
wlott's avatar
wlott committed
      (format stream "~2&")))

    (setq *last-error-context* context)
wlott's avatar
wlott committed
    
    (unless (and (equal format-string *last-format-string*)
ram's avatar
ram committed
		 (tree-equal format-args *last-format-args*))
ram's avatar
ram committed
      (note-message-repeats nil)
wlott's avatar
wlott committed
      (setq *last-format-string* format-string)
      (setq *last-format-args* format-args)
      (format stream "~&~:(~A~): ~?~&" what format-string format-args)))
wlott's avatar
wlott committed
  
  (incf *last-message-count*)
  (undefined-value))


;;; Keep track of how many times each kind of warning happens.
;;;
(proclaim '(type index *compiler-error-count* *compiler-warning-count*
wlott's avatar
wlott committed
		 *compiler-note-count*))
(defvar *compiler-error-count* 0)
(defvar *compiler-warning-count* 0)
(defvar *compiler-note-count* 0)


;;; Compiler-Error, ...  --  Interface
;;;
;;;    Increment the count and print the message.  Compiler-Note never prints
;;; anything when Brevity is 3.  Compiler-Error calls the bailout function
;;; so that it never returns.  Compiler-Error-Message returns like
;;; Compiler-Warning, but prints a message like Compiler-Error.
;;;
(proclaim '(ftype (function (string &rest t) void)
		  compiler-error compiler-warning compiler-note))
;;;
(defun compiler-error (format-string &rest format-args)
  (incf *compiler-error-count*)
  (print-error-message :error format-string format-args)
wlott's avatar
wlott committed
  (funcall *compiler-error-bailout*)
  (error "*Compiler-Error-Bailout* returned?"))
;;;
(defun compiler-error-message (format-string &rest format-args)
  (incf *compiler-error-count*)
  (print-error-message :error format-string format-args))
wlott's avatar
wlott committed
;;;
(defun compiler-warning (format-string &rest format-args)
  (incf *compiler-warning-count*)
  (print-error-message :warning format-string format-args))
wlott's avatar
wlott committed
;;;
(defun compiler-note (format-string &rest format-args)
  (unless (if *compiler-error-context*
	      (policy *compiler-error-context* (= brevity 3))
	      (policy nil (= brevity 3)))
    (print-error-message :note format-string format-args)))
wlott's avatar
wlott committed


;;; Compiler-Mumble  --  Interface
;;;
;;;    The politically correct way to print out random progress messages and
;;; such like.  We clear the current error context so that we know that it
;;; needs to be reprinted, and we also Force-Output so that the message gets
;;; seen right away.
;;;
(proclaim '(function compiler-mumble (string &rest t) void))
(defun compiler-mumble (format-string &rest format-args)
ram's avatar
ram committed
  (note-message-repeats)
  (setq *last-error-context* nil)
wlott's avatar
wlott committed
  (apply #'format *compiler-error-output* format-string format-args)
  (force-output *compiler-error-output*))
wlott's avatar
wlott committed


;;; Find-Component-Name  --  Interface
;;;
;;;    Return a string that somehow names the code in Component.  We use the
;;; source path for the bind node for an arbitrary entry point to find the
;;; source context, then return that as a string.
;;;
(proclaim  '(function find-component-name (component) simple-string))
(defun find-component-name (component)
  (let ((ep (first (block-succ (component-head component)))))
    (assert ep () "No entry points?")
    (multiple-value-bind
	(form context)
	(find-original-source
	 (node-source-path (continuation-next (block-start ep))))
      (declare (ignore form))
      (let ((*print-level* 2)
	    (*print-pretty* nil))
	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))


;;;; Undefined warnings:


(defvar *undefined-warning-limit* 3
  "If non-null, then an upper limit on the number of unknown function or type
  warnings that the compiler will print for any given name in a single
  compilation.  This prevents excessive amounts of output when there really is
  a missing definition (as opposed to a typo in the use.)")


;;; NOTE-UNDEFINED-REFERENCE  --  Interface
;;;
;;;    Make an entry in the *UNDEFINED-WARNINGS* describing a reference to Name
;;; of the specified Kind.  If we have exceeded the warning limit, then just
;;; increment the count, otherwise note the current error context.
;;;
(defun note-undefined-reference (name kind)
  (unless (policy nil (= brevity 3))
    (let* ((found (dolist (warn *undefined-warnings* nil)
		    (when (and (equal (undefined-warning-name warn) name)
			       (eq (undefined-warning-kind warn) kind))
		      (return warn))))
	   (res (or found
		    (make-undefined-warning :name name :kind kind))))
      (unless found (push res *undefined-warnings*))
      (when (or (not *undefined-warning-limit*)
		(< (undefined-warning-count res) *undefined-warning-limit*))
	(push (find-error-context (list name))
	      (undefined-warning-warnings res)))
      (incf (undefined-warning-count res))))
  (undefined-value))

wlott's avatar
wlott committed

;;;; Careful call:

;;; Careful-Call  --  Interface
;;;
;;;    Apply a function to some arguments, returning a list of the values
;;; resulting of the evaulation.  If an error is signalled during the
;;; application, then we print a warning message and return NIL as our second
;;; value to indicate this.  Node is used as the error context for any error
;;; message, and Context is a string that is spliced into the warning.
;;;
(proclaim '(function careful-call ((or symbol function) list node string)
		     (values list boolean)))
wlott's avatar
wlott committed
(defun careful-call (function args node context)
  (values
   (multiple-value-list
    (handler-case (apply function args)
      (error (condition)
	(let ((*compiler-error-context* node))
	  (compiler-warning "Lisp error during ~A:~%~A" context condition)
	  (return-from careful-call (values nil nil))))))
   t))


;;;; Generic list (?) functions:

(proclaim '(inline find-in position-in map-in))

wlott's avatar
wlott committed
;;; Find-In  --  Interface
;;;
(defun find-in (next element list &key (key #'identity)
		     (test #'eql test-p) (test-not nil not-p))
  "Find Element in a null-terminated List linked by the accessor function
  Next.  Key, Test and Test-Not are the same as for generic sequence
  functions."
  (when (and test-p not-p)
    (error "Silly to supply both :Test and :Test-Not."))
  (if not-p
      (do ((current list (funcall next current)))
	  ((null current) nil)
	(unless (funcall test-not (funcall key current) element)
	  (return current)))
      (do ((current list (funcall next current)))
	  ((null current) nil)
	(when (funcall test (funcall key current) element)
	  (return current)))))

;;; Position-In  --  Interface
;;;
(defun position-in (next element list &key (key #'identity)
		     (test #'eql test-p) (test-not nil not-p))
  "Return the position of Element (or NIL if absent) in a null-terminated List
  linked by the accessor function Next.  Key, Test and Test-Not are the same as
  for generic sequence functions."
  (when (and test-p not-p)
    (error "Silly to supply both :Test and :Test-Not."))
  (if not-p
      (do ((current list (funcall next current))
	   (i 0 (1+ i)))
	  ((null current) nil)
	(unless (funcall test-not (funcall key current) element)
	  (return i)))
      (do ((current list (funcall next current))
	   (i 0 (1+ i)))