Skip to content
Snippets Groups Projects
ir1util.lisp 53.1 KiB
Newer Older
wlott's avatar
wlott committed
;;;    Return the COMBINATION node that is the call to the let Fun.
;;;
(defun let-combination (fun)
  (declare (type clambda fun))
  (assert (eq (functional-kind fun) :let))
  (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* *current-form*))


;;; 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.
;;; 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.
;;;
(defstruct (compiler-error-context
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore s d))
	       (format stream "#<Compiler-Error-Context>"))))
  ;;
  ;; The form immediately responsible for this error (may be the result of
  ;; mecroexpansion, etc.)
  source
  ;;
  ;; The form in the original source that expanded into Source.
  original-source
  ;;
  ;; A list of prefixes of "interesting" forms that enclose original-source.
ram's avatar
ram committed
  context
  ;;
  ;; Source for a form enclosing this one, or NIL if unknown.
  enclosing-source
  ;;
  ;; Description of how the value of SOURCE is used by ENCLOSING-SOURCE such as
  ;; "third argument", "set value", etc.  Null when there is no
  ;; ENCLOSING-SOURCE.
  (enclosed-how nil :type (or simple-string null)))
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)


;;; A list of "DEFxxx" forms for which we should we should compute the source
;;; context by taking the CAR of the first arg when it is a list.
;;;
(defparameter defmumble-take-car-forms '(defstruct))


;;; 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))
  (assert path)
  (let* ((rpath (reverse (rest path)))
wlott's avatar
wlott committed
	 (root (find-source-root (first rpath) *source-info*)))
    (collect ((context))
      (let ((form root)
	    (current (rest rpath)))
	(loop
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))
		  (if (>= (length form) 2)
		      (let ((next (second form)))
			(context
			 (list head
			       (if (and (listp next)
					(member head
						defmumble-take-car-forms))
				   (car next)
				   next))))
		      (context (list head)))))))
	  (setq form (nth (pop current) form)))
	
	(cond ((context)
	       (values form (context)))
	      ((and path root)
	       (if (listp root)
		   (values form (list (subseq root 0 (min 2 (length root)))))
		   (values form ())))
	      (t
	       (values '(unable to locate source)
		       '((some strange place)))))))))


ram's avatar
ram committed
;;; FIND-ENCLOSING-SOURCE  --  Internal
;;;
;;;    Look at the DEST of node, and return the source for it, along with a
;;; description of how the value is used by the DEST.
;;;
(defun find-enclosing-source (node)
  (declare (type node node))
  (let* ((cont (node-cont node))
	 (dest (continuation-dest cont)))
    (when dest
      (values
	(node-source dest)
	(etypecase dest
	  (cif "conditional test value")
	  (cset "assigned value")
	  (creturn "function return value")
	  (exit "RETURN'ed value")
	  (basic-combination
	   (if (eq cont (basic-combination-fun dest))
	       "called function"
	       (format nil "~:R argument"
		       (1+ (position cont
				     (basic-combination-args dest)))))))))))
	  

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.
;;;
(defun find-error-context ()
  (let ((context *compiler-error-context*))
    (if (compiler-error-context-p context)
	context
	(let ((source (cond (*current-form*)
			    (context (node-source context))
			    (t nil)))
	      (path (if context (node-source-path context) *current-path*)))
	  (when (and *source-info* path)
	    (multiple-value-bind (form src-context)
				 (find-original-source path)
ram's avatar
ram committed
	      (multiple-value-bind (enclosing how)
				   (when (and context (not *current-form*))
				     (find-enclosing-source context))
		(make-compiler-error-context
		 :source source
		 :original-source form
		 :context src-context
		 :enclosing-source enclosing
		 :enclosed-how how))))))))
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.")))

;;; 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*))
(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.")


;;; We save the context information that we printed out most recently so that
;;; we don't print it out redundantly.
;;;
(proclaim '(list *last-source-context*))
(defvar *last-source-context* nil)
(defvar *last-original-source* nil)
(defvar *last-source-form* nil)
ram's avatar
ram committed
(defvar *last-enclosing-source* nil)
wlott's avatar
wlott committed
(defvar *last-format-string* nil)
(defvar *last-format-args* nil)
(defvar *last-message-count* 0)

;;; The stream that compiler error output is directed to, or NIL if error
;;; output is inhibited.
;;;
(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
(proclaim '(type (or stream null) *compiler-error-output*))


;;; 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.
;;;
(defun note-message-repeats ()
ram's avatar
ram committed
  (cond ((= *last-message-count* 1) (terpri *compiler-error-output*))
	((> *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 (string what format-string) (list format-args))
  (let* ((*print-level* *error-print-level*)
	 (*print-length* *error-print-length*)
	 (stream *compiler-error-output*)
	 (context (find-error-context)))
    
    (unless stream (return-from print-error-message (undefined-value)))
    
    (cond
     (context
      (let ((context (compiler-error-context-context context))
	    (form (compiler-error-context-original-source context))
ram's avatar
ram committed
	    (source (compiler-error-context-source context))
	    (enclosing (compiler-error-context-enclosing-source context))
	    (how (compiler-error-context-enclosed-how context)))
wlott's avatar
wlott committed
	
ram's avatar
ram committed
	(unless (tree-equal context *last-source-context*)
wlott's avatar
wlott committed
	  (note-message-repeats)
	  (setq *last-source-context* context)
	  (setq *last-original-source* nil)
	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" context))
ram's avatar
ram committed
l	
	(unless (tree-equal form *last-original-source*)
wlott's avatar
wlott committed
	  (note-message-repeats)
	  (setq *last-original-source* form)
ram's avatar
ram committed
	  (setq *last-enclosing-source* nil)
	  (setq *last-format-string* nil) 
wlott's avatar
wlott committed
	  (format stream "  ~S~%" form))
ram's avatar
ram committed

	(unless (or (tree-equal source form)
		    (member source form))
	  (unless (tree-equal enclosing *last-enclosing-source*)
	    (note-message-repeats)
	    (setq *last-source-form* '#(invalid))
	    (setq *last-enclosing-source* enclosing)
	    (format stream "==>~%  ~S~%" enclosing))
	  
	  (unless (tree-equal source *last-source-form*)
	    (note-message-repeats)
	    (setq *last-source-form* source)
	    (setq *last-format-string* nil)
	    (unless (member source format-args)
	      (if *last-enclosing-source*
		  (format stream "The ~A:~%  ~S~%" how source)
		  (format stream "==>~%  ~S~%" source)))))))
wlott's avatar
wlott committed
     (t
      (note-message-repeats)
      (format stream "~2&")))
    
    (unless (and (equal format-string *last-format-string*)
ram's avatar
ram committed
		 (tree-equal format-args *last-format-args*))
wlott's avatar
wlott committed
      (note-message-repeats)
      (setq *last-format-string* format-string)
      (setq *last-format-args* format-args)
      (format stream "~&~A: ~?~&" what format-string format-args)))
  
  (incf *last-message-count*)
  (undefined-value))


;;; Keep track of how many times each kind of warning happens.
;;;
(proclaim '(type unsigned-byte *compiler-error-count* *compiler-warning-count*
		 *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)
  (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))
;;;
(defun compiler-warning (format-string &rest format-args)
  (incf *compiler-warning-count*)
  (print-error-message "Warning" format-string format-args))
;;;
(defun compiler-note (format-string &rest format-args)
  (incf *compiler-note-count*)
  (unless (if *compiler-error-context*
	      (policy *compiler-error-context* (= brevity 3))
	      (policy nil (= brevity 3)))
    (print-error-message "Note" format-string format-args)))


;;; 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)
  (when *last-format-string*
    (note-message-repeats)
    (terpri *compiler-error-output*)
    (setq *last-source-context* nil)
    (setq *last-format-string* nil))
  (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:


;;; A list of UNDEFINED-WARNING structures representing the calls to unknown
;;; functions.  This is bound by WITH-COMPILATION-UNIT.
;;;
(defvar *undefined-warnings*)
(proclaim '(list *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)
  (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)
	      (undefined-warning-warnings res)))
    (incf (undefined-warning-count res)))
  (undefined-value))


;;; NOTE-NAME-DEFINED  --  Interface
;;;
;;;    Delete any undefined warnings for Name and Kind.
;;;
(defun note-name-defined (name kind)
  (setq *undefined-warnings*
	(delete-if #'(lambda (x)
		       (and (equal (undefined-warning-name x) name)
			    (eq (undefined-warning-kind x) kind)))
		   *undefined-warnings*))

  (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 (function list node string) (values list boolean)))
(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:

;;; 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)))
	  ((null current) nil)
	(when (funcall test (funcall key current) element)
	  (return i)))))


