Skip to content
Snippets Groups Projects
debug.lisp 14.5 KiB
Newer Older
ram's avatar
ram committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441
;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Spice Lisp Debugger.
;;;
;;; Written by Steve Handerson
;;; Pages 6 through 9 rewritten by Bill Chiles.
;;;
;;; **********************************************************************
;;;
(in-package "DEBUG" :use '("LISP" "SYSTEM"))


(export '(internal-debug *flush-debug-errors* backtrace debug-function
	  show-all debug-return local show hide argument pc
	  function-name hide-defaults *debug-print-level*
	  *debug-print-length* *debug-hidden-functions*))



(in-package "LISP")
(export '(invoke-debugger *debugger-hook*))


(in-package "DEBUG")

;;;
;;; Used to communicate to debug-loop that we are at a step breakpoint.
;;;

(define-condition step-condition (simple-condition))
  "*Print-level* is bound to this value when debug prints a function call.")
;;;; Variables, parameters, and constants.

  "*Print-length* is bound to this value when debug prints a function call.")
  null, use *PRINT-LEVEL*")
(defvar *inside-debugger-p* nil
  "This is T while evaluating expressions in the debugger.")


(defparameter *debug-print-length* 5
  "*PRINT-LENGTH* is bound to this value when debug prints a function call.  If
  null, use *PRINT-LENGTH*.")

(defvar *in-the-debugger* nil
  "When true, the LIST-LOCATIONS command only displays block start locations.
  "The default contents of *debug-prompt*."
   Otherwise, all locations are displayed.")

  "If true, list the code location type in the LIST-LOCATIONS command.")
    (princ " ")))
;;; should not be listed when listing breakpoints.
;;;
  "A lambda of no args that prints the debugger prompt on *debug-io*.")

;;; Code locations of the possible breakpoints
;;;
Prompt is <stack-level>':'<frame-number>(<command-level>*']').
Frames look like calls, C signifying a catch frame.
Expressions get evaluated in the frame's lexical environment,
  setting * and friends like the top level read-eval-print loop.
Debug commands do not affect * and friends.
;;;
(defvar *breakpoints* nil)
(declaim (type list *breakpoints*))

;;; A list of breakpoint-info structures of the made and active step
;;; breakpoints.
  PUSH     rebinds things in another command level.  Good for hide/show.
  ABORT    returns to the previous abort restart case.
;;;
(defvar *step-breakpoints* nil)  
;;;
(defvar *number-of-steps* 1)
  F  go to numbered frame (prompts if not given).
  S  search for a specified function (prompts), 
     an optional number of times (does not prompt).
  R  searches up the stack, optional times.
(declaim (type integer *number-of-steps*))
;;;
(defvar *default-breakpoint-debug-function* nil)
  ?              prints all kinds of groovy things.
  L              lists locals in current function.
  P, PP          displays current function call.  

Functions/macros for your enjoyment:
 (DEBUG:DEBUG-RETURN expression [frame])  returns with values from an active frame.
 (DEBUG:ARGUMENT n [frame])              shows the nth  supplied argument.
 (DEBUG:PC [frame])                 shows the next pc to be executed.
;;; Returns a list of the next code-locations following the one passed.  One of
;;; the *bad-code-location-types* will not be returned.
;;;
(defun next-code-locations (code-location)
    (di:do-debug-block-locations (block-code-location debug-block)
    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
    (format t "Cannot step, in elsewhere code~%"))
   (t
(proclaim '(inline pointer+ stack-ref valid-env-p cstack-pointer-valid-p))
	  (di:activate-breakpoint bp)
(defun pointer+ (x y)
  (%primitive sap+ x (ash y 2)))
	     (t ,other)))))
(defun stack-ref (s n)
  (%primitive read-control-stack (pointer+ s n)))

(defun escape-reg (f n)
  (stack-ref f (+ n %escape-frame-general-register-start-slot)))

