Skip to content
Snippets Groups Projects
debug.lisp 14.6 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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.")

;;; A list of the types of code-locations that should not be stepped to and
ram's avatar
ram committed
;;; 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."
ram's avatar
ram committed
  (do ((callee (%primitive current-fp)
	       (stack-ref callee c::old-fp-save-offset))
ram's avatar
ram committed
       (n 0 (1+ n)))
      ((or (not (cstack-pointer-valid-p callee))
	   (>= n frames))
       (values))
ram's avatar
ram committed
    (let* ((caller (stack-ref callee c::old-fp-save-offset))
ram's avatar
ram committed
	   (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
ram's avatar
ram committed
			  (escape-reg caller c::old-fp-offset))))
ram's avatar
ram committed
		  ((valid-env-p env)
		   (format t "~%<escape frame> ")
		   (print-code-and-stuff
		    env
		    (escape-reg caller c::return-pc-offset))
		   (setq callee
			 (check-valid
ram's avatar
ram committed
			  (stack-ref callee c::old-fp-save-offset))))
ram's avatar
ram committed
		  (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))