Newer
Older
;;; -*- Mode: Lisp; Log: code.log; Package: DI -*-
;;;
;;; **********************************************************************
;;; 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 $")
;;; **********************************************************************
;;;
;;; This file contains the implementation of the programmer's interface
;;; to writing debugging tools.
;;;
;;; X86 support by Douglas Crosher 1996,1997,1998.
;;; 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))
(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
frame-code-location eval-in-frame return-from-frame frame-catches
frame-number frame frame-p find-debug-tag-for-frame
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
do-debug-block-locations debug-block-successors debug-block
debug-block-p debug-block-elsewhere-p
make-breakpoint activate-breakpoint deactivate-breakpoint
breakpoint-active-p breakpoint-hook-function breakpoint-info
breakpoint-kind breakpoint-what breakpoint breakpoint-p
code-location-debug-function code-location-debug-block
code-location-top-level-form-offset code-location-form-number
code-location-debug-source code-location-kind
code-location code-location-p code-location-unknown-p code-location=
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
set-breakpoint-for-editor set-location-breakpoint-for-editor
delete-breakpoint-for-editor
*debugging-interpreter*))
;;;; 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
;;; debug information, and there is no B that they could have called to realize
;;; 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))
(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))
(: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
"~&Cannot return values from ~:[frame~;~:*~S~] since ~
the debug information lacks details about returning ~
values here."
fun)))))
(define-condition no-debug-blocks (debug-condition)
((debug-function :reader no-debug-blocks-debug-function
:initarg :debug-function))
(:documentation "The debug-function has no debug-block information.")
(:report (lambda (condition stream)
(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)
(no-debug-variables-debug-function condition)))))
((debug-function :reader lambda-list-unavailable-debug-function
:initarg :debug-function))
(:documentation
"The debug-function has no lambda-list since argument debug-variables are
unavailable.")
(:report (lambda (condition stream)
(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)
(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)
(ambiguous-variable-name-name condition)
(ambiguous-variable-name-frame condition)))))
;;; The debug-internals code tries to signal all programmer errors as subtypes
;;; of debug-error. There are calls to ERROR signalling simple-errors, but
;;;
;;; 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))
(:report (lambda (condition stream)
(format stream "~&Unhandled debug-condition:~%~A"
((code-location :reader unknown-code-location-code-location
:initarg :code-location))
(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))
(unknown-debug-variable-debug-variable condition)
(unknown-debug-variable-debug-function condition)))))
(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))
(format stream
(frame-function-mismatch-code-location condition)
(frame-function-mismatch-frame condition)
(frame-function-mismatch-form condition)))))
;;; 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)
(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.
;;;
(defstruct (debug-variable (:print-function print-debug-variable)
(:constructor nil))
;;
;; 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.
(defun print-debug-variable (obj str n)
(declare (ignore n))
(format str "#<Debug-Variable ~A:~A:~A>"
(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))
;;;
;;; Frames
;;;
;;; These represents call-frames on the stack.
;;;
;;
;; 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.
pointer
;;
;; This is the frame's number for prompt printing. Top is zero.
(number 0 :type index))
(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))
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
(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))))
;;;
;;; 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).
(debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
;; Cached debug-block information. This is nil when we have tried to parse
;; 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)))
(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)))
;;; 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)))))
;;;
;;; Debug-blocks.
;;;
;;; These exist for caching data stored in packed binary form in compiler
;;; debug-blocks.
;;;
(defstruct (debug-block (:print-function print-debug-block))
;;
;; 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.
(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"))
(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.")
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
(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*)))))
;;; 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))
;;;
(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)))
(: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
;; function containing the breakpoint. :function-end breakpoint
;; hook-functions also take a cookie argument. See cookie-fun slot.
(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))
;;
;; 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.
;; :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))
;;
;; This slot users can set with whatever information they find useful.
%info)
;;;
(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))))))
(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.")
(defstruct (code-location (:print-function print-code-location)
(:constructor nil))
;;
;; 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))))
(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")))
((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)
;; 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))
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
;;;
(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.")
(setf (documentation 'c::debug-source-p 'function)
"Returns whether object is a debug-source.")
;;;; Frames.
;;; 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.
(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))
#-gengc (defun kernel:lra-code-header (lra) (kernel:lra-code-header lra))
(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))
;;; 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))
(system:sap<= #-gengc (alien:alien-sap
(alien:extern-alien "control_stack" (* t)))
#+gengc (kernel:mutator-control-stack-base)
x)
#+(or :x86 :amd64) ;; stack grows to low address values
(system:sap> (alien:alien-sap
(alien:extern-alien "control_stack_end" (* t)))
x)
(zerop (logand (system:sap-int x) #b11))))
(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer)
(pc system:system-area-pointer))
(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)))
;;; Note this function should be called with garbage collect inhibited.
(defun compute-lra-data-from-pc (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)))))
(defconstant vm::nargs-offset #.vm::ecx-offset)
;;; 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.
(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))
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
(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))))))
;;; 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