Skip to content
Snippets Groups Projects
debug-int.lisp 187 KiB
Newer Older
;;; -*- Mode: Lisp; Log: code.log; Package: DI -*-
chiles's avatar
chiles committed
;;;
;;; **********************************************************************
;;; 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-int.lisp,v 1.127 2007/03/28 04:30:01 rtoy Exp $")
chiles's avatar
chiles committed
;;; **********************************************************************
;;;
;;; This file contains the implementation of the programmer's interface
;;; to writing debugging tools.
;;;
chiles's avatar
 
chiles committed
;;; Written by Bill Chiles and Rob Maclachlan.
chiles's avatar
chiles committed
;;;
;;; X86 support by Douglas Crosher 1996,1997,1998.
chiles's avatar
chiles committed

(in-package "DEBUG-INTERNALS")
chiles's avatar
 
chiles committed

chiles's avatar
chiles committed

;;; The compiler's debug-source structure is almost exactly what we want, so
;;; just get these symbols and export them.
;;;
(import '(c::debug-source-from c::debug-source-name c::debug-source-created
	  c::debug-source-compiled c::debug-source-start-positions
	  c::make-debug-source c::debug-source c::debug-source-p))
chiles's avatar
chiles committed

(export '(debug-variable-name debug-variable-package debug-variable-symbol
	  debug-variable-id debug-variable-value debug-variable-validity
	  debug-variable-valid-value debug-variable debug-variable-p

	  top-frame frame-down frame-up flush-frames-above frame-debug-function
chiles's avatar
chiles committed
	  frame-code-location eval-in-frame return-from-frame frame-catches
	  frame-number frame frame-p find-debug-tag-for-frame
chiles's avatar
chiles committed

chiles's avatar
 
chiles committed
	  do-debug-function-blocks debug-function-lambda-list
	  debug-variable-info-available do-debug-function-variables
	  debug-function-symbol-variables ambiguous-debug-variables
	  preprocess-for-eval function-debug-function debug-function-function
	  debug-function-kind debug-function-name debug-function
	  debug-function-p debug-function-start-location
chiles's avatar
chiles committed

	  do-debug-block-locations debug-block-successors debug-block
	  debug-block-p debug-block-elsewhere-p

	  make-breakpoint activate-breakpoint deactivate-breakpoint
chiles's avatar
 
chiles committed
	  breakpoint-active-p breakpoint-hook-function breakpoint-info
	  breakpoint-kind breakpoint-what breakpoint breakpoint-p
chiles's avatar
 
chiles committed
	  delete-breakpoint function-end-cookie-valid-p
chiles's avatar
chiles committed

	  code-location-debug-function code-location-debug-block
	  code-location-top-level-form-offset code-location-form-number
wlott's avatar
wlott committed
	  code-location-debug-source code-location-kind
	  code-location code-location-p code-location-unknown-p code-location=
chiles's avatar
chiles committed

	  debug-source-from debug-source-name debug-source-created
	  debug-source-compiled debug-source-root-number
	  debug-source-start-positions form-number-translations
	  source-path-context debug-source debug-source-p

	  debug-condition no-debug-info no-debug-function-returns
	  no-debug-blocks lambda-list-unavailable

	  debug-error unhandled-condition invalid-control-stack-pointer
	  unknown-code-location unknown-debug-variable invalid-value
	  ambiguous-variable-name frame-function-mismatch

chiles's avatar
 
chiles committed
	  set-breakpoint-for-editor set-location-breakpoint-for-editor
	  delete-breakpoint-for-editor

	  *debugging-interpreter*))
chiles's avatar
chiles committed



;;;; Conditions.

;;; The interface to building debugging tools signals conditions that prevent
;;; it from adhering to its contract.  These are serious-conditions because the
;;; program using the interface must handle them before it can correctly
;;; continue execution.  These debugging conditions are not errors since it is
;;; no fault of the programmers that the conditions occur.  The interface does
;;; not provide for programs to detect these situations other than calling a
;;; routine that detects them and signals a condition.  For example,
;;; programmers call A which may fail to return successfully due to a lack of
cwang's avatar
cwang committed
;;; debug information, and there is no B that they could have called to realize
chiles's avatar
chiles committed
;;; A would fail.  It is not an error to have called A, but it is an error for
;;; the program to then ignore the signal generated by A since it cannot
;;; continue without A's correctly returning a value or performing some
;;; operation.
;;;
;;; Use DEBUG-SIGNAL to signal these conditions.
;;;