(defun valid-env-p (env)
  (and (functionp env)
       (eql (%primitive get-vector-subtype env)
	    %function-constants-subtype)))

(defun cstack-pointer-valid-p (x)
  (and (%primitive pointer< x (%primitive current-sp))
       (not (%primitive pointer< x
			(%primitive make-immediate-type 0
				    %control-stack-type)))))

(defun check-valid (x)
  (unless (cstack-pointer-valid-p x)
    (error "Invalid control stack pointer."))
  x)

(defun print-code-and-stuff (env pc)
  (let* ((code (%primitive header-ref env %function-code-slot))
	 (code-int (%primitive make-fixnum code)))
    (format t "~A, Code = #x~X, PC = ~D"
	    (%primitive header-ref env %function-name-slot)
	    (logior code-int (ash %code-type 27))
	    (- (%primitive make-fixnum pc) code-int))))

;;; Backtrace prints a history of calls on the stack.

(defun backtrace (&optional (frames most-positive-fixnum)
			    (*standard-output* *debug-io*))
  "Show a listing of the call stack going down from the current frame.  Frames
  is how many frames to show."
  (do ((callee (%primitive current-cont)
	       (stack-ref callee c::old-cont-save-offset))
       (n 0 (1+ n)))
      ((or (not (cstack-pointer-valid-p callee))
	   (>= n frames))
       (values))
    (let* ((caller (stack-ref callee c::old-cont-save-offset))
	   (pc (stack-ref callee c::return-pc-save-offset)))
      (unless (cstack-pointer-valid-p caller)
	(return (values)))
      (let ((env (stack-ref caller c::env-save-offset)))
	(cond 
	 ((eql env 0)
	  (let ((env (escape-reg caller c::env-offset)))
	    (cond ((eql (%primitive get-type env) %trap-type)
		   (format t "~%<undefined> ~S"
			   (escape-reg caller c::call-name-offset))
		   (setq callee
			 (check-valid
			  (escape-reg caller c::old-cont-offset))))
		  ((valid-env-p env)
		   (format t "~%<escape frame> ")
		   (print-code-and-stuff
		    env
		    (escape-reg caller c::return-pc-offset))
		   (setq callee
			 (check-valid
			  (stack-ref callee c::old-cont-save-offset))))
		  (t
		   (error "Escaping frame ENV invalid?")))))
	 ((valid-env-p env)
	  (terpri)
	  (print-code-and-stuff env pc))
	 (t
	  (format t "~%<invalid frame>")))))))

    (make-unprintable-object "unavailable-arg")))
;;;; DEBUG
;;; PRINT-FRAME-CALL -- Interface
;;;
;;; This prints a representation of the function call causing frame to exist.
;;; Verbosity indicates the level of information to output; zero indicates just
   which causes the standard debugger to execute.")