;;; Map-In  --  Interface
;;;
(defun map-in (next function list)
  "Map Function over the elements in a null-terminated List linked by the
  accessor function Next, returning a list of the results."
  (collect ((res))
    (do ((current list (funcall next current)))
	((null current))
      (res (funcall function current)))
    (res)))


;;; Deletef-In  --  Interface
;;;
(defmacro deletef-in (next place item &environment env)
  "Deletef-In Next Place Item
  Delete Item from a null-terminated list linked by the accessor function Next
  that is stored in Place.  Item must appear exactly once in the list."
  (multiple-value-bind
      (temps vals stores store access)
      #-new-compiler
      (if clc::*in-the-compiler*
	  (get-setf-method place env)
	  (lisp::foo-get-setf-method place env))
      #+new-compiler
      (lisp::foo-get-setf-method place env)
    (let ((n-item (gensym))
	  (n-place (gensym))
	  (n-current (gensym))
	  (n-prev (gensym)))
      `(let* (,@(mapcar #'list temps vals)
	      (,n-place ,access)
	      (,n-item ,item))
	 (if (eq ,n-place ,n-item)
	     (let ((,(first stores) (,next ,n-place)))
	       ,store)
	     (do ((,n-prev ,n-place ,n-current)
		  (,n-current (,next ,n-place)
			      (,next ,n-current)))
		 ((eq ,n-current ,n-item)
		  (setf (,next ,n-prev)
			(,next ,n-current)))))
	 (undefined-value)))))


;;; Push-In  --  Interface
;;;
(defmacro push-in (next item place &environment env)
  "Push Item onto a list linked by the accessor function Next that is stored in
  Place."
  (multiple-value-bind
      (temps vals stores store access)
      #-new-compiler
      (if clc::*in-the-compiler*
	  (get-setf-method place env)
	  (lisp::foo-get-setf-method place env))
      #+new-compiler
      (lisp::foo-get-setf-method place env)
    `(let (,@(mapcar #'list temps vals)
	   (,(first stores) ,item))
       (setf (,next ,(first stores)) ,access)
       ,store
       (undefined-value))))


;;; Compiler-Constantp  --  Interface
;;;
;;;    We don't want to assume that a variable is a constant just because it is
;;; in the current lisp environment.
;;;
;;; ### For now, just use CONSTANTP to avoid bootstrapping problems with having
;;; to have the INFO database available at meta-compile time.
;;;
(proclaim '(function compiler-constantp (t) boolean))
(defun compiler-constantp (exp)
  "Like constantp, only uses the compilation environment rather than the
  current Lisp environment."
#|
  (if (symbolp exp)
      (eq (info variable kind exp) :constant)
      (constantp exp))
|#
  (constantp exp))