src/code/show.lisp

   1 ;;;; some stuff for displaying information for debugging/experimenting
   2 ;;;; with the system, mostly conditionalized with #!+SB-SHOW
   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!INT")
  14 \f
  15 ;;;; various SB-SHOW-dependent forms
  16 ;;;;
  17 ;;;; In general, macros named /FOO
  18 ;;;;   * are for debugging/tracing
  19 ;;;;   * expand into nothing unless :SB-SHOW is in the target
  20 ;;;;     features list
  21 ;;;; Often, they also do nothing at runtime if */SHOW* is NIL, but
  22 ;;;; this is not always true for some very-low-level ones.
  23 ;;;;
  24 ;;;; (I follow the "/FOO for debugging/tracing expressions" naming
  25 ;;;; rule and several other naming conventions in all my Lisp
  26 ;;;; programming when possible, and then set Emacs to display comments
  27 ;;;; in one shade of blue, tracing expressions in another shade of
  28 ;;;; blue, and declarations and assertions in a yellowish shade, so
  29 ;;;; that it's easy to separate them from the "real code" which
  30 ;;;; actually does the work of the program. -- WHN 2001-05-07)
  31
  32 ;;; Set this to NIL to suppress output from /SHOW-related forms.
  33 #!+sb-show (defvar */show* t)
  34
  35 (defun cannot-/show (string)
  36   (declare (type simple-string string))
  37   #+sb-xc-host (error "can't /SHOW: ~A" string)
  38   ;; We end up in this situation when we execute /SHOW too early in
  39   ;; cold init. That happens to me often enough that it's really
  40   ;; annoying for it to cause a hard failure -- which at that point is
  41   ;; hard to recover from -- instead of just diagnostic output.
  42   ;;
  43   ;; FIXME: The following is what we'd like to have. However,
  44   ;; including it as is causes compilation of make-host-2 to fail,
  45   ;; with "caught WARNING: defining setf macro for AREF when (SETF
  46   ;; AREF) was previously treated as a function" during compilation of
  47   ;; defsetfs.lisp
  48   ;;
  49   ;; #-sb-xc-host (sb!sys:%primitive print
  50   ;;                              (concatenate 'simple-string "/can't /SHOW:" string))
  51   ;;
  52   ;; because the CONCATENATE is transformed to an expression involving
  53   ;; (SETF AREF). Not declaring the argument as a SIMPLE-STRING (or
  54   ;; otherwise inhibiting the transform; e.g. with (SAFETY 3)) would
  55   ;; help, but full calls to CONCATENATE don't work this early in
  56   ;; cold-init, because they now need the full assistance of the type
  57   ;; system. So (KLUDGE):
  58   #-sb-xc-host (sb!sys:%primitive print "/can't /SHOW:")
  59   #-sb-xc-host (sb!sys:%primitive print string)
  60   (values))
  61
  62 ;;; Should /SHOW output be suppressed at this point?
  63 ;;;
  64 ;;; Note that despite the connoting-no-side-effects-pure-predicate
  65 ;;; name, we emit some error output if we're called at a point where
  66 ;;; /SHOW is inherently invalid.
  67 #!+sb-show
  68 (defun suppress-/show-p ()
  69   (cond (;; protection against /SHOW too early in cold init for
  70          ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously
  71          ;; we need *TRACE-OUTPUT* bound.
  72          (not (boundp '*trace-output*))
  73          (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)")
  74          t)
  75         (;; protection against /SHOW too early in cold init for
  76          ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso
  77          ;; display of name mnemonicity, *READTABLE* is used by the
  78          ;; printer to decide which case convention to use when
  79          ;; writing symbols, so we need it bound.
  80          (not (boundp '*readtable*))
  81          (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)")
  82          t)
  83         (;; more protection against /SHOW too early in cold init, part III
  84          (not (boundp '*/show*))
  85          (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)")
  86          t)
  87         (;; ordinary, healthy reason to suppress /SHOW, no error
  88          ;; output needed
  89          (not */show*)
  90          t)
  91         (t
  92          ;; Let the /SHOW go on.
  93          nil)))
  94
  95 ;;; shorthand for a common idiom in output statements used in
  96 ;;; debugging: (/SHOW "Case 2:" X Y) becomes a pretty-printed version
  97 ;;; of (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y), conditional on */SHOW*.
  98 (defmacro /show (&rest xlist)
  99   #!-sb-show (declare (ignore xlist))
 100   #!+sb-show
 101   (flet (;; Is X something we want to just show literally by itself?
 102          ;; (instead of showing it as NAME=VALUE)
 103          (literal-p (x) (or (stringp x) (numberp x))))
 104     ;; We build a FORMAT statement out of what we find in XLIST.
 105     (let ((format-stream (make-string-output-stream)) ; string arg to FORMAT
 106           (format-reverse-rest)  ; reversed &REST argument to FORMAT
 107           (first-p t))            ; first pass through loop?
 108       (write-string "~&~<~;/" format-stream)
 109       (dolist (x xlist)
 110         (if first-p
 111             (setq first-p nil)
 112             (write-string #+ansi-cl " ~_"
 113                           #-ansi-cl " " ; for CLISP (CLTL1-ish)
 114                           format-stream))
 115         (if (literal-p x)
 116             (princ x format-stream)
 117             (progn (let ((*print-pretty* nil))
 118                      (format format-stream "~S=~~S" x))
 119                    (push x format-reverse-rest))))
 120       (write-string "~;~:>~%" format-stream)
 121       (let ((format-string (get-output-stream-string format-stream))
 122             (format-rest (reverse format-reverse-rest)))
 123         `(locally
 124            (declare (optimize (speed 1) (space 2) (safety 3)))
 125            (unless (suppress-/show-p)
 126              (format *trace-output*
 127                      ,format-string
 128                      #+ansi-cl (list ,@format-rest)
 129                      #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish)
 130            (values))))))
 131
 132 ;;; a disabled-at-compile-time /SHOW, implemented as a macro instead
 133 ;;; of a function so that leaving occasionally-useful /SHOWs in place
 134 ;;; but disabled incurs no run-time overhead and works even when the
 135 ;;; arguments can't be evaluated (e.g. because they're only meaningful
 136 ;;; in a debugging version of the system, or just due to bit rot..)
 137 (defmacro /noshow (&rest rest)
 138   (declare (ignore rest)))
 139
 140 ;;; like /SHOW, except displaying values in hexadecimal
 141 (defmacro /xhow (&rest rest)
 142   `(let ((*print-base* 16))
 143      (/show ,@rest)))
 144 (defmacro /noxhow (&rest rest)
 145   (declare (ignore rest)))
 146
 147 ;;; a trivial version of /SHOW which only prints a constant string,
 148 ;;; implemented at a sufficiently low level that it can be used early
 149 ;;; in cold init
 150 ;;;
 151 ;;; Unlike the other /SHOW-related functions, this one doesn't test
 152 ;;; */SHOW* at runtime, because messing with special variables early
 153 ;;; in cold load is too much trouble to be worth it.
 154 (defmacro /show0 (&rest string-designators)
 155   ;; We can't use inline MAPCAR here because, at least in 0.6.11.x,
 156   ;; this code gets compiled before DO-ANONYMOUS is defined.
 157   (declare (notinline mapcar))
 158   (let ((s (apply #'concatenate
 159                   'simple-string
 160                   (mapcar #'string string-designators))))
 161     (declare (ignorable s)) ; (for when #!-SB-SHOW)
 162     #+sb-xc-host `(/show ,s)
 163     #-sb-xc-host `(progn
 164                     #!+sb-show
 165                     (sb!sys:%primitive print
 166                                        ,(concatenate 'simple-string "/" s)))))
 167 (defmacro /noshow0 (&rest rest)
 168   (declare (ignore rest)))
 169
 170 ;;; low-level display of a string, works even early in cold init
 171 (defmacro /primitive-print (thing)
 172   (declare (ignorable thing)) ; (for when #!-SB-SHOW)
 173   #!+sb-show
 174   (progn
 175     #+sb-xc-host `(/show "(/primitive-print)" ,thing)
 176     #-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing))))
 177
 178 ;;; low-level display of a system word, works even early in cold init
 179 (defmacro /hexstr (thing)
 180   (declare (ignorable thing)) ; (for when #!-SB-SHOW)
 181   #!+sb-show
 182   (progn
 183     #+sb-xc-host `(/show "(/hexstr)" ,thing)
 184     #-sb-xc-host `(sb!sys:%primitive print (hexstr ,thing))))
 185
 186 (defmacro /nohexstr (thing)
 187   (declare (ignore thing)))
 188 \f
 189 (/show0 "done with show.lisp")