(defun print-frame-call (frame &key (print-length *print-length*)
			       (number nil))
  (let ((*print-length* (or *debug-print-length* print-length))
(defvar *debug-abort*)
	(*print-level* (or *debug-print-level* print-level)))
      (when number
	(format t "~&~S: " (di:frame-number frame)))
      (format t "~S" frame))
     (t
      (when number
	(format t "~&~S: " (di:frame-number frame)))
    (when (>= verbosity 2)
      (let ((loc (di:frame-code-location frame)))
	 (*debug-abort* (find-restart 'abort))
	(handler-case
	    (progn
	 (*error-output* *debug-io*))

;;;; Invoke-debugger.

(defvar *debugger-hook* nil
   which causes the standard debugger to execute.  The system passes the value
   of this variable to the function because it binds *debugger-hook* to nil
   around the invocation.")
    (do ((p restarts (cdr p))
	 (i 0 (1+ i)))
	((endp p))
      (format s "~&  ~D: ~A~%" i (car p)))))
	 ;; Rebind some printer control variables.
;;; INTERNAL-DEBUG calls the debug loop.  This is used in DEBUG and
;;; CONDITIONS::ERROR-ERROR.
	 (*print-readably* nil)
;;; SHOW-RESTARTS -- Internal.
  (let ((*in-the-debugger* T)
	(*read-suppress* NIL))
  (when restarts
    (format s "~&Restarts:~%")
    (let ((count 0)
	  (names-used '(nil))
	  (max-name-len 0))
      (dolist (restart restarts)

;;; NTH-ARG -- Internal.
;;;
;;; This returns the n'th arg as the user sees it from args, the result of
;;; Interface to *debug-commands*.
;;; 
(defmacro def-debug-command (name &rest body)
    (dolist (ele args (error "Argument specification out of range -- ~S." n))
      (lambda-list-element-dispatch ele
      (defun ,fun-name () ,@body)
      (push (cons ,name #',fun-name) *debug-commands*)
				      (di:frame-code-location *current-frame*)
		   (error "Unused rest-arg before n'th argument.")
(defun debug-command-p (form)
  (if (symbolp form)
      (cdr (assoc (symbol-name form) *debug-commands* :test #'string=))))
(defun debug-command-p (form &optional other-commands)
	;; Return the right value.
(defun make-restart-commands (&optional (restarts *debug-restarts*))
(def-debug-command "FRAME" (&optional
;;; 
(def-debug-command "Q"
	   (princ "You are here."))
	  ((> n current)
(def-debug-command "GO"
	    (setf *current-frame*
		  (do ((prev *current-frame* lead)

(def-debug-command "PUSH"
  (invoke-debugger *debug-condition*))

(def-debug-command "ABORT"
  (invoke-restart *debug-abort*))
		       (lead (di:frame-down *current-frame*)
(def-debug-command "RESTART"
		      ((null lead)
		       (princ "Bottom of stack encountered.")
		       prev)
      (write-string "Restart number: ")
	  (t
    (invoke-restart-interactively (nth num *debug-restarts*))))
;;;

;;;
;;; 
(def-debug-command "H"
  (princ debug-help-string))
	  (princ "No such restart.")))))
(def-debug-command "ERROR"
;;; Information commands.
;;;
 
;;; BACKTRACE-DEBUG-COMMAND binds *inside-debugger-p*, so BACKTRACE will
;;; not reparse the stack.  *inside-debugger-p* is only bound to non-nil
;;; when doing evaluations in the debug loop.
;;; 
(def-debug-command "BACKTRACE"
  (let ((*inside-debugger-p* t))
    (backtrace (read-if-available most-positive-fixnum))))
   printing a prompting line to continue with output.")
  (let* ((end -1)
(defvar *flush-debug-errors* t
  "Don't recursively call DEBUG on errors while within the debugger if non-nil.")
	     (let ((code-loc (di:debug-function-start-location place)))
(def-debug-command "FLUSH"
  (setf *flush-debug-errors* (not *flush-debug-errors*)))

	(when old-bp-info
	  (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
	  (setf *breakpoints* (remove old-bp-info *breakpoints*))
	  (format t "Note: previous breakpoint removed.~%"))
	(push new-bp-info *breakpoints*))
      (print-breakpoint-info (first *breakpoints*))
  (if (not (listen-skip-whitespace in))
      (princ prompt out))

;;; list all breakpoints set
(def-debug-command "LIST-BREAKPOINTS" ()
  (if (listen-skip-whitespace stream)
	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
  (dolist (info *breakpoints*)



;;;; Debug-Loop.

(defun debug-loop ()
  (let ((*debug-command-level* (1+ *debug-command-level*)))
    (loop
     (catch 'debug-loop-catcher
       (handler-bind ((error #'(lambda (condition)
				 (when *flush-debug-errors*
				   (clear-input *debug-io*)
				   (princ condition)
				   (format t "~&Error flushed ...")
				   (throw 'debug-loop-catcher nil))
				 (invoke-debugger condition))))
	 (funcall *debug-prompt*)
	 (let* ((exp (read))
		(cmd-fun (debug-command-p exp))
		;; Must bind level for restart function created for this abort.
		(level *debug-command-level*))
	   (with-simple-restart (abort "Return to debug level ~D." level)
	     (if cmd-fun
		 (funcall cmd-fun)
		 (debug-eval-print exp)))))))))

(defun debug-eval-print (exp)
  (setq +++ ++ ++ + + - - exp)
  (let* ((values (multiple-value-list (eval -)))
	 (*standard-output* *debug-io*))
    (fresh-line)
    (if values (prin1 (car values)))
    (dolist (x (cdr values))
      (fresh-line)
      (prin1 x))
    (setq /// // // / / values)
    (setq *** ** ** * * (car values))
    ;; Make sure nobody passes back an unbound marker.
    (unless (boundp '*)
      (setq * nil)
      (fresh-line)
      (princ "Setting * to NIL -- was unbound marker."))))
    (print-breakpoint-info info)))

(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")

;;; remove breakpoint n or all if none given
(def-debug-command "DELETE-BREAKPOINT" ()
  (let* ((index (read-if-available nil))
	 (bp-info
	  (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
    (cond (bp-info
	   (di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
	   (setf *breakpoints* (remove bp-info *breakpoints*))
	   (format t "Breakpoint ~S removed.~%" index))
	  (index (format t "Breakpoint doesn't exist."))
	  (t
	   (dolist (ele *breakpoints*)
	     (di:delete-breakpoint (breakpoint-info-breakpoint ele)))
	   (setf *breakpoints* nil)
	   (format t "All breakpoints deleted.~%")))))

(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")


;;;
;;; Miscellaneous commands.
;;;

(def-debug-command "FLUSH-ERRORS" ()
  (if (setf *flush-debug-errors* (not *flush-debug-errors*))
      (write-line "Errors now flushed.")
      (write-line "Errors now create nested debug levels.")))


(def-debug-command "DESCRIBE" ()
  (let* ((curloc (di:frame-code-location *current-frame*))
	 (debug-fun (di:code-location-debug-function curloc))
	 (function (di:debug-function-function debug-fun)))
    (if function
	(describe function)
	(format t "Can't figure out the function for this frame."))))


;;;
;;; Editor commands.
;;;

(def-debug-command "EDIT-SOURCE" ()
  (unless (typep *terminal-io* 'ed::ts-stream)
    (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~
	    connected to a Hemlock editor."))
  (let* ((wire (ed::ts-stream-wire *terminal-io*))
	 (location (maybe-block-start-location
		    (di:frame-code-location *current-frame*)))
	 (d-source (di:code-location-debug-source location))
	 (name (di:debug-source-name d-source)))
    (ecase (di:debug-source-from d-source)
      (:file
       (let* ((tlf-offset (di:code-location-top-level-form-offset location))
	      (local-tlf-offset (- tlf-offset
				   (di:debug-source-root-number d-source)))
	      (char-offset (aref (or (di:debug-source-start-positions d-source)
				     (error "No start positions map."))
				 local-tlf-offset)))
	 (wire:remote wire
	   (ed::edit-source-location (namestring name)
				     (di:debug-source-created d-source)
				     tlf-offset local-tlf-offset char-offset
				     (di:code-location-form-number location)))
	 (wire:wire-force-output wire)))
      ((:lisp :stream)
       (wire:remote wire
	 (ed::cannot-edit-source-location))
       (wire:wire-force-output wire)))))



;;;; Debug loop command utilities.

(defun read-prompting-maybe (prompt &optional (in *standard-input*)
				    (out *standard-output*))
  (unless (ext:listen-skip-whitespace in)
    (princ prompt out)
    (force-output out))
  (read in))

(defun read-if-available (default &optional (stream *standard-input*))
  (if (ext:listen-skip-whitespace stream)
      (read stream)
      default))