97ec653f903dcd16160d5c10c52b46ed2c18c639
[sbcl.git] / 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 def-source-context (name lambda-list &body body)
101   #!+sb-doc
102   "DEF-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 (def-source-context defstruct (name-or-options &rest slots)
113   (declare (ignore slots))
114   `(defstruct ,(if (consp name-or-options)
115                    (car name-or-options)
116                    name-or-options)))
117
118 (def-source-context function (thing)
119   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
120       `(lambda ,(second thing))
121       `(function ,thing)))
122
123 ;;; Return the first two elements of FORM if FORM is a list. Take the
124 ;;; CAR of the second form if appropriate.
125 (defun source-form-context (form)
126   (cond ((atom form) nil)
127         ((>= (length form) 2)
128          (funcall (gethash (first form) *source-context-methods*
129                            #'(lambda (x)
130                                (declare (ignore x))
131                                (list (first form) (second form))))
132                   (rest form)))
133         (t
134          form)))
135
136 ;;; Given a source path, return the original source form and a
137 ;;; description of the interesting aspects of the context in which it
138 ;;; appeared. The context is a list of lists, one sublist per context
139 ;;; form. The sublist is a list of some of the initial subforms of the
140 ;;; context form.
141 ;;;
142 ;;; For now, we use the first two subforms of each interesting form. A
143 ;;; form is interesting if the first element is a symbol beginning
144 ;;; with "DEF" and it is not the source form. If there is no
145 ;;; DEF-mumble, then we use the outermost containing form. If the
146 ;;; second subform is a list, then in some cases we return the CAR of
147 ;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
148 ;;; options, etc.)
149 (defun find-original-source (path)
150   (declare (list path))
151   (let* ((rpath (reverse (source-path-original-source path)))
152          (tlf (first rpath))
153          (root (find-source-root tlf *source-info*)))
154     (collect ((context))
155       (let ((form root)
156             (current (rest rpath)))
157         (loop
158           (when (atom form)
159             (aver (null current))
160             (return))
161           (let ((head (first form)))
162             (when (symbolp head)
163               (let ((name (symbol-name head)))
164                 (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
165                   (context (source-form-context form))))))
166           (when (null current) (return))
167           (setq form (nth (pop current) form)))
168         
169         (cond ((context)
170                (values form (context)))
171               ((and path root)
172                (let ((c (source-form-context root)))
173                  (values form (if c (list c) nil))))
174               (t
175                (values '(unable to locate source)
176                        '((some strange place)))))))))
177
178 ;;; Convert a source form to a string, suitably formatted for use in
179 ;;; compiler warnings.
180 (defun stringify-form (form &optional (pretty t))
181   (let ((*print-level* *compiler-error-print-level*)
182         (*print-length* *compiler-error-print-length*)
183         (*print-lines* *compiler-error-print-lines*)
184         (*print-pretty* pretty))
185     (if pretty
186         (format nil "~<~@;  ~S~:>" (list form))
187         (prin1-to-string form))))
188
189 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
190 ;;; error context, or NIL if we can't figure anything out. ARGS is a
191 ;;; list of things that are going to be printed out in the error
192 ;;; message, and can thus be blown off when they appear in the source
193 ;;; context.
194 (defun find-error-context (args)
195   (let ((context *compiler-error-context*))
196     (if (compiler-error-context-p context)
197         context
198         (let ((path (or (and (boundp '*current-path*) *current-path*)
199                         (if context
200                             (node-source-path context)
201                             nil))))
202           (when (and *source-info* path)
203             (multiple-value-bind (form src-context) (find-original-source path)
204               (collect ((full nil cons)
205                         (short nil cons))
206                 (let ((forms (source-path-forms path))
207                       (n 0))
208                   (dolist (src (if (member (first forms) args)
209                                    (rest forms)
210                                    forms))
211                     (if (>= n *enclosing-source-cutoff*)
212                         (short (stringify-form (if (consp src)
213                                                    (car src)
214                                                    src)
215                                                nil))
216                         (full (stringify-form src)))
217                     (incf n)))
218
219                 (let* ((tlf (source-path-tlf-number path))
220                        (file-info (source-info-file-info *source-info*)))
221                   (make-compiler-error-context
222                    :enclosing-source (short)
223                    :source (full)
224                    :original-source (stringify-form form)
225                    :context src-context
226                    :file-name (file-info-name file-info)
227                    :file-position
228                    (multiple-value-bind (ignore pos)
229                        (find-source-root tlf *source-info*)
230                      (declare (ignore ignore))
231                      pos)
232                    :original-source-path
233                    (source-path-original-source path))))))))))
234 \f
235 ;;;; printing error messages
236
237 ;;; We save the context information that we printed out most recently
238 ;;; so that we don't print it out redundantly.
239
240 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
241 (defvar *last-error-context* nil)
242 (declaim (type (or compiler-error-context null) *last-error-context*))
243
244 ;;; The format string and args for the last error we printed.
245 (defvar *last-format-string* nil)
246 (defvar *last-format-args* nil)
247 (declaim (type (or string null) *last-format-string*))
248 (declaim (type list *last-format-args*))
249
250 ;;; The number of times that the last error message has been emitted,
251 ;;; so that we can compress duplicate error messages.
252 (defvar *last-message-count* 0)
253 (declaim (type index *last-message-count*))
254
255 ;;; If the last message was given more than once, then print out an
256 ;;; indication of how many times it was repeated. We reset the message
257 ;;; count when we are done.
258 (defun note-message-repeats (&optional (terpri t))
259   (cond ((= *last-message-count* 1)
260          (when terpri (terpri *error-output*)))
261         ((> *last-message-count* 1)
262           (format *error-output* "~&; [Last message occurs ~D times.]~2%"
263                  *last-message-count*)))
264   (setq *last-message-count* 0))
265
266 ;;; Print out the message, with appropriate context if we can find it.
267 ;;; If the context is different from the context of the last message
268 ;;; we printed, then we print the context. If the original source is
269 ;;; different from the source we are working on, then we print the
270 ;;; current source in addition to the original source.
271 ;;;
272 ;;; We suppress printing of messages identical to the previous, but
273 ;;; record the number of times that the message is repeated.
274 (defun print-compiler-message (format-string format-args)
275
276   (declare (type simple-string format-string))
277   (declare (type list format-args))
278   
279   (let ((stream *error-output*)
280         (context (find-error-context format-args)))
281     (cond
282      (context
283       (let ((file (compiler-error-context-file-name context))
284             (in (compiler-error-context-context context))
285             (form (compiler-error-context-original-source context))
286             (enclosing (compiler-error-context-enclosing-source context))
287             (source (compiler-error-context-source context))
288             (last *last-error-context*))
289
290         (unless (and last
291                      (equal file (compiler-error-context-file-name last)))
292           (when (pathnamep file)
293             (note-message-repeats)
294             (setq last nil)
295             (format stream "~2&; file: ~A~%" (namestring file))))
296
297         (unless (and last
298                      (equal in (compiler-error-context-context last)))
299           (note-message-repeats)
300           (setq last nil)
301           (format stream "~&")
302           (pprint-logical-block (stream nil :per-line-prefix "; ")
303             (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
304           (format stream "~%"))
305
306
307         (unless (and last
308                      (string= form
309                               (compiler-error-context-original-source last)))
310           (note-message-repeats)
311           (setq last nil)
312           (format stream "~&")
313           (pprint-logical-block (stream nil :per-line-prefix "; ")
314             (format stream "  ~A" form))
315           (format stream "~&"))
316
317         (unless (and last
318                      (equal enclosing
319                             (compiler-error-context-enclosing-source last)))
320           (when enclosing
321             (note-message-repeats)
322             (setq last nil)
323             (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
324
325         (unless (and last
326                      (equal source (compiler-error-context-source last)))
327           (setq *last-format-string* nil)
328           (when source
329             (note-message-repeats)
330             (dolist (src source)
331               (format stream "~&")
332               (write-string "; ==>" stream)
333               (format stream "~&")
334               (pprint-logical-block (stream nil :per-line-prefix "; ")
335                 (write-string src stream)))))))
336      (t
337        (format stream "~&")
338       (note-message-repeats)
339       (setq *last-format-string* nil)
340        (format stream "~&")))
341
342     (setq *last-error-context* context)
343
344     (unless (and (equal format-string *last-format-string*)
345                  (tree-equal format-args *last-format-args*))
346       (note-message-repeats nil)
347       (setq *last-format-string* format-string)
348       (setq *last-format-args* format-args)
349       (let ((*print-level*  *compiler-error-print-level*)
350             (*print-length* *compiler-error-print-length*)
351             (*print-lines*  *compiler-error-print-lines*))
352         (format stream "~&")
353         (pprint-logical-block (stream nil :per-line-prefix "; ")
354           (format stream "~&~?" format-string format-args))
355         (format stream "~&"))))
356
357   (incf *last-message-count*)
358   (values))
359
360 (defun print-compiler-condition (condition)
361   (declare (type condition condition))
362   (let (;; These different classes of conditions have different
363         ;; effects on the return codes of COMPILE-FILE, so it's nice
364         ;; for users to be able to pick them out by lexical search
365         ;; through the output.
366         (what (etypecase condition
367                 (style-warning 'style-warning)
368                 (warning 'warning)
369                 (error 'error))))
370     (multiple-value-bind (format-string format-args)
371         (if (typep condition 'simple-condition)
372             (values (simple-condition-format-control condition)
373                     (simple-condition-format-arguments condition))
374             (values "~A"
375                     (list (with-output-to-string (s)
376                             (princ condition s)))))
377       (print-compiler-message (format nil
378                                       "caught ~S:~%  ~A"
379                                       what
380                                       format-string)
381                               format-args)))
382   (values))
383
384 ;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
385 ;;; condition-signalling functions, but it just writes some output
386 ;;; instead of signalling. (In CMU CL, it did signal a condition, but
387 ;;; this didn't seem to work all that well; it was weird to have
388 ;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
389 ;;; that the compiler couldn't figure out how to compile something as
390 ;;; efficiently as it liked.)
391 (defun compiler-note (format-string &rest format-args)
392   (unless (if *compiler-error-context*
393               (policy *compiler-error-context* (= inhibit-warnings 3))
394               (policy *lexenv* (= inhibit-warnings 3)))
395     (incf *compiler-note-count*)
396     (print-compiler-message (format nil "note: ~A" format-string)
397                             format-args))
398   (values))
399
400 ;;; Issue a note when we might or might not be in the compiler.
401 (defun maybe-compiler-note (&rest rest)
402   (if (boundp '*lexenv*) ; if we're in the compiler
403       (apply #'compiler-note rest)
404       (let ((stream *error-output*))
405         (pprint-logical-block (stream nil :per-line-prefix ";")
406           
407           (format stream " note: ~3I~_")
408           (pprint-logical-block (stream nil)
409             (apply #'format stream rest)))
410         (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
411
412 ;;; The politically correct way to print out progress messages and
413 ;;; such like. We clear the current error context so that we know that
414 ;;; it needs to be reprinted, and we also Force-Output so that the
415 ;;; message gets seen right away.
416 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
417 (defun compiler-mumble (format-string &rest format-args)
418   (note-message-repeats)
419   (setq *last-error-context* nil)
420   (apply #'format *error-output* format-string format-args)
421   (force-output *error-output*)
422   (values))
423
424 ;;; Return a string that somehow names the code in COMPONENT. We use
425 ;;; the source path for the bind node for an arbitrary entry point to
426 ;;; find the source context, then return that as a string.
427 (declaim (ftype (function (component) simple-string) find-component-name))
428 (defun find-component-name (component)
429   (let ((ep (first (block-succ (component-head component)))))
430     (aver ep) ; else no entry points??
431     (multiple-value-bind (form context)
432         (find-original-source
433          (node-source-path (continuation-next (block-start ep))))
434       (declare (ignore form))
435       (let ((*print-level* 2)
436             (*print-pretty* nil))
437         (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
438 \f
439 ;;;; condition system interface
440
441 ;;; Keep track of how many times each kind of condition happens.
442 (defvar *compiler-error-count*)
443 (defvar *compiler-warning-count*)
444 (defvar *compiler-style-warning-count*)
445 (defvar *compiler-note-count*)
446
447 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
448 ;;; should return WARNINGS-P or FAILURE-P.
449 (defvar *failure-p*)
450 (defvar *warnings-p*)
451
452 ;;; condition handlers established by the compiler. We re-signal the
453 ;;; condition, then if it isn't handled, we increment our warning
454 ;;; counter and print the error message.
455 (defun compiler-error-handler (condition)
456   (signal condition)
457   (incf *compiler-error-count*)
458   (setf *warnings-p* t
459         *failure-p* t)
460   (print-compiler-condition condition)
461   (continue condition))
462 (defun compiler-warning-handler (condition)
463   (signal condition)
464   (incf *compiler-warning-count*)
465   (setf *warnings-p* t
466         *failure-p* t)
467   (print-compiler-condition condition)
468   (muffle-warning condition))
469 (defun compiler-style-warning-handler (condition)
470   (signal condition)
471   (incf *compiler-style-warning-count*)
472   (setf *warnings-p* t)
473   (print-compiler-condition condition)
474   (muffle-warning condition))
475 \f
476 ;;;; undefined warnings
477
478 (defvar *undefined-warning-limit* 3
479   #!+sb-doc
480   "If non-null, then an upper limit on the number of unknown function or type
481   warnings that the compiler will print for any given name in a single
482   compilation. This prevents excessive amounts of output when the real
483   problem is a missing definition (as opposed to a typo in the use.)")
484
485 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
486 ;;; to NAME of the specified KIND. If we have exceeded the warning
487 ;;; limit, then just increment the count, otherwise note the current
488 ;;; error context.
489 ;;;
490 ;;; Undefined types are noted by a condition handler in
491 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
492 ;;; the compiler, hence the BOUNDP check.
493 (defun note-undefined-reference (name kind)
494   (unless (and
495            ;; Check for boundness so we don't blow up if we're called
496            ;; when IR1 conversion isn't going on.
497            (boundp '*lexenv*)
498            ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
499            ;; isn't a good idea; we should have INHIBIT-WARNINGS
500            ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
501            ;; sure what the BOUNDP '*LEXENV* test above is for; it's
502            ;; likely a good idea, but it probably deserves an
503            ;; explanatory comment.
504            (policy *lexenv* (= inhibit-warnings 3)))
505     (let* ((found (dolist (warning *undefined-warnings* nil)
506                     (when (and (equal (undefined-warning-name warning) name)
507                                (eq (undefined-warning-kind warning) kind))
508                       (return warning))))
509            (res (or found
510                     (make-undefined-warning :name name :kind kind))))
511       (unless found (push res *undefined-warnings*))
512       (when (or (not *undefined-warning-limit*)
513                 (< (undefined-warning-count res) *undefined-warning-limit*))
514         (push (find-error-context (list name))
515               (undefined-warning-warnings res)))
516       (incf (undefined-warning-count res))))
517   (values))