src/compiler/ir1report.lisp

   1 ;;;; machinery for reporting errors/warnings/notes/whatnot from
   2 ;;;; the compiler
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!C")
  14 \f
  15 ;;;; compiler error context determination
  16
  17 (declaim (special *current-path*))
  18
  19 ;;; We bind print level and length when printing out messages so that
  20 ;;; we don't dump huge amounts of garbage.
  21 ;;;
  22 ;;; FIXME: It's not possible to get the defaults right for everyone.
  23 ;;; So: Should these variables be in the SB-EXT package? Or should we
  24 ;;; just get rid of them completely and just use the bare
  25 ;;; CL:*PRINT-FOO* variables instead?
  26 (declaim (type (or unsigned-byte null)
  27                *compiler-error-print-level*
  28                *compiler-error-print-length*
  29                *compiler-error-print-lines*))
  30 (defvar *compiler-error-print-level* 5
  31   #!+sb-doc
  32   "the value for *PRINT-LEVEL* when printing compiler error messages")
  33 (defvar *compiler-error-print-length* 10
  34   #!+sb-doc
  35   "the value for *PRINT-LENGTH* when printing compiler error messages")
  36 (defvar *compiler-error-print-lines* 12
  37   #!+sb-doc
  38   "the value for *PRINT-LINES* when printing compiler error messages")
  39
  40 (defvar *enclosing-source-cutoff* 1
  41   #!+sb-doc
  42   "The maximum number of enclosing non-original source forms (i.e. from
  43   macroexpansion) that we print in full. For additional enclosing forms, we
  44   print only the CAR.")
  45 (declaim (type unsigned-byte *enclosing-source-cutoff*))
  46
  47 ;;; We separate the determination of compiler error contexts from the
  48 ;;; actual signalling of those errors by objectifying the error
  49 ;;; context. This allows postponement of the determination of how (and
  50 ;;; if) to signal the error.
  51 ;;;
  52 ;;; We take care not to reference any of the IR1 so that pending
  53 ;;; potential error messages won't prevent the IR1 from being GC'd. To
  54 ;;; this end, we convert source forms to strings so that source forms
  55 ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
  56 (defstruct (compiler-error-context
  57             #-no-ansi-print-object
  58             (:print-object (lambda (x stream)
  59                              (print-unreadable-object (x stream :type t))))
  60             (:copier nil))
  61   ;; a list of the stringified CARs of the enclosing non-original source forms
  62   ;; exceeding the *enclosing-source-cutoff*
  63   (enclosing-source nil :type list)
  64   ;; a list of stringified enclosing non-original source forms
  65   (source nil :type list)
  66   ;; the stringified form in the original source that expanded into SOURCE
  67   (original-source (missing-arg) :type simple-string)
  68   ;; a list of prefixes of "interesting" forms that enclose original-source
  69   (context nil :type list)
  70   ;; the FILE-INFO-NAME for the relevant FILE-INFO
  71   (file-name (missing-arg) :type (or pathname (member :lisp :stream)))
  72   ;; the file position at which the top level form starts, if applicable
  73   (file-position nil :type (or index null))
  74   ;; the original source part of the source path
  75   (original-source-path nil :type list))
  76
  77 ;;; If true, this is the node which is used as context in compiler warning
  78 ;;; messages.
  79 (declaim (type (or null compiler-error-context node) *compiler-error-context*))
  80 (defvar *compiler-error-context* nil)
  81
  82 ;;; a hashtable mapping macro names to source context parsers. Each parser
  83 ;;; function returns the source-context list for that form.
  84 (defvar *source-context-methods* (make-hash-table))
  85
  86 ;;; documentation originally from cmu-user.tex:
  87 ;;;   This macro defines how to extract an abbreviated source context from
  88 ;;;   the \var{name}d form when it appears in the compiler input.
  89 ;;;   \var{lambda-list} is a \code{defmacro} style lambda-list used to
  90 ;;;   parse the arguments. The \var{body} should return a list of
  91 ;;;   subforms that can be printed on about one line. There are
  92 ;;;   predefined methods for \code{defstruct}, \code{defmethod}, etc. If
  93 ;;;   no method is defined, then the first two subforms are returned.
  94 ;;;   Note that this facility implicitly determines the string name
  95 ;;;   associated with anonymous functions.
  96 ;;; So even though SBCL itself only uses this macro within this file,
  97 ;;; it's a reasonable thing to put in SB-EXT in case some dedicated
  98 ;;; user wants to do some heavy tweaking to make SBCL give more
  99 ;;; informative output about his code.
 100 (defmacro define-source-context (name lambda-list &body body)
 101   #!+sb-doc
 102   "DEFINE-SOURCE-CONTEXT Name Lambda-List Form*
 103    This macro defines how to extract an abbreviated source context from the
 104    Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
 105    style lambda-list used to parse the arguments. The Body should return a
 106    list of subforms suitable for a \"~{~S ~}\" format string."
 107   (let ((n-whole (gensym)))
 108     `(setf (gethash ',name *source-context-methods*)
 109            (lambda (,n-whole)
 110              (destructuring-bind ,lambda-list ,n-whole ,@body)))))
 111
 112 (defmacro def-source-context (&rest rest)
 113   (deprecation-warning 'def-source-context 'define-source-context)
 114   `(define-source-context ,@rest))
 115
 116 (define-source-context defstruct (name-or-options &rest slots)
 117   (declare (ignore slots))
 118   `(defstruct ,(if (consp name-or-options)
 119                    (car name-or-options)
 120                    name-or-options)))
 121
 122 (define-source-context function (thing)
 123   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
 124       `(lambda ,(second thing))
 125       `(function ,thing)))
 126
 127 ;;; Return the first two elements of FORM if FORM is a list. Take the
 128 ;;; CAR of the second form if appropriate.
 129 (defun source-form-context (form)
 130   (cond ((atom form) nil)
 131         ((>= (length form) 2)
 132          (funcall (gethash (first form) *source-context-methods*
 133                            (lambda (x)
 134                              (declare (ignore x))
 135                              (list (first form) (second form))))
 136                   (rest form)))
 137         (t
 138          form)))
 139
 140 ;;; Given a source path, return the original source form and a
 141 ;;; description of the interesting aspects of the context in which it
 142 ;;; appeared. The context is a list of lists, one sublist per context
 143 ;;; form. The sublist is a list of some of the initial subforms of the
 144 ;;; context form.
 145 ;;;
 146 ;;; For now, we use the first two subforms of each interesting form. A
 147 ;;; form is interesting if the first element is a symbol beginning
 148 ;;; with "DEF" and it is not the source form. If there is no
 149 ;;; DEF-mumble, then we use the outermost containing form. If the
 150 ;;; second subform is a list, then in some cases we return the CAR of
 151 ;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
 152 ;;; options, etc.)
 153 (defun find-original-source (path)
 154   (declare (list path))
 155   (let* ((rpath (reverse (source-path-original-source path)))
 156          (tlf (first rpath))
 157          (root (find-source-root tlf *source-info*)))
 158     (collect ((context))
 159       (let ((form root)
 160             (current (rest rpath)))
 161         (loop
 162           (when (atom form)
 163             (aver (null current))
 164             (return))
 165           (let ((head (first form)))
 166             (when (symbolp head)
 167               (let ((name (symbol-name head)))
 168                 (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
 169                   (context (source-form-context form))))))
 170           (when (null current) (return))
 171           (setq form (nth (pop current) form)))
 172
 173         (cond ((context)
 174                (values form (context)))
 175               ((and path root)
 176                (let ((c (source-form-context root)))
 177                  (values form (if c (list c) nil))))
 178               (t
 179                (values '(unable to locate source)
 180                        '((some strange place)))))))))
 181
 182 ;;; Convert a source form to a string, suitably formatted for use in
 183 ;;; compiler warnings.
 184 (defun stringify-form (form &optional (pretty t))
 185   (with-standard-io-syntax
 186    (let ((*print-readably* nil)
 187          (*print-pretty* pretty)
 188          (*print-level* *compiler-error-print-level*)
 189          (*print-length* *compiler-error-print-length*)
 190          (*print-lines* *compiler-error-print-lines*))
 191      (if pretty
 192          (format nil "~<~@;  ~S~:>" (list form))
 193          (prin1-to-string form)))))
 194
 195 ;;; shorthand for creating debug names from source names or other
 196 ;;; stems, e.g.
 197 ;;;   (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
 198 ;;;   (DEBUG-NAMIFY "top level form ~S" FORM)
 199 ;;;
 200 ;;; FIXME: This function seems to have a lot in common with
 201 ;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
 202 ;;; functions.
 203 (defun debug-namify (format-string &rest format-arguments)
 204   (with-standard-io-syntax
 205    (let ((*print-readably* nil)
 206          (*package* *cl-package*)
 207          (*print-length* 3)
 208          (*print-level* 2))
 209      (apply #'format nil format-string format-arguments))))
 210
 211 ;;; shorthand for a repeated idiom in creating debug names
 212 ;;;
 213 ;;; the problem, part I: We want to create debug names that look like
 214 ;;; "&MORE processor for <something>" where <something> might be
 215 ;;; either a source-name value (typically a symbol) or a non-symbol
 216 ;;; debug-name value (typically a string). It's awkward to handle this
 217 ;;; with FORMAT because we'd like to splice a source-name value using
 218 ;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
 219 ;;; (to avoid irrelevant quotes at string splice boundaries).
 220 ;;;
 221 ;;; the problem, part II: The <something> is represented as a pair
 222 ;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
 223 ;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily
 224 ;;; we don't use a value if it's NIL, instead defaulting it. But we
 225 ;;; can't safely/comfortably use NIL for that in this context, since
 226 ;;; the app programmer can use NIL as a name, so we use the private
 227 ;;; symbol .ANONYMOUS. instead.)
 228 ;;;
 229 ;;; the solution: Use this function to convert whatever it is to a
 230 ;;; string, which FORMAT can then splice using "~A".
 231 (defun as-debug-name (source-name debug-name)
 232   (if (eql source-name '.anonymous.)
 233       debug-name
 234       (debug-namify "~S" source-name)))
 235
 236 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
 237 ;;; error context, or NIL if we can't figure anything out. ARGS is a
 238 ;;; list of things that are going to be printed out in the error
 239 ;;; message, and can thus be blown off when they appear in the source
 240 ;;; context.
 241 (defun find-error-context (args)
 242   (let ((context *compiler-error-context*))
 243     (if (compiler-error-context-p context)
 244         context
 245         (let ((path (or (and (boundp '*current-path*) *current-path*)
 246                         (if context
 247                             (node-source-path context)
 248                             nil))))
 249           (when (and *source-info* path)
 250             (multiple-value-bind (form src-context) (find-original-source path)
 251               (collect ((full nil cons)
 252                         (short nil cons))
 253                 (let ((forms (source-path-forms path))
 254                       (n 0))
 255                   (dolist (src (if (member (first forms) args)
 256                                    (rest forms)
 257                                    forms))
 258                     (if (>= n *enclosing-source-cutoff*)
 259                         (short (stringify-form (if (consp src)
 260                                                    (car src)
 261                                                    src)
 262                                                nil))
 263                         (full (stringify-form src)))
 264                     (incf n)))
 265
 266                 (let* ((tlf (source-path-tlf-number path))
 267                        (file-info (source-info-file-info *source-info*)))
 268                   (make-compiler-error-context
 269                    :enclosing-source (short)
 270                    :source (full)
 271                    :original-source (stringify-form form)
 272                    :context src-context
 273                    :file-name (file-info-name file-info)
 274                    :file-position
 275                    (multiple-value-bind (ignore pos)
 276                        (find-source-root tlf *source-info*)
 277                      (declare (ignore ignore))
 278                      pos)
 279                    :original-source-path
 280                    (source-path-original-source path))))))))))
 281 \f
 282 ;;;; printing error messages
 283
 284 ;;; We save the context information that we printed out most recently
 285 ;;; so that we don't print it out redundantly.
 286
 287 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
 288 (defvar *last-error-context* nil)
 289 (declaim (type (or compiler-error-context null) *last-error-context*))
 290
 291 ;;; The format string and args for the last error we printed.
 292 (defvar *last-format-string* nil)
 293 (defvar *last-format-args* nil)
 294 (declaim (type (or string null) *last-format-string*))
 295 (declaim (type list *last-format-args*))
 296
 297 ;;; The number of times that the last error message has been emitted,
 298 ;;; so that we can compress duplicate error messages.
 299 (defvar *last-message-count* 0)
 300 (declaim (type index *last-message-count*))
 301
 302 ;;; If the last message was given more than once, then print out an
 303 ;;; indication of how many times it was repeated. We reset the message
 304 ;;; count when we are done.
 305 (defun note-message-repeats (&optional (terpri t))
 306   (cond ((= *last-message-count* 1)
 307          (when terpri (terpri *error-output*)))
 308         ((> *last-message-count* 1)
 309           (format *error-output* "~&; [Last message occurs ~W times.]~2%"
 310                  *last-message-count*)))
 311   (setq *last-message-count* 0))
 312
 313 ;;; Print out the message, with appropriate context if we can find it.
 314 ;;; If the context is different from the context of the last message
 315 ;;; we printed, then we print the context. If the original source is
 316 ;;; different from the source we are working on, then we print the
 317 ;;; current source in addition to the original source.
 318 ;;;
 319 ;;; We suppress printing of messages identical to the previous, but
 320 ;;; record the number of times that the message is repeated.
 321 (defun print-compiler-message (format-string format-args)
 322
 323   (declare (type simple-string format-string))
 324   (declare (type list format-args))
 325
 326   (let ((stream *error-output*)
 327         (context (find-error-context format-args)))
 328     (cond
 329      (context
 330       (let ((file (compiler-error-context-file-name context))
 331             (in (compiler-error-context-context context))
 332             (form (compiler-error-context-original-source context))
 333             (enclosing (compiler-error-context-enclosing-source context))
 334             (source (compiler-error-context-source context))
 335             (last *last-error-context*))
 336
 337         (unless (and last
 338                      (equal file (compiler-error-context-file-name last)))
 339           (when (pathnamep file)
 340             (note-message-repeats)
 341             (setq last nil)
 342             (format stream "~2&; file: ~A~%" (namestring file))))
 343
 344         (unless (and last
 345                      (equal in (compiler-error-context-context last)))
 346           (note-message-repeats)
 347           (setq last nil)
 348           (format stream "~&")
 349           (pprint-logical-block (stream nil :per-line-prefix "; ")
 350             (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
 351           (format stream "~%"))
 352
 353
 354         (unless (and last
 355                      (string= form
 356                               (compiler-error-context-original-source last)))
 357           (note-message-repeats)
 358           (setq last nil)
 359           (format stream "~&")
 360           (pprint-logical-block (stream nil :per-line-prefix "; ")
 361             (format stream "  ~A" form))
 362           (format stream "~&"))
 363
 364         (unless (and last
 365                      (equal enclosing
 366                             (compiler-error-context-enclosing-source last)))
 367           (when enclosing
 368             (note-message-repeats)
 369             (setq last nil)
 370             (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
 371
 372         (unless (and last
 373                      (equal source (compiler-error-context-source last)))
 374           (setq *last-format-string* nil)
 375           (when source
 376             (note-message-repeats)
 377             (dolist (src source)
 378               (format stream "~&")
 379               (write-string "; ==>" stream)
 380               (format stream "~&")
 381               (pprint-logical-block (stream nil :per-line-prefix "; ")
 382                 (write-string src stream)))))))
 383      (t
 384        (format stream "~&")
 385       (note-message-repeats)
 386       (setq *last-format-string* nil)
 387        (format stream "~&")))
 388
 389     (setq *last-error-context* context)
 390
 391     (unless (and (equal format-string *last-format-string*)
 392                  (tree-equal format-args *last-format-args*))
 393       (note-message-repeats nil)
 394       (setq *last-format-string* format-string)
 395       (setq *last-format-args* format-args)
 396       (let ((*print-level*  *compiler-error-print-level*)
 397             (*print-length* *compiler-error-print-length*)
 398             (*print-lines*  *compiler-error-print-lines*))
 399         (format stream "~&")
 400         (pprint-logical-block (stream nil :per-line-prefix "; ")
 401           (format stream "~&~?" format-string format-args))
 402         (format stream "~&"))))
 403
 404   (incf *last-message-count*)
 405   (values))
 406
 407 (defun print-compiler-condition (condition)
 408   (declare (type condition condition))
 409   (let (;; These different classes of conditions have different
 410         ;; effects on the return codes of COMPILE-FILE, so it's nice
 411         ;; for users to be able to pick them out by lexical search
 412         ;; through the output.
 413         (what (etypecase condition
 414                 (style-warning 'style-warning)
 415                 (warning 'warning)
 416                 (error 'error))))
 417     (multiple-value-bind (format-string format-args)
 418         (if (typep condition 'simple-condition)
 419             (values (simple-condition-format-control condition)
 420                     (simple-condition-format-arguments condition))
 421             (values "~A"
 422                     (list (with-output-to-string (s)
 423                             (princ condition s)))))
 424       (print-compiler-message (format nil
 425                                       "caught ~S:~%  ~A"
 426                                       what
 427                                       format-string)
 428                               format-args)))
 429   (values))
 430
 431 ;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
 432 ;;; condition-signalling functions, but it just writes some output
 433 ;;; instead of signalling. (In CMU CL, it did signal a condition, but
 434 ;;; this didn't seem to work all that well; it was weird to have
 435 ;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
 436 ;;; that the compiler couldn't figure out how to compile something as
 437 ;;; efficiently as it liked.)
 438 (defun compiler-note (format-string &rest format-args)
 439   (unless (if *compiler-error-context*
 440               (policy *compiler-error-context* (= inhibit-warnings 3))
 441               (policy *lexenv* (= inhibit-warnings 3)))
 442     (incf *compiler-note-count*)
 443     (print-compiler-message (format nil "note: ~A" format-string)
 444                             format-args))
 445   (values))
 446
 447 ;;; Issue a note when we might or might not be in the compiler.
 448 (defun maybe-compiler-note (&rest rest)
 449   (if (boundp '*lexenv*) ; if we're in the compiler
 450       (apply #'compiler-note rest)
 451       (let ((stream *error-output*))
 452         (pprint-logical-block (stream nil :per-line-prefix ";")
 453
 454           (format stream " note: ~3I~_")
 455           (pprint-logical-block (stream nil)
 456             (apply #'format stream rest)))
 457         (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
 458
 459 ;;; The politically correct way to print out progress messages and
 460 ;;; such like. We clear the current error context so that we know that
 461 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
 462 ;;; message gets seen right away.
 463 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
 464 (defun compiler-mumble (format-string &rest format-args)
 465   (note-message-repeats)
 466   (setq *last-error-context* nil)
 467   (apply #'format *error-output* format-string format-args)
 468   (force-output *error-output*)
 469   (values))
 470
 471 ;;; Return a string that somehow names the code in COMPONENT. We use
 472 ;;; the source path for the bind node for an arbitrary entry point to
 473 ;;; find the source context, then return that as a string.
 474 (declaim (ftype (function (component) simple-string) find-component-name))
 475 (defun find-component-name (component)
 476   (let ((ep (first (block-succ (component-head component)))))
 477     (aver ep) ; else no entry points??
 478     (multiple-value-bind (form context)
 479         (find-original-source
 480          (node-source-path (continuation-next (block-start ep))))
 481       (declare (ignore form))
 482       (let ((*print-level* 2)
 483             (*print-pretty* nil))
 484         (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
 485 \f
 486 ;;;; condition system interface
 487
 488 ;;; Keep track of how many times each kind of condition happens.
 489 (defvar *compiler-error-count*)
 490 (defvar *compiler-warning-count*)
 491 (defvar *compiler-style-warning-count*)
 492 (defvar *compiler-note-count*)
 493
 494 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
 495 ;;; should return WARNINGS-P or FAILURE-P.
 496 (defvar *failure-p*)
 497 (defvar *warnings-p*)
 498
 499 ;;; condition handlers established by the compiler. We re-signal the
 500 ;;; condition, then if it isn't handled, we increment our warning
 501 ;;; counter and print the error message.
 502 (defun compiler-error-handler (condition)
 503   (signal condition)
 504   (incf *compiler-error-count*)
 505   (setf *warnings-p* t
 506         *failure-p* t)
 507   (print-compiler-condition condition)
 508   (continue condition))
 509 (defun compiler-warning-handler (condition)
 510   (signal condition)
 511   (incf *compiler-warning-count*)
 512   (setf *warnings-p* t
 513         *failure-p* t)
 514   (print-compiler-condition condition)
 515   (muffle-warning condition))
 516 (defun compiler-style-warning-handler (condition)
 517   (signal condition)
 518   (incf *compiler-style-warning-count*)
 519   (setf *warnings-p* t)
 520   (print-compiler-condition condition)
 521   (muffle-warning condition))
 522 \f
 523 ;;;; undefined warnings
 524
 525 (defvar *undefined-warning-limit* 3
 526   #!+sb-doc
 527   "If non-null, then an upper limit on the number of unknown function or type
 528   warnings that the compiler will print for any given name in a single
 529   compilation. This prevents excessive amounts of output when the real
 530   problem is a missing definition (as opposed to a typo in the use.)")
 531
 532 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
 533 ;;; to NAME of the specified KIND. If we have exceeded the warning
 534 ;;; limit, then just increment the count, otherwise note the current
 535 ;;; error context.
 536 ;;;
 537 ;;; Undefined types are noted by a condition handler in
 538 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
 539 ;;; the compiler, hence the BOUNDP check.
 540 (defun note-undefined-reference (name kind)
 541   (unless (and
 542            ;; Check for boundness so we don't blow up if we're called
 543            ;; when IR1 conversion isn't going on.
 544            (boundp '*lexenv*)
 545            ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
 546            ;; isn't a good idea; we should have INHIBIT-WARNINGS
 547            ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
 548            ;; sure what the BOUNDP '*LEXENV* test above is for; it's
 549            ;; likely a good idea, but it probably deserves an
 550            ;; explanatory comment.
 551            (policy *lexenv* (= inhibit-warnings 3)))
 552     (let* ((found (dolist (warning *undefined-warnings* nil)
 553                     (when (and (equal (undefined-warning-name warning) name)
 554                                (eq (undefined-warning-kind warning) kind))
 555                       (return warning))))
 556            (res (or found
 557                     (make-undefined-warning :name name :kind kind))))
 558       (unless found (push res *undefined-warnings*))
 559       (when (or (not *undefined-warning-limit*)
 560                 (< (undefined-warning-count res) *undefined-warning-limit*))
 561         (push (find-error-context (list name))
 562               (undefined-warning-warnings res)))
 563       (incf (undefined-warning-count res))))
 564   (values))