(define-condition debug-condition (serious-condition)
  ()
  (:documentation
   "All debug-conditions inherit from this type.  These are serious conditions
    that must be handled, but they are not programmer errors."))

(define-condition no-debug-info (debug-condition)
  ()
  (:documentation "There is absolutely no debugging information available.")
  (:report (lambda (condition stream)
	     (declare (ignore condition))
chiles's avatar
 
chiles committed
	     (fresh-line stream)
chiles's avatar
chiles committed
	     (write-line "No debugging information available." stream))))

(define-condition no-debug-function-returns (debug-condition)
  ((debug-function :reader no-debug-function-returns-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
  (:documentation
   "The system could not return values from a frame with debug-function since
    it lacked information about returning values.")
  (:report (lambda (condition stream)
	     (let ((fun (debug-function-function
			 (no-debug-function-returns-debug-function condition))))
	       (format stream
chiles's avatar
 
chiles committed
		       "~&Cannot return values from ~:[frame~;~:*~S~] since ~
			the debug information lacks details about returning ~
			values here."
chiles's avatar
chiles committed
		       fun)))))

(define-condition no-debug-blocks (debug-condition)
  ((debug-function :reader no-debug-blocks-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
  (:documentation "The debug-function has no debug-block information.")
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S has no debug-block information."
chiles's avatar
chiles committed
		     (no-debug-blocks-debug-function condition)))))

(define-condition no-debug-variables (debug-condition)
  ((debug-function :reader no-debug-variables-debug-function
		   :initarg :debug-function))
  (:documentation "The debug-function has no debug-variable information.")
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S has no debug-variable information."
		     (no-debug-variables-debug-function condition)))))

chiles's avatar
chiles committed
(define-condition lambda-list-unavailable (debug-condition)
  ((debug-function :reader lambda-list-unavailable-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
  (:documentation
   "The debug-function has no lambda-list since argument debug-variables are
    unavailable.")
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S has no lambda-list information available."
chiles's avatar
chiles committed
		     (lambda-list-unavailable-debug-function condition)))))

(define-condition invalid-value (debug-condition)
  ((debug-variable :reader invalid-value-debug-variable
		   :initarg :debug-variable)
   (frame :reader invalid-value-frame :initarg :frame))
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S has :invalid or :unknown value in ~S."
		     (invalid-value-debug-variable condition)
		     (invalid-value-frame condition)))))

(define-condition ambiguous-variable-name (debug-condition)
  ((name :reader ambiguous-variable-name-name :initarg :name)
   (frame :reader ambiguous-variable-name-frame :initarg :frame))
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S names more than one valid variable in ~S."
		     (ambiguous-variable-name-name condition)
		     (ambiguous-variable-name-frame condition)))))
chiles's avatar
chiles committed


;;;; Errors and DEBUG-SIGNAL.

chiles's avatar
 
chiles committed
;;; The debug-internals code tries to signal all programmer errors as subtypes
;;; of debug-error.  There are calls to ERROR signalling simple-errors, but
cwang's avatar
cwang committed
;;; these dummy checks in the code shouldn't come up.
chiles's avatar
chiles committed
;;;
;;; While under development, this code also signals errors in code branches
;;; that remain unimplemented.
;;;

(define-condition debug-error (error) ()
  (:documentation
   "All programmer errors from using the interface for building debugging
    tools inherit from this type."))

(define-condition unhandled-condition (debug-error)
  ((condition :reader unhandled-condition-condition :initarg :condition))
chiles's avatar
chiles committed
  (:report (lambda (condition stream)
	     (format stream "~&Unhandled debug-condition:~%~A"
chiles's avatar
 
chiles committed
		     (unhandled-condition-condition condition)))))
chiles's avatar
chiles committed

(define-condition unknown-code-location (debug-error)
  ((code-location :reader unknown-code-location-code-location
		  :initarg :code-location))
chiles's avatar
chiles committed
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&Invalid use of an unknown code-location -- ~S."
chiles's avatar
chiles committed
		     (unknown-code-location-code-location condition)))))

(define-condition unknown-debug-variable (debug-error)
  ((debug-variable :reader unknown-debug-variable-debug-variable
		   :initarg :debug-variable)
   (debug-function :reader unknown-debug-variable-debug-function
		   :initarg :debug-function))
chiles's avatar
chiles committed
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
	     (format stream "~&~S not in ~S."
chiles's avatar
chiles committed
		     (unknown-debug-variable-debug-variable condition)
		     (unknown-debug-variable-debug-function condition)))))

chiles's avatar
 
chiles committed
(define-condition invalid-control-stack-pointer (debug-error)
  ()
  (:report (lambda (condition stream)
	     (declare (ignore condition))
	     (fresh-line stream)
	     (write-string "Invalid control stack pointer." stream))))

(define-condition frame-function-mismatch (debug-error)
  ((code-location :reader frame-function-mismatch-code-location
		  :initarg :code-location)
   (frame :reader frame-function-mismatch-frame :initarg :frame)
   (form :reader frame-function-mismatch-form :initarg :form))
chiles's avatar
chiles committed
  (:report (lambda (condition stream)
chiles's avatar
 
chiles committed
		     "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S"
		     (frame-function-mismatch-code-location condition)
		     (frame-function-mismatch-frame condition)
		     (frame-function-mismatch-form condition)))))
chiles's avatar
chiles committed


;;; DEBUG-SIGNAL -- Internal.
;;;
;;; This signals debug-conditions.  If they go unhandled, then signal an
;;; unhandled-condition error.
;;;
;;; ??? Get SIGNAL in the right package!
;;;
(defmacro debug-signal (datum &rest arguments)
chiles's avatar
 
chiles committed
  `(let ((condition (make-condition ,datum ,@arguments)))
     (signal condition)
chiles's avatar
chiles committed
     (error 'unhandled-condition :condition condition)))



;;;; Structures.

;;; Most of these structures model information stored in internal data
;;; structures created by the compiler.  Whenever comments preface an object or
;;; type with "compiler", they refer to the internal compiler thing, not to the
;;; object or type with the same name in the "DI" package.
;;;


;;;
;;; Debug-variables
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-functions.  Debug-functions store these.
;;;
chiles's avatar
 
chiles committed
(defstruct (debug-variable (:print-function print-debug-variable)
			   (:constructor nil))
chiles's avatar
chiles committed
  ;;
  ;; String name of variable.
  (name nil :type simple-string)
  ;;
  ;; String name of package.  Nil when variable's name is uninterned.
  (package nil :type (or null simple-string))
  ;;
  ;; Unique integer identification relative to other variables with the same
  ;; name and package.
  (id 0 :type c::index)
  ;;
  ;; Whether the variable always has a valid value.
  (alive-p nil :type boolean))
chiles's avatar
chiles committed

(defun print-debug-variable (obj str n)
  (declare (ignore n))
  (format str "#<Debug-Variable ~A:~A:~A>"
chiles's avatar
chiles committed
	  (debug-variable-package obj)
	  (debug-variable-name obj)
	  (debug-variable-id obj)))

(setf (documentation 'debug-variable-name 'function)
  "Returns the name of the debug-variable.  The name is the name of the symbol
   used as an identifier when writing the code.")

(setf (documentation 'debug-variable-package 'function)
  "Returns the package name of the debug-variable.  This is the package name of
   the symbol used as an identifier when writing the code.")

(setf (documentation 'debug-variable-id 'function)
  "Returns the integer that makes debug-variable's name and package name unique
   with respect to other debug-variable's in the same function.")


(defstruct (compiled-debug-variable
	    (:include debug-variable)
	    (:constructor make-compiled-debug-variable
			  (name package id alive-p sc-offset save-sc-offset)))
  ;;
  ;; Storage class and offset.  (unexported).
  (sc-offset nil :type c::sc-offset)
  ;;
  ;; Storage class and offset when saved somewhere.
  (save-sc-offset nil :type (or c::sc-offset null)))

(defstruct (interpreted-debug-variable
	    (:include debug-variable
		      (alive-p t))
	    (:constructor make-interpreted-debug-variable
			  (name package ir1-var)))
  ;;
  ;; This is the IR1 structure that holds information about interpreted vars.
  (ir1-var nil :type c::lambda-var))

chiles's avatar
chiles committed
;;;
;;; Frames
;;;

;;; These represents call-frames on the stack.
;;;
chiles's avatar
 
chiles committed
(defstruct (frame (:constructor nil))
chiles's avatar
chiles committed
  ;;
  ;; Next frame up.  Null when top frame.
  (up nil :type (or frame null))
  ;;
  ;; Previous frame down.  Nil when the bottom frame.  Before computing the
  ;; next frame down, this slot holds the frame pointer to the control stack
  ;; for the given frame.  This lets us get the next frame down and the
  ;; return-pc for that frame.
  (%down :unparsed :type (or frame (member nil :unparsed)))
  ;;
  ;; Debug-function for function whose call this frame represents.
  (debug-function nil :type debug-function)
  ;;
  ;; Code-location to continue upon return to frame.
  (code-location nil :type code-location)
  ;;
  ;; A-list of catch-tags to code-locations.
  (%catches :unparsed :type (or list (member :unparsed)))
  ;;
  ;; Pointer to frame on control stack.  (unexported)
  ;; When is an interpreted-frame, this is an index into the interpreter's
  ;; stack.
chiles's avatar
chiles committed
  pointer
  ;;
  ;; This is the frame's number for prompt printing.  Top is zero.
chiles's avatar
chiles committed

(setf (documentation 'frame-up 'function)
  "Returns the frame immediately above frame on the stack.  When frame is
   the top of the stack, this returns nil.")

(setf (documentation 'frame-debug-function 'function)
  "Returns the debug-function for the function whose call frame represents.")

(setf (documentation 'frame-code-location 'function)
  "Returns the code-location where the frame's debug-function will continue
   running when program execution returns to this frame.  If someone
   interrupted this frame, the result could be an unknown code-location.")


(defstruct (compiled-frame
	    (:include frame)
	    (:print-function print-compiled-frame)
	    (:constructor make-compiled-frame
			  (pointer up debug-function code-location number
				   #+gengc saved-state-chain
				   &optional escaped)))
  ;;
  ;; Indicates whether someone interrupted frame.  (unexported).
  ;; If escaped, this is a pointer to the state that was saved when we were
  ;; interrupted.  On the non-gengc system, this is a sigcontext pointer.
  ;; On the gengc system, this is a state pointer from saved-state-chain.
  escaped
  ;;
  ;; List of saps to saved states.  Each time we unwind past an exception,
  ;; we pop the next entry off this list.  When we get to the end of the
  ;; list, there is nothing else on the stack.
  #+gengc (saved-state-chain nil :type list))

(defun print-compiled-frame (obj str n)
  (declare (ignore n))
  (format str "#<Compiled-Frame ~S~:[~;, interrupted~]>"
	  (debug-function-name (frame-debug-function obj))
	  (compiled-frame-escaped obj)))


(defstruct (interpreted-frame
	    (:include frame)
	    (:print-function print-interpreted-frame)
	    (:constructor make-interpreted-frame
			  (pointer up debug-function code-location number
			   real-frame closure)))
  ;;
  ;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP.
  (real-frame nil :type compiled-frame)
  ;;
  ;; This is the closed over data used by the interpreter.
  (closure nil :type simple-vector))

(defun print-interpreted-frame (obj str n)
  (declare (ignore n))
  (format str "#<Interpreted-Frame ~S>"
	  (debug-function-name (frame-debug-function obj))))

chiles's avatar
chiles committed
;;;
;;; Debug-functions
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-functions.  *compiled-debug-functions* maps a c::debug-function to a
;;; debug-function.  There should only be one debug-function in existence for
;;; any function; that is, all code-locations and other objects that reference
;;; debug-functions point to unique objects.  This is due to the overhead in
;;; cached information.
;;;
(defstruct (debug-function (:print-function print-debug-function))
  ;;
  ;; Some representation of the function arguments.  See
  ;; DEBUG-FUNCTION-LAMBDA-LIST.
  ;; NOTE: must parse vars before parsing arg list stuff.
  (%lambda-list :unparsed)
  ;;
  ;; Cached debug-variable information.  (unexported).
chiles's avatar
chiles committed
  ;; These are sorted by their name.
  (debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
chiles's avatar
chiles committed
  ;;
  ;; Cached debug-block information.  This is nil when we have tried to parse
chiles's avatar
chiles committed
  ;; the packed binary info, but none is available.
  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
  ;;
  ;; The actual function if available.
  (%function :unparsed :type (or null function (member :unparsed))))

(defun print-debug-function (obj str n)
  (declare (ignore n))
  (format str "#<~A-Debug-Function ~S>"
	  (etypecase obj
	    (compiled-debug-function "Compiled")
	    (interpreted-debug-function "Interpreted")
	    (bogus-debug-function "Bogus"))
	  (debug-function-name obj)))
chiles's avatar
chiles committed


(defstruct (compiled-debug-function
	    (:include debug-function)
	    (:constructor %make-compiled-debug-function
			  (compiler-debug-fun component)))
  ;;
  ;; Compiler's dumped debug-function information.  (unexported).
  (compiler-debug-fun nil :type c::compiled-debug-function)
  ;;
  ;; Code object.  (unexported).
  component
  ;;
  ;; The :function-start breakpoint (if any) used to facilitate function
  ;; end breakpoints.
  (end-starter nil :type (or null breakpoint)))
chiles's avatar
chiles committed

;;; This maps c::compiled-debug-functions to compiled-debug-functions, so we
;;; can get at cached stuff and not duplicate compiled-debug-function
;;; structures.
;;;
(defvar *compiled-debug-functions* (make-hash-table :test #'eq))

;;; MAKE-COMPILED-DEBUG-FUNCTION -- Internal.
;;;
;;; Makes a compiled-debug-function for a c::compiler-debug-function and its
;;; component.  This maps the latter to the former in
;;; *compiled-debug-functions*.  If there already is a compiled-debug-function,
;;; then this returns it from *compiled-debug-functions*.
;;;
(defun make-compiled-debug-function (compiler-debug-fun component)
  (or (gethash compiler-debug-fun *compiled-debug-functions*)
      (setf (gethash compiler-debug-fun *compiled-debug-functions*)
	    (%make-compiled-debug-function compiler-debug-fun component))))


(defstruct (interpreted-debug-function
	    (:include debug-function)
	    (:constructor %make-interpreted-debug-function (ir1-lambda)))
  ;;
  ;; This is the ir1 lambda this debug-function represents.
  (ir1-lambda nil :type c::clambda))

(defstruct (bogus-debug-function
	    (:include debug-function)
	    (:constructor make-bogus-debug-function
			  (%name &aux (%lambda-list nil) (debug-vars nil)
				 (blocks nil) (%function nil))))
  %name)

(defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq))

(defun make-interpreted-debug-function (ir1-lambda)
  (let ((home-lambda (c::lambda-home ir1-lambda)))
    (or (gethash home-lambda *ir1-lambda-debug-function*)
	(setf (gethash home-lambda *ir1-lambda-debug-function*)
	      (%make-interpreted-debug-function home-lambda)))))
chiles's avatar
chiles committed

;;;
;;; Debug-blocks.
;;;

;;; These exist for caching data stored in packed binary form in compiler
;;; debug-blocks.
;;;
(defstruct (debug-block (:print-function print-debug-block))
chiles's avatar
chiles committed
  ;;
  ;; Code-locations where execution continues after this block.
  (successors nil :type list)
  ;;
  ;; This indicates whether the block is a special glob of code shared by
  ;; various functions and tucked away elsewhere in a component.  This kind of
  ;; block has no start code-location.  In an interpreted-debug-block, this is
  ;; always nil.  This slot is in all debug-blocks since it is an exported
  ;; interface.
  (elsewhere-p nil :type boolean))
chiles's avatar
chiles committed

(defun print-debug-block (obj str n)
  (declare (ignore n))
  (format str "#<~A-Debug-Block ~S>"
	  (etypecase obj
	    (compiled-debug-block "Compiled")
	    (interpreted-debug-block "Interpreted"))
chiles's avatar
chiles committed
	  (debug-block-function-name obj)))

(setf (documentation 'debug-block-successors 'function)
  "Returns the list of possible code-locations where execution may continue
   when the basic-block represented by debug-block completes its execution.")

(setf (documentation 'debug-block-elsewhere-p 'function)
  "Returns whether debug-block represents elsewhere code.")


(defstruct (compiled-debug-block (:include debug-block)
				 (:constructor
				  make-compiled-debug-block
				  (code-locations successors elsewhere-p)))
  ;;
  ;; Code-location information for the block.
  (code-locations nil :type simple-vector))

(defstruct (interpreted-debug-block (:include debug-block
					      (elsewhere-p nil))
				    (:constructor %make-interpreted-debug-block
						  (ir1-block)))
  ;;
  ;; This is the IR1 block this debug-block represents.
  (ir1-block nil :type c::cblock)
  ;;
  ;; Code-location information for the block.
  (locations :unparsed :type (or (member :unparsed) simple-vector)))

(defvar *ir1-block-debug-block* (make-hash-table :test #'eq))

;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal.
;;;
;;; This makes a debug-block for the interpreter's ir1-block.  If we have it in
;;; the cache, return it.  If we need to make it, then first make debug-blocks
;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the
;;; successors of ir1-block have debug-blocks.  We need this to fill in the
;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks.
;;; After making all the possible debug-blocks we'll need to reference, go back
;;; over the list of new debug-blocks and fill in their successor slots with
;;; lists of debug-blocks.  Then look up our argument ir1-block to find its
;;; debug-block since we know we have it now.
;;;
(defun make-interpreted-debug-block (ir1-block)
  (check-type ir1-block c::cblock)
  (let ((res (gethash ir1-block *ir1-block-debug-block*)))
    (or res
	(let ((lambda (c::block-home-lambda ir1-block)))
	  (c::do-blocks (block (c::block-component ir1-block))
	    (when (eq lambda (c::block-home-lambda block))
	      (push (setf (gethash block *ir1-block-debug-block*)
			  (%make-interpreted-debug-block block))
		    res)))
	  (dolist (block res)
	    (let* ((successors nil)
		   (cblock (interpreted-debug-block-ir1-block block))
		   (succ (c::block-succ cblock))
		   (valid-succ
		    (if (and succ
			     (eq (car succ)
				 (c::component-tail
				  (c::block-component cblock))))
			()
			succ)))
	      (dolist (sblock valid-succ)
		(let ((dblock (gethash sblock *ir1-block-debug-block*)))
		  (when dblock
		    (push dblock successors))))
	      (setf (debug-block-successors block) (nreverse successors))))
	  (gethash ir1-block *ir1-block-debug-block*)))))

chiles's avatar
chiles committed
;;;
;;; Breakpoints.
;;;

chiles's avatar
 
chiles committed
;;; This is an internal structure that manages information about a breakpoint
;;; locations.  See *component-breakpoint-offsets*.
;;;
(defstruct (breakpoint-data (:print-function print-breakpoint-data)
			    (:constructor make-breakpoint-data
					  (component offset)))
  ;;
  ;; This is the component in which the breakpoint lies.
  component
  ;;
  ;; This is the byte offset into the component.
  (offset nil :type c::index)
  ;;
  ;; The original instruction replaced by the breakpoint.
  (instruction nil :type (or null (unsigned-byte 32)))
  ;;
  ;; A list of user breakpoints at this location.
  (breakpoints nil :type list))
chiles's avatar
 
chiles committed
;;;
(defun print-breakpoint-data (obj str n)
  (declare (ignore n))
  (format str "#<Breakpoint-Data ~S at ~S>"
	  (debug-function-name
	   (debug-function-from-pc (breakpoint-data-component obj)
				   (breakpoint-data-offset obj)))
	  (breakpoint-data-offset obj)))
  
chiles's avatar
chiles committed
(defstruct (breakpoint (:print-function print-breakpoint)
chiles's avatar
 
chiles committed
		       (:constructor %make-breakpoint
				     (hook-function what kind %info)))
  ;;
  ;; This is the function invoked when execution encounters the breakpoint.  It
  ;; takes a frame, the breakpoint, and optionally a list of values.  Values
  ;; are supplied for :function-end breakpoints as values to return for the
chiles's avatar
 
chiles committed
  ;; function containing the breakpoint.  :function-end breakpoint
  ;; hook-functions also take a cookie argument.  See cookie-fun slot.
chiles's avatar
 
chiles committed
  (hook-function nil :type function)
  ;;
  ;; Code-location or debug-function.
  (what nil :type (or code-location debug-function))
  ;;
  ;; :code-location, :function-start, or :function-end for that kind of
  ;; breakpoint.  :unknown-return-partner if this is the partner of a
  ;; :code-location breakpoint at an :unknown-return code-location.
  (kind nil :type (member :code-location :function-start :function-end
			  :unknown-return-partner))
chiles's avatar
 
chiles committed
  ;;
  ;; Status helps the user and the implementation.
  (status :inactive :type (member :active :inactive :deleted))
  ;;
  ;; This is a backpointer to a breakpoint-data.
  (internal-data nil :type (or null breakpoint-data))
  ;;
  ;; With code-locations whose type is :unknown-return, there are really
  ;; two breakpoints: one at the multiple-value entry point, and one at
  ;; the single-value entry point.  This slot holds the breakpoint for the
  ;; other one, or NIL if this isn't at an :unknown-return code location.
chiles's avatar
 
chiles committed
  (unknown-return-partner nil :type (or null breakpoint))
  ;;
chiles's avatar
 
chiles committed
  ;; :function-end breakpoints use a breakpoint at the :function-start to
  ;; establish the end breakpoint upon function entry.  We do this by frobbing
  ;; the LRA to jump to a special piece of code that breaks and provides the
  ;; return values for the returnee.  This slot points to the start breakpoint,
  ;; so we can activate, deactivate, and delete it.
  (start-helper nil :type (or null breakpoint))
  ;;
  ;; This is a hook users supply to get a dynamically unique cookie for
  ;; identifying :function-end breakpoint executions.  That is, if there is one
  ;; :function-end breakpoint, but there may be multiple pending calls of its
  ;; function on the stack.  This function takes the cookie, and the
  ;; hook-function takes the cookie too.
  (cookie-fun nil :type (or null function))
  ;;
chiles's avatar
 
chiles committed
  ;; This slot users can set with whatever information they find useful.
  %info)
;;;
chiles's avatar
chiles committed
(defun print-breakpoint (obj str n)
  (declare (ignore n))
  (let ((what (breakpoint-what obj)))
    (format str "#<Breakpoint ~S~:[~;~:*~S~]>"
	    (etypecase what
	      (code-location what)
	      (debug-function (debug-function-name what)))
	    (etypecase what
	      (code-location nil)
	      (debug-function (breakpoint-kind obj))))))

chiles's avatar
 
chiles committed
(setf (documentation 'breakpoint-hook-function 'function)
  "Returns the breakpoint's function the system calls when execution encounters
   the breakpoint, and it is active.  This is SETF'able.")

(setf (documentation 'breakpoint-what 'function)
  "Returns the breakpoint's what specification.")

(setf (documentation 'breakpoint-kind 'function)
  "Returns the breakpoint's kind specification.")

chiles's avatar
chiles committed
;;;
;;; Code-locations.
;;;

chiles's avatar
 
chiles committed
(defstruct (code-location (:print-function print-code-location)
			  (:constructor nil))
chiles's avatar
chiles committed
  ;;
  ;; This is the debug-function containing code-location.
  (debug-function nil :type debug-function)
  ;;
  ;; This is initially :unsure.  Upon first trying to access an :unparsed slot,
  ;; if the data is unavailable, then this becomes t, and the code-location is
  ;; unknown.  If the data is available, this becomes nil, a known location.
  ;; We can't use a separate type code-location for this since we must return
  ;; code-locations before we can tell whether they're known or unknown.  For
  ;; example, when parsing the stack, we don't want to unpack all the variables
  ;; and blocks just to make frames.
  (%unknown-p :unsure :type (member t nil :unsure))
  ;;
  ;; This is the debug-block containing code-location.
  ;; Possibly toss this out and just find it in the blocks cache in
  ;; debug-function.
  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
  ;;
  ;; This is the number of forms processed by the compiler or loader before
  ;; the top-level form containing this code-location.
  (%tlf-offset :unparsed :type (or c::index (member :unparsed)))
  ;;
  ;; This is the depth-first number of the node that begins code-location
  ;; within its top-level form.
  (%form-number :unparsed :type (or c::index (member :unparsed))))
chiles's avatar
chiles committed

(defun print-code-location (obj str n)
  (declare (ignore n))
  (format str "#<~A ~S>"
	  (ecase (code-location-unknown-p obj)
	    ((nil) (etypecase obj
		     (compiled-code-location "Compiled-Code-Location")
		     (interpreted-code-location "Interpreted-Code-Location")))
chiles's avatar
chiles committed
	    ((t) "Unknown-Code-Location"))
	  (debug-function-name (code-location-debug-function obj))))

(setf (documentation 'code-location-debug-function 'function)
  "Returns the debug-function representing information about the function
   corresponding to the code-location.")


(defstruct (compiled-code-location
	    (:include code-location)
	    (:constructor make-known-code-location
			  (pc debug-function %tlf-offset %form-number
			      %live-set kind &aux (%unknown-p nil)))
	    (:constructor make-compiled-code-location (pc debug-function)))
  ;;
  ;; This is an index into debug-function's component slot.
  (pc nil :type c::index)
  ;;
  ;; This is a bit-vector indexed by a variable's position in
  ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid
  ;; value at this code-location.  (unexported).
  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
  ;;
  ;; (unexported)
chiles's avatar
 
chiles committed
  ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)".
  (kind :unparsed :type (or (member :unparsed) c::location-kind)))

(defstruct (interpreted-code-location
	    (:include code-location
		      (%unknown-p nil))
	    (:constructor make-interpreted-code-location
			  (ir1-node debug-function)))
  ;;
  ;; This is an index into debug-function's component slot.
  (ir1-node nil :type c::node))
  

chiles's avatar
chiles committed
;;;
;;; Debug-sources
;;;

pw's avatar
pw committed
(declaim (inline debug-source-root-number))
chiles's avatar
chiles committed
;;;
(defun debug-source-root-number (debug-source)
  "Returns the number of top-level forms processed by the compiler before
   compiling this source.  If this source is uncompiled, this is zero.  This
   may be zero even if the source is compiled since the first form in the first
   file compiled in one compilation, for example, must have a root number of
   zero -- the compiler saw no other top-level forms before it."
  (c::debug-source-source-root debug-source))

(setf (documentation 'c::debug-source-from 'function)
  "Returns an indication of the type of source.  The following are the possible
   values:
      :file    from a file (obtained by COMPILE-FILE if compiled).
      :lisp    from Lisp (obtained by COMPILE if compiled).
      :stream  from a non-file stream.")

(setf (documentation 'c::debug-source-name 'function)
  "Returns the actual source in some sense represented by debug-source, which
   is related to DEBUG-SOURCE-FROM:
      :file    the pathname of the file.
      :lisp    a lambda-expression.
      :stream  some descriptive string that's otherwise useless.")

(setf (documentation 'c::debug-source-created 'function)
  "Returns the universal time someone created the source.  This may be nil if
   it is unavailable.")

(setf (documentation 'c::debug-source-compiled 'function)
  "Returns the time someone compiled the source.  This is nil if the source
   is uncompiled.")

(setf (documentation 'c::debug-source-start-positions 'function)
  "This function returns the file position of each top-level form as an array
   if debug-source is from a :file.  If DEBUG-SOURCE-FROM is :lisp or :stream,
   this returns nil.")

chiles's avatar
chiles committed
(setf (documentation 'c::debug-source-p 'function)
  "Returns whether object is a debug-source.")



;;;; Frames.

chiles's avatar
 
chiles committed
;;; This is used in FIND-ESCAPE-FRAME and with the bogus components and LRAs
;;; used for :function-end breakpoints.  When a components debug-info slot is
;;; :bogus-lra, then the real-lra-slot contains the real component to continue
;;; executing, as opposed to the bogus component which appeared in some frame's
;;; LRA location.
;;;
(defconstant real-lra-slot vm:code-constants-offset)

;;; These are magically converted by the compiler.
chiles's avatar
 
chiles committed
(defun kernel:current-sp () (kernel:current-sp))
(defun kernel:current-fp () (kernel:current-fp))
(defun kernel:stack-ref (s n) (kernel:stack-ref s n))
(defun kernel:%set-stack-ref (s n value) (kernel:%set-stack-ref s n value))
chiles's avatar
 
chiles committed
(defun kernel:function-code-header (fun) (kernel:function-code-header fun))
#-gengc (defun kernel:lra-code-header (lra) (kernel:lra-code-header lra))
chiles's avatar
 
chiles committed
(defun kernel:make-lisp-obj (value) (kernel:make-lisp-obj value))
(defun kernel:get-lisp-obj-address (thing) (kernel:get-lisp-obj-address thing))
(defun kernel:function-word-offset (fun) (kernel:function-word-offset fun))
chiles's avatar
 
chiles committed
(defsetf kernel:stack-ref kernel:%set-stack-ref)
;;; DESCRIPTOR-SAP -- internal
;;;
;;; Convert the descriptor into a SAP.  The bits all stay the same, we just
;;; change our notion of what we think they are.
;;; 
(declaim (inline descriptor-sap))
(defun descriptor-sap (x)
  (system:int-sap (kernel:get-lisp-obj-address x)))


(declaim (inline cstack-pointer-valid-p))
chiles's avatar
chiles committed
(defun cstack-pointer-valid-p (x)
chiles's avatar
 
chiles committed
  (declare (type system:system-area-pointer x))
cwang's avatar
cwang committed
  #-(or :x86 :amd64)
  (and (system:sap< x (kernel:current-sp))
       (system:sap<= #-gengc (alien:alien-sap
			      (alien:extern-alien "control_stack" (* t)))
		     #+gengc (kernel:mutator-control-stack-base)
		     x)
ram's avatar
ram committed
       (zerop (logand (system:sap-int x) #b11)))
cwang's avatar
cwang committed
  #+(or :x86 :amd64) ;; stack grows to low address values
ram's avatar
ram committed
  (and (system:sap>= x (kernel:current-sp))
       (system:sap> (alien:alien-sap
		     (alien:extern-alien "control_stack_end" (* t)))
		    x)
       (zerop (logand (system:sap-int x) #b11))))

cwang's avatar
cwang committed
#+(or gengc x86 amd64)
(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
  (pc system:system-area-pointer))
ram's avatar
ram committed

cwang's avatar
cwang committed
#+(or gengc x86 amd64)
(defun component-from-component-ptr (component-ptr)
  (declare (type system:system-area-pointer component-ptr))
  (kernel:make-lisp-obj
   (logior (system:sap-int component-ptr)
	   vm:other-pointer-type)))
ram's avatar
ram committed

cwang's avatar
cwang committed
;;;; X86 and amd64 support.
ram's avatar
ram committed

cwang's avatar
cwang committed
#+(or x86 amd64)
;;; Note this function should be called with garbage collect inhibited.
(defun compute-lra-data-from-pc (pc)
ram's avatar
ram committed
  (declare (type system-area-pointer pc))
  (let ((component-ptr (component-ptr-from-pc pc)))
    (unless (sap= component-ptr (int-sap #x0))
       (let* ((code (component-from-component-ptr component-ptr))
	      (code-header-len (* (kernel:get-header-data code) vm:word-bytes))
	      (pc-offset (- (sap-int pc)
			    (- (kernel:get-lisp-obj-address code)
			       vm:other-pointer-type)
			    code-header-len)))
;	 (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
	 (values pc-offset code)))))
ram's avatar
ram committed

(defconstant vm::nargs-offset #.vm::ecx-offset)
ram's avatar
ram committed

;;; Check for a valid return address - it could be any valid C/Lisp
;;; address.
;;;
;;; XX Could be a little smarter.
(declaim (inline ra-pointer-valid-p))
(defun ra-pointer-valid-p (ra)
  (declare (type system:system-area-pointer ra))
  (and
   ;; Not the first page which is unmapped.
   (>= (sys:sap-int ra) 4096)
   ;; Not a Lisp stack pointer.
   (or (sys:sap< ra (kernel:current-sp))
       (sys:sap>= ra (alien:alien-sap
		      (alien:extern-alien "control_stack_end" (* t)))))))

;;; Try to find a valid previous stack. This is complex on the x86 as
;;; it can jump between C and Lisp frames. To help find a valid frame
;;; it searches backwards.
;;;
;;; XX Should probably check if it has reached the bottom of the
;;; stack.
;;;
;;; XX Should handle interrupted frames, both Lisp and C. A present it
;;; manages to find a fp trail, see linux hack below.
;;;
(defun x86-call-context (fp &key (depth 0))
  (declare (type system-area-pointer fp)
	   (fixnum depth))
;  (format t "*CC ~s ~s~%" fp depth)
  (cond
   ((not (cstack-pointer-valid-p fp))
    (format t "Debug invalid fp ~s~%" fp)
    nil)
   (t
    ;; Check the two possible frame pointers.
cwang's avatar
cwang committed
    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) 
					   vm:word-bytes))))
	  (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset)
					 vm:word-bytes))))
	  (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes)))
	  (c-ra (sap-ref-sap fp (* 1 vm:word-bytes))))
      (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
		  (ra-pointer-valid-p lisp-ra)
		  (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
		  (ra-pointer-valid-p c-ra))
;	     (format t "*C Both valid ~s ~s ~s ~s~%"
;		     lisp-ocfp lisp-ra c-ocfp c-ra)
	     ;; Look forward another step to check their validity.
	     (let ((lisp-path-fp (x86-call-context lisp-ocfp
						   :depth (1+ depth)))
		   (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
	       (cond ((and lisp-path-fp c-path-fp)
		      ;; Both still seem valid - choose the lisp frame.
		      (when (zerop depth)
			(format t "Debug: Both still valid ~s ~s ~s ~s~%"
				lisp-ocfp lisp-ra c-ocfp c-ra))
		      #+FreeBSD4
		      (if (sap> lisp-ocfp c-ocfp)
			  (values lisp-ra lisp-ocfp)
			  (values c-ra c-ocfp))
		      #-FreeBSD4
		      (values lisp-ra lisp-ocfp))
		     (lisp-path-fp
		      ;; The lisp convention is looking good.
;		      (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
		      (values lisp-ra lisp-ocfp))
		     (c-path-fp
		      ;; The C convention is looking good.
;		      (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
		      (values c-ra c-ocfp))
		     (t
		      ;; Neither seems right?
;		      (format t "Debug: no valid2 fp found ~s ~s~%"
;			      lisp-ocfp c-ocfp)
		      nil))))
	    ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
		  (ra-pointer-valid-p lisp-ra))
	     ;; The lisp convention is looking good.
;	     (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra)
	     (values lisp-ra lisp-ocfp))
	    ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
		  #-linux (ra-pointer-valid-p c-ra))
	     ;; The C convention is looking good.
;	     (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra)
	     (values c-ra c-ocfp))
	    (t
;	     (format t "Debug: no valid fp found ~s ~s~%" lisp-ocfp c-ocfp)
	     nil))))))
ram's avatar
ram committed

cwang's avatar
cwang committed
) ; end progn x86 amd64
chiles's avatar
chiles committed
;;; TOP-FRAME -- Public.
;;;
(defun top-frame ()
  "Returns the top frame of the control stack as it was before calling this
   function."
  (multiple-value-bind (fp pc)
      (kernel:%caller-frame-and-pc)
    (possibly-an-interpreted-frame