Skip to content
Snippets Groups Projects
debug.lisp 56.8 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.53 2001/07/12 20:10:52 pw Exp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
chiles's avatar
 
chiles committed
;;; CMU Common Lisp Debugger.  This includes a basic command-line oriented
;;; debugger interface as well as support for Hemlock to deliver debugger
;;; commands to a slave Lisp.
ram's avatar
ram committed
;;;
;;; Written by Bill Chiles.
ram's avatar
ram committed
;;;

ram's avatar
ram committed

(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
ram's avatar
ram committed
	  *debug-print-level* *debug-print-length* *debug-prompt*
	  *debug-readtable* *help-line-scroll-count* *stack-top-hint*
chiles's avatar
 
chiles committed

	  *auto-eval-in-frame* var arg
	  *only-block-start-locations* *print-location-kind*
ram's avatar
ram committed

chiles's avatar
 
chiles committed
	  do-debug-command))
ram's avatar
ram committed

(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) ())
ram's avatar
ram committed
;;;; Variables, parameters, and constants.

(defparameter *debug-print-level* 3
  "*PRINT-LEVEL* is bound to this value when debug prints a function call.  If
ram's avatar
ram committed
  null, use *PRINT-LEVEL*")

(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
  "This is T while in the debugger.")

(defvar *debug-command-level* 0
  "Pushes and pops/exits inside the debugger change this.")

(defvar *stack-top-hint* nil
  "If this is bound before the debugger is invoked, it is used as the stack
(defvar *real-stack-top* nil)

(defvar *current-frame* nil)

;;; DEBUG-PROMPT -- Internal.
;;;
;;; This is the default for *debug-prompt*.
;;;
(defun debug-prompt ()
  (let ((*standard-output* *debug-io*))
    (terpri)
    (prin1 (di:frame-number *current-frame*))
    (dotimes (i *debug-command-level*) (princ "]"))
    (princ " ")
    (force-output)))

(defparameter *debug-prompt* #'debug-prompt
  "This is a function of no arguments that prints the debugger prompt
   on *debug-io*.")

(defconstant debug-help-string
"
The prompt is right square brackets, the number indicating how many
  recursive command loops you are in.
Debug commands do not affect * and friends, but evaluation in the debug loop
  do affect these variables.
Any command may be uniquely abbreviated.

Getting in and out of DEBUG:
  Q        throws to top level.
  GO       calls CONTINUE which tries to proceed with the restart 'continue.
  RESTART  invokes restart numbered as shown (prompt if not given).
  ERROR    prints the error condition and restart cases.
  FLUSH    toggles *flush-debug-errors*, which is initially t.
 
  The name of any restart, or its number, is a valid command, and is the same
    as using RESTART to invoke that restart.

Changing frames:
  U  up frame        D  down frame       T  top frame       B  bottom frame

  F n   goes to frame n.

Inspecting frames:
  BACKTRACE [n]  shows n frames going down the stack.
  L              lists locals in current function.
  P, PP          displays current function call.
  SOURCE [n]     displays frame's source form with n levels of enclosing forms.
  VSOURCE [n]    displays frame's source form without any ellipsis.

Breakpoints and steps:
  LIST-LOCATIONS [{function | :c}]  list the locations for breakpoints.
    Specify :c for the current frame.  Abbreviation: LL
  LIST-BREAKPOINTS                  list the active breakpoints.
    Abbreviations: LB, LBP
  DELETE-BREAKPOINT [n]             remove breakpoint n or all breakpoints.
    Abbreviations: DEL, DBP    
  BREAKPOINT {n | :end | :start} [:break form] [:function function]
    [{:print form}*] [:condition form]    set a breakpoint.
    Abbreviations: BR, BP
  STEP [n]                          step to the next location or step n times.

Function and macro commands:
 (DEBUG:DEBUG-RETURN expression)
    returns expression's values from the current frame, exiting the debugger.
 (DEBUG:ARG n)
    returns the n'th argument, remaining in the debugger.
 (DEBUG:VAR string-or-symbol [id])
    returns the specified variable's value, remaining in the debugger.

See the CMU Common Lisp User's Manual for more information.
")


;;;; Breakpoint state:

(defvar *only-block-start-locations* nil
ram's avatar
ram committed
  "When true, the LIST-LOCATIONS command only displays block start locations.
   Otherwise, all locations are displayed.")

(defvar *print-location-kind* nil
ram's avatar
ram committed
  "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.
;;;
(defvar *bad-code-location-types* '(:call-site :internal-error))
(declaim (type list *bad-code-location-types*))
ram's avatar
ram committed

;;; Code locations of the possible breakpoints
;;;
(defvar *possible-breakpoints*)
(declaim (type list *possible-breakpoints*))

;;; A list of the made and active breakpoints, each is a breakpoint-info
ram's avatar
ram committed
;;;
(defvar *breakpoints* nil)
(declaim (type list *breakpoints*))

;;; A list of breakpoint-info structures of the made and active step
;;; breakpoints.
;;;
(defvar *step-breakpoints* nil)  
(declaim (type list *step-breakpoints*))

;;; Number of times left to step.
ram's avatar
ram committed
;;;
(defvar *number-of-steps* 1)
(declaim (type integer *number-of-steps*))

;;; Used when listing and setting breakpoints.
ram's avatar
ram committed
;;;
(defvar *default-breakpoint-debug-function* nil)
(declaim (type (or list di:debug-function) *default-breakpoint-debug-function*))
ram's avatar
ram committed


;;;; Code location utilities:

;;; FIRST-CODE-LOCATION -- Internal.
;;;
;;; Returns the first code-location in the passed debug block
;;;
(defun first-code-location (debug-block)
  (let ((found nil)
	(first-code-location nil))
    (di:do-debug-block-locations (code-location debug-block)
      (unless found 
	(setf first-code-location code-location)
	(setf found t)))
    first-code-location))

;;; NEXT-CODE-LOCATIONS -- Internal.
;;;
ram's avatar
ram committed
;;; 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)
  (let ((debug-block (di:code-location-debug-block code-location))
	(block-code-locations nil))
ram's avatar
ram committed
    (di:do-debug-block-locations (block-code-location debug-block)
      (unless (member (di:code-location-kind block-code-location)
		      *bad-code-location-types*)
	(push block-code-location block-code-locations)))
    (setf block-code-locations (nreverse block-code-locations))
    (let* ((code-loc-list (rest (member code-location block-code-locations
					:test #'di:code-location=)))
	   (next-list (cond (code-loc-list
			     (list (first code-loc-list)))
			    ((map 'list #'first-code-location
				  (di:debug-block-successors debug-block)))
			    (t nil))))
      (when (and (= (length next-list) 1)
		 (di:code-location= (first next-list) code-location))
	(setf next-list (next-code-locations (first next-list))))
      next-list)))

;;; POSSIBLE-BREAKPOINTS -- Internal.
;;;  
;;; Returns a list of code-locations of the possible breakpoints of the 
;;; debug-function passed.
;;;
(defun possible-breakpoints (debug-function)
  (let ((possible-breakpoints nil))
    (di:do-debug-function-blocks (debug-block debug-function)
      (unless (di:debug-block-elsewhere-p debug-block)
	(if *only-block-start-locations*
	    (push (first-code-location debug-block) possible-breakpoints)
	    (di:do-debug-block-locations (code-location debug-block)
	      (when (not (member (di:code-location-kind code-location)
				 *bad-code-location-types*))
		(push code-location possible-breakpoints))))))
    (nreverse possible-breakpoints)))

;;; LOCATION-IN-LIST -- Internal.
;;;
;;; Searches the info-list for the item passed (code-location, debug-function,
;;; or breakpoint-info).  If the item passed is a debug function then kind will
;;; be compared if it was specified.  The kind if also compared if a
;;; breakpoint-info is passed since it's in the breakpoint.  The info structure
;;; is returned if found.
;;;
(defun location-in-list (place info-list &optional (kind nil)) 
  (when (breakpoint-info-p place)
ram's avatar
ram committed
    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
    (setf place (breakpoint-info-place place)))
  (cond ((di:code-location-p place)
	 (find place info-list
	       :key #'breakpoint-info-place
	       :test #'(lambda (x y) (and (di:code-location-p y)
					  (di:code-location= x y)))))
	(t
	 (find place info-list
	       :test #'(lambda (x-debug-function y-info)
			 (let ((y-place (breakpoint-info-place y-info))
			       (y-breakpoint (breakpoint-info-breakpoint
					      y-info)))
			   (and (di:debug-function-p y-place)
				(eq x-debug-function y-place)
				(or (not kind)
				    (eq kind (di:breakpoint-kind
					      y-breakpoint))))))))))


;;; MAYBE-BLOCK-START-LOCATION  --  Internal.
;;;
;;; If Loc is an unknown location, then try to find the block start location.
;;; Used by source printing to some information instead of none for the user.
;;;
(defun maybe-block-start-location (loc)
  (if (di:code-location-unknown-p loc)
      (let* ((block (di:code-location-debug-block loc))
	     (start (di:do-debug-block-locations (loc block)
		      (return loc))))
	(cond ((and (not (di:debug-block-elsewhere-p block))
		    start)
	       (format t "~%Unknown location: using block start.~%")
	       start)
	      (t
	       loc)))
      loc))


;;;; The BREAKPOINT-INFO structure:

;;; Hold info about made breakpoints
;;;
(defstruct breakpoint-info
  ;;
  ;; Where we are going to stop.
  (place (required-argument) :type (or di:code-location di:debug-function)) 
  ;;
  ;; The breakpoint returned by di:make-breakpoint.
  (breakpoint (required-argument) :type di:breakpoint)
  ;;
  ;; Function returned from di:preprocess-for-eval.  If result is non-nil,
  ;; drop into the debugger.
  (break #'identity :type function)
  ;; 
  ;; Function returned from di:preprocess-for-eval.  If result is non-nil,
  ;; eval (each) print and print results.
  (condition #'identity :type function)
  ;;
  ;; List of functions from di:preprocess-for-eval to evaluate, results are
  ;; conditionally printed.  Car of each element is the function, cdr is the
  ;; form it goes with.
  (print nil :type list)
  ;;
  ;; The number used when listing the possible breakpoints within a function.
  ;; Could also be a symbol such as start or end.
  (code-location-number (required-argument) :type (or symbol integer))
  ;;
  ;; The number used when listing the breakpoints active and to delete
  ;; breakpoints. 
  (breakpoint-number (required-argument) :type integer))


;;; CREATE-BREAKPOINT-INFO -- Internal.
;;;
;;; Returns a new breakpoint-info structure with the info passed.
;;;
(defun create-breakpoint-info (place breakpoint code-location-number
				     &key (break #'identity)
				     (condition #'identity) (print nil))
  (setf *breakpoints*
	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
  (let ((breakpoint-number
	 (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
	     ((or (> i (length *breakpoints*))
		  (not (= i (breakpoint-info-breakpoint-number
			     (first breakpoints)))))

	      i))))
    (make-breakpoint-info :place place :breakpoint breakpoint
			  :code-location-number code-location-number
			  :breakpoint-number breakpoint-number
			  :break break :condition condition :print print)))

;;; PRINT-BREAKPOINT-INFO -- Internal.
;;;
;;; Prints the breakpoint info for the breakpoint-info structure passed.
;;;
(defun print-breakpoint-info (breakpoint-info)
  (let ((place (breakpoint-info-place breakpoint-info))
	(bp-number (breakpoint-info-breakpoint-number breakpoint-info))
	(loc-number (breakpoint-info-code-location-number breakpoint-info)))
    (case (di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
      (:code-location 
       (print-code-location-source-form place 0)
       (format t "~&~S: ~S in ~S"
	       bp-number loc-number (di:debug-function-name
				      (di:code-location-debug-function place))))
      (:function-start
       (format t "~&~S: FUNCTION-START in ~S" bp-number
	       (di:debug-function-name place)))
      (:function-end
       (format t "~&~S: FUNCTION-END in ~S" bp-number
	       (di:debug-function-name place))))))



;;;; Main-hook-function for steps and breakpoints

;;; MAIN-HOOK-FUNCTION -- Internal.
;;;
;;; Must be passed as the hook function.  Keeps track of where step 
;;; breakpoints are.
;;;
(defun main-hook-function (current-frame breakpoint &optional return-vals
					 function-end-cookie)
  (setf *default-breakpoint-debug-function*
	(di:frame-debug-function current-frame))
  (dolist (step-info *step-breakpoints*)
    (di:delete-breakpoint (breakpoint-info-breakpoint step-info))
    (let ((bp-info (location-in-list step-info *breakpoints*)))
      (when bp-info
	(di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
  (let ((*stack-top-hint* current-frame)
	(step-hit-info
	 (location-in-list (di:breakpoint-what breakpoint)
			   *step-breakpoints* (di:breakpoint-kind breakpoint)))
	(bp-hit-info
	 (location-in-list (di:breakpoint-what breakpoint)
			   *breakpoints* (di:breakpoint-kind breakpoint)))
	(break)
	(condition)
	(string ""))
    (setf *step-breakpoints* nil)
    (labels ((build-string (str)
	       (setf string (concatenate 'string string str)))
	     (print-common-info ()
	       (build-string 
		(with-output-to-string (*standard-output*)
		  (when function-end-cookie 
		    (format t "~%Return values: ~S" return-vals))
		  (when condition
		    (when (breakpoint-info-print bp-hit-info)
		      (format t "~%")
		      (print-frame-call current-frame))
		    (dolist (print (breakpoint-info-print bp-hit-info))
		      (format t "~& ~S = ~S" (rest print)
			      (funcall (first print) current-frame))))))))
      (when bp-hit-info
	(setf break (funcall (breakpoint-info-break bp-hit-info)
			     current-frame))
	(setf condition (funcall (breakpoint-info-condition bp-hit-info)
				 current-frame)))
      (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
	     (build-string (format nil "~&*Step (to a breakpoint)*"))
	     (print-common-info)
	     (break string))
	    ((and bp-hit-info step-hit-info break)
	     (build-string (format nil "~&*Step (to a breakpoint)*"))
	     (print-common-info)
	     (break string))
	    ((and bp-hit-info step-hit-info)
	     (print-common-info)
	     (format t "~A" string)
	     (decf *number-of-steps*)
Loading
Loading full blame...