Skip to content
Snippets Groups Projects
Commit 300b7156 authored by chiles's avatar chiles
Browse files

Initial revision

parent 87fd9c7c
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: completion; Log: debug.log; Package: debug-internals -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file contains the implementation of the programmer's interface
;;; to writing debugging tools.
;;;
;;; Written by Bill Chiles.
;;; Designed by Rob Maclachlan and Bill Chiles.
;;;
(in-package "DEBUG-INTERNALS" :nicknames '("DI"))
;;; 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::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 frame-debug-function
frame-code-location eval-in-frame return-from-frame frame-catches
frame-number frame frame-p
do-blocks debug-function-lambda-list 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
do-debug-block-locations debug-block-successors debug-block
debug-block-p debug-block-elsewhere-p
make-breakpoint activate-breakpoint deactivate-breakpoint
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 code-location-p
unknown-code-location unknown-code-location-p
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))
;;;; 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 the 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)
(: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)
(:documentation "The debug-function has no debug-block information.")
(:report (lambda (condition stream)
(format stream "~S has no debug-block information."
(no-debug-blocks-debug-function condition)))))
(define-condition lambda-list-unavailable (debug-condition)
(debug-function)
(:documentation
"The debug-function has no lambda-list since argument debug-variables are
unavailable.")
(:report (lambda (condition stream)
(format stream "~S has no lambda-list information available."
(lambda-list-unavailable-debug-function condition)))))
;;;; Errors and DEBUG-SIGNAL.
;;; The debug internals code tries to signal all programmer errors as
;;; subtypes of debug-error. There are calls to ERROR signalling simple-errors,
;;; but these dummy checks in the code and shouldn't come up.
;;;
;;; 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))
(:report (lambda (condition stream)
(format stream "~&Unhandled debug-condition:~%~A"
condition))))
(define-condition invalid-control-stack-pointer (debug-error)
()
(:report (lambda (condition stream)
(declare (ignore condition))
(write-string "Invalid control stack pointer." stream))))
(define-condition unknown-code-location (debug-error)
((code-location))
(:report (lambda (condition stream)
(format stream "Invalid use of an unknown code-location -- ~S."
(unknown-code-location-code-location condition)))))
(define-condition unknown-debug-variable (debug-error)
((debug-variable)
(debug-function))
(:report (lambda (condition stream)
(format stream "~S not in ~S."
(unknown-debug-variable-debug-variable condition)
(unknown-debug-variable-debug-function condition)))))
(define-condition invalid-value (debug-error)
((debug-variable)
(frame))
(:report (lambda (condition stream)
(format stream "~S has :invalid or :unknown value in ~S."
(invalid-value-debug-variable condition)
(invalid-value-frame 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)
`(let ((condition (ext:signal ,datum ,@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 make-debug-variable
(name package id alive-p sc-offset
save-sc-offset)))
;;
;; 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 c::boolean)
;;
;; 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)))
(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.")
;;;
;;; Frames
;;;
;;; These represents call-frames on the stack.
;;;
(defstruct (frame (:print-function print-frame)
(:constructor make-frame
(pointer up debug-function code-location number
&optional escaped)))
;;
;; 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)
pointer
;;
;; Indicates whether someone interrupted frame. (unexported).
;; If escaped, this is a pointer to the escape frame on the control stack.
escaped
;;
;; This is the frame's number for prompt printing. Top is zero.
number)
(defun print-frame (obj str n)
(declare (ignore n))
(format str "#<Frame ~S~:[~;, interrupted~]>"
(debug-function-name (frame-debug-function obj))
(frame-escaped obj)))
(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.")
;;;
;;; 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).
;; These are sorted by their name.
(debug-vars :unparsed :type (or simple-vector (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 "#<Debug-function ~S>" (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)
;;; 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)))
;;;
;;; Debug-blocks.
;;;
;;; These exist for caching data stored in packed binary form in compiler
;;; debug-blocks.
;;;
(defstruct (debug-block (:print-function print-debug-block)
(:constructor make-debug-block
(code-locations successors elsewhere-p)))
;;
;; Code-location information for the block.
(code-locations nil :type simple-vector)
;;
;; Code-locations where execution continues after this block.
(successors nil :type list)
;;
;; This notes the block as a special glob of code shared by various functions
;; and tucked away elsewhere in a component. This kind of block has not
;; start code-location.
(elsewhere-p nil :type c::boolean))
(defun print-debug-block (obj str n)
(declare (ignore n))
(format str "#<Debug-block ~S>"
;; Fix up, for now assuming always have a code-location in 0.
(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.")
;;;
;;; Breakpoints.
;;;
(defstruct (breakpoint (:print-function print-breakpoint)
(:constructor %make-breakpoint))
hook-function ;Function takes frame, breakpoint, and optional values.
what ;Code-location or debug-function.
kind ;:code-location, :function-start, or :function-end.
info ;User settable and usable information.
active-p) ;Whether this breakpoint is in effect.
(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))))))
;;;
;;; Code-locations.
;;;
(defstruct (code-location (:print-function print-code-location)
(:constructor make-code-location
(pc debug-function &optional
%tlf-offset %form-number %live-set kind
;; Any optional means it's known.
(%unknown-p (not kind))))
(:constructor make-unknown-code-location
(pc debug-function &aux (%unknown-p t))))
;;
;; This is an index into debug-function's component slot.
(pc nil :type c::index)
;;
;; 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)))
;;
;; 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)
(kind :unparsed :type (member :unparsed :unknown-return :known-return
:internal-error :non-local-exit :block-start)))
(defun print-code-location (obj str n)
(declare (ignore n))
(format str "#<~A ~S>"
(ecase (code-location-unknown-p obj)
((nil) "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.")
;;;
;;; Debug-sources
;;;
(proclaim '(inline debug-source-root-number))
;;;
(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-p 'function)
"Returns whether object is a debug-source.")
;;;
;;; Interpreted-debug-infos.
;;;
(defstruct (interpreted-debug-info
(:print-function print-interpreted-debug-info))
)
(defun print-interpreted-debug-info (obj str n)
(declare (ignore n obj))
(write-string "#<Interpreted-Debug-Info>" str))
;;;; Frames.
(proclaim '(inline pointer+offset pointer- stack-ref env-valid-p
cstack-pointer-valid-p %set-stack-ref))
(defun pointer- (next previous)
(system:%primitive pointer- next previous))
(defun pointer+offset (x y)
(system:%primitive sap+ x (ash y 2)))
(defun stack-ref (s n)
(system:%primitive read-control-stack (pointer+offset s n)))
(defun %set-stack-ref (s n value)
(system:%primitive write-control-stack (pointer+offset s n) value))
;;;
(defsetf stack-ref %set-stack-ref)
(defun env-valid-p (env)
(and (functionp env)
(eql (system:%primitive get-vector-subtype env)
system:%function-constants-subtype)))
(defun cstack-pointer-valid-p (x)
(and (system:%primitive pointer< x (system:%primitive current-sp))
(not (system:%primitive pointer< x
(system:%primitive make-immediate-type 0
system:%control-stack-type)))))
;;; These are the names of all the functions that the system could have called
;;; while interpreting. We need to detect these when parsing the stack and
;;; make frames representing the code the intepreter is evaluating.
;;;
(defconstant interpreter-function-names nil)
;;; TOP-FRAME -- Public.
;;;
(defun top-frame ()
"Returns the top frame of the control stack as it was before calling this
function."
(compute-calling-frame (system:%primitive current-cont) nil))
(defun frame-down (frame)
"Returns the frame immediately below frame on the stack. When frame is
the bottom of the stack, this returns nil."
(let ((down (frame-%down frame)))
(if (eq down :unparsed)
(setf (frame-%down frame)
(compute-calling-frame (frame-pointer frame) frame))
down)))
;;; COMPUTE-CALLING-FRAME -- Internal.
;;;
;;; This returns a frame for the one existing in time immediately prior to the
;;; frame referenced by current-fp. This is current-fp's caller or the next
;;; frame down the control stack. If there is no down frame, this returns nil
;;; for the bottom of the stack. Up-frame is the up link for the resulting
;;; frame object, and it is nil when we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous frame we
;;; want, and the current frame contains the pc at which we will continue
;;; executing upon returning to that previous frame.
;;;
(defun compute-calling-frame (current-fp up-frame)
(let ((caller (stack-ref current-fp c::old-cont-save-offset)))
(unless (cstack-pointer-valid-p caller)
(return-from compute-calling-frame nil))
(multiple-value-bind (env env-fp escaped)
(fp-env caller current-fp)
(cond (escaped
;; If env-fp is escaped, then caller is the escape frame.
(multiple-value-bind
(env pc)
(pc-offset (escape-register caller c::return-pc-offset)
env up-frame)
(let ((d-fun (debug-function-from-pc env pc)))
(make-frame env-fp up-frame d-fun
(code-location-from-pc d-fun pc)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))
#|((member (system:%primitive header-ref env
system:%function-name-slot)
interpreter-function-names)
;; Just print calls within the interpreter as ... uh ... real calls
;; for now
)|#
(t
(multiple-value-bind
(env pc)
(pc-offset (stack-ref current-fp c::return-pc-save-offset)
env up-frame)
(let ((d-fun (debug-function-from-pc env pc)))
;; env-fp = caller.
(make-frame env-fp up-frame d-fun
(code-location-from-pc d-fun pc)
(if up-frame (1+ (frame-number up-frame)) 0)))))))))
;;; PC-OFFSET -- Internal.
;;;
;;; THIS FUNCTION BECOMES TOTALLY UNNECESSARY IN THE NEW SYSTEM WHEN PC'S
;;; ALWAYS DIRECTLY POINT TO COMPONENTS (OR ENVIRONMENTS).
;;;
;;; This takes a pc in the form of an interior pointer, the environment (code
;;; component) in which to interpret the pc, and next frame up the stack.
;;; Conceptually, we fetch the code vector from the environment and subtract
;;; the code vector's address from pc, turning pc into an offset. We also
;;; subtract off the code vector's header size. This leaves a pc that is an
;;; offset into the code vector.
;;;
;;; We actually have to be careful performing the above activity. Sometimes
;;; the argument env is not a function or environment due to funny calling
;;; conventions. That is, someone accessed a slot in a frame to get the env,
;;; but the particular calling convention used blew off storing a valid env in
;;; the slot. In this situation, use the frame's debug-function's environment
;;; and call CHECK-PC to compute and check the offset's validity, signalling
;;; an error if for some weird reason we still don't have a valid environment.
;;;
;;; Otherwise, assume the argument env is the environment and call CHECK-PC
;;; without signalling an error when env is invalid. The problem here is the
;;; test described in the previous paragraph could yield a valid environment
;;; object, but it isn't our environment as determined by CHECK-PC on the pc's
;;; offset validity. In this situation, as above, use the frame's
;;; debug-function's environment and call CHECK-PC signalling an error if we
;;; don't have a good environment still.
;;;
;;; CHECK-PC:
;;; We check the offset's validity by making sure it is a valid index into
;;; the code vector. If the pc, as an interior pointer, pointed into some
;;; other code vector, then the address arithmetic would yield an invalid
;;; index. When the index is invalid, so is the environment, and we have to
;;; iterate up the stack to find a frame that saved the appropriate
;;; environment. Not every frame saves its environment due to optimized local
;;; calling conventions. In this code, we always know someone has saved the
;;; environment because before we get here, we know someone has used the full
;;; call sequence (due to calling a debugger routine, calling ERROR, etc.), or
;;; some frame has escaped. We only have to look up the stack one frame since
;;; the appropriate environment propagates down through the frame objects.
;;;
(defun pc-offset (pc env up-frame)
(flet ((check-pc (pc env errorp)
(let* ((code-vector (system:%primitive header-ref env
system:%function-code-slot))
(offset (- (pointer- pc code-vector)
clc::i-vector-header-size)))
(cond ((<= 0 offset (length code-vector))
(values env offset))
(errorp
(error "Unexpected inappropriate environment for pc."))
(t nil)))))
(if (not (and (functionp env)
(eql (system:%primitive get-vector-subtype env)
#.system:%function-constants-subtype)))
(check-pc pc
(compiled-debug-function-component
(frame-debug-function up-frame))
t)
(multiple-value-bind (env offset) (check-pc pc env nil)
(if env
(values env offset)
(check-pc pc
(compiled-debug-function-component
(frame-debug-function up-frame))
t))))))
;;; FP-ENV -- Internal.
;;;
;;; This takes a frame pointer and returns its saved environment, taking care
;;; if fp points to an escape frame. As multiple values, this returns the
;;; environment, the appropriate frame pointer for the environment, and whether
;;; fp referenced an escape. If fp is an escape frame, then we return fp as
;;; the last value for convenience in accessing data saved in the escape frame.
;;;
(defun fp-env (fp current-fp)
(let ((env (stack-ref fp c::env-save-offset)))
(if (and (eql env 0)
;; If env is zero indicating an escape frame, then its return-pc
;; must point into an assembler routine for interrupts.
(= (system:%primitive get-type
(stack-ref current-fp
c::return-pc-save-offset))
system:%assembler-code-type))
;; Get the env of the interrupted frame.
(let ((env (escape-register fp c::env-offset)))
(cond ((eql (system:%primitive get-type env) system:%trap-type)
;; Just ignore these for frame handling.
)
((env-valid-p env)
(values env
;; This is valid since the escape frame must be
;; preceded by some frame.
(stack-ref fp c::old-cont-save-offset)
fp))
(t
(error "Escaping frame ENV invalid?"))))
(values env fp nil))))
#|
;;; FP-ENV -- Internal.
;;;
;;; This takes a frame pointer and returns its saved environment, taking care
;;; if fp points to an escape frame. As multiple values, this returns the
;;; environment, the appropriate frame pointer for the environment, and whether
;;; fp referenced an escape. If fp is an escape frame, then we return fp as
;;; the last value for convenience in accessing data saved in the escape frame.
;;;
(defun fp-env (fp)
(let ((env (stack-ref fp c::env-save-offset)))
(if (eql env 0)
;; Get the env of the interrupted frame.
(let ((env (escape-register fp c::env-offset)))
(cond ((eql (system:%primitive get-type env) system:%trap-type)
;; Just ignore these for frame handling.
)
((env-valid-p env)
(values env
;; This is valid since the escape frame must be
;; preceded by some frame.
(stack-ref fp c::old-cont-save-offset)
fp))
(t
(error "Escaping frame ENV invalid?"))))
(values env fp nil))))
|#
;;;
;;; Frame utilities.
;;;
;;; ESCAPE-REGISTER -- Internal.
;;;
;;; An escape register saves the value of a register for a frame that someone
;;; interrupts. This function returns the n'th saved register. F is the
;;; frame pointer to the escape frame which notes that someone interrupted the
;;; previous frame.
;;;
(defun escape-register (f n)
(stack-ref f (+ n system:%escape-frame-general-register-start-slot)))
;;; DEBUG-FUNCTION-FROM-PC -- Internal.
;;;
;;; This returns a compiled-debug-function for env and pc. We fetch the
;;; c::debug-info and run down its function-map to get a
;;; c::compiled-debug-function from the pc. The result only needs to reference
;;; the component, for function constants, and the c::compiled-debug-function.
;;;
(defun debug-function-from-pc (env pc)
(let* ((component (function-code-header env))
(info (system:%primitive header-ref component
system:%function-constants-debug-info-slot)))
(unless info
(debug-signal 'no-debug-info))
(let* ((function-map (c::compiled-debug-info-function-map info))
(len (length function-map)))
(declare (simple-vector function-map))
(if (= len 1)
(make-compiled-debug-function (svref function-map 0) component)
(let ((i 1))
(declare (type c::index i))
(loop
(when (or (= i len) (< pc (svref function-map i)))
(return (make-compiled-debug-function (svref function-map (1- i))
component)))
(incf i 2)))))))
;;; FUNCTION-CODE-HEADER -- Internal.
;;;
;;; This returns a pointer to the code data-block containing the function. The
;;; code header contains constants and debug-info. First we fetch the
;;; function's header word and shift out the type tag, leaving the offset back
;;; to the code header. Negate that and add it to the pointer to fun.
;;;
;;; IGNORE THE ABOVE COMMENT UNTIL RUNNING WITH THE NEW DATA FORMAT FOR THE
;;; NEW SYSTEM.
;;;
(defun function-code-header (fun)
(ecase (system:%primitive get-vector-subtype fun)
((#.system:%function-entry-subtype #.system:%function-closure-entry-subtype)
(system:%primitive header-ref fun system:%function-entry-constants-slot))
(#.system:%function-closure-subtype
(system:%primitive header-ref
(system:%primitive header-ref fun
system:%function-name-slot)
system:%function-entry-constants-slot))
(#.system:%function-constants-subtype
fun)))
;;; CODE-LOCATION-FROM-PC -- Internal.
;;;
;;; This returns a code-location for the compiled-debug-function, debug-fun,
;;; and the pc into its code vector. If there is debug-block info, we assume
;;; the code-location is known by making a default one. It may later prove
;;; to be unknown as :unparsed slots are accessed.
;;;
(defun code-location-from-pc (debug-fun pc)
;; For now, and this might be right:
(if (c::compiled-debug-function-blocks
(compiled-debug-function-compiler-debug-fun
debug-fun))
(make-code-location pc debug-fun)
(make-unknown-code-location pc debug-fun)))
(defun frame-catches (frame)
"Returns an a-list mapping catch tags to code-locations. These are
code-locations at which execution would continue with frame as the top
frame if someone threw to the corresponding tag."
(let ((catch (system:%primitive active-catch-frame))
(res nil)
(fp (frame-pointer frame)))
(loop
(when (eql catch 0) (return (nreverse res)))
(when (eq fp (stack-ref catch system:%unwind-block-current-cont))
(push (cons (stack-ref catch system:%catch-block-tag)
(make-code-location
(- (stack-ref catch system:%unwind-block-entry-pc)
clc::i-vector-header-size)
(frame-debug-function frame)))
res))
(setf catch (stack-ref catch system:%catch-block-previous-catch)))))
;;;; Debug-functions.
;;; DO-BLOCKS -- Public.
;;;
(defmacro do-blocks ((block-var debug-function &optional result) &body body)
"Executes the forms in a context with block-var bound to each debug-block
in debug-function successively. Result is an optional form to execute for
return values, and DO-BLOCKS returns nil if there is no result form. This
signals a no-debug-blocks condition when the debug-function lacks
debug-block information."
(let ((blocks (gensym))
(i (gensym)))
`(let ((,blocks (debug-function-debug-blocks ,debug-function)))
(declare (simple-vector ,blocks))
(dotimes (,i (length ,blocks) ,result)
(let ((,block-var (svref ,blocks ,i)))
,@body)))))
;;; DO-DEBUG-FUNCTION-VARIABLES -- Public.
;;;
(defmacro do-debug-function-variables ((var debug-function &optional result)
&body body)
"Executes body in a context with var bound to each debug-variable in
debug-function. This returns the value of executing result (defaults to
nil). This may iterate over only some of debug-function's variables or none
depending on debug policy; for example, possibly the compilation only
preserved argument information."
(let ((vars (gensym))
(i (gensym)))
`(let ((,vars (debug-function-debug-variables ,debug-function)))
(declare (simple-vector ,vars))
(dotimes (,i (length ,vars) ,result)
(let ((,var (svref ,vars ,i)))
,@body)))))
;;; DEBUG-FUNCTION-FUNCTION -- Public.
;;;
;;; ??? Can't work on the RT before back porting the new system from the MIPS.
;;;
(defun debug-function-function (debug-function)
"Returns the Common Lisp function associated with the debug-function. This
returns nil if the function is unavailable or is non-existent as a user
callable function object."
(etypecase debug-function
(compiled-debug-function
(setf (debug-function-%function debug-function) nil))
(interpreted-debug-function
(error "Can't currently debug interpreted functions."))))
;;; DEBUG-FUNCTION-NAME -- Public.
;;;
(defun debug-function-name (debug-function)
"Returns the name of the function represented by debug-function. This may
be a string or a cons; do not assume it is a symbol."
(etypecase debug-function
(compiled-debug-function
(c::compiled-debug-function-name
(compiled-debug-function-compiler-debug-fun debug-function)))
(interpreted-debug-function
(error "Can't get interpreted-debug-function names now."))))
;;; FUNCTION-DEBUG-FUNCTION -- Public.
;;;
(defun function-debug-function (fun)
"Returns a debug-function that represents debug information for function."
(debug-function-from-pc
fun
(- (system:%primitive header-ref fun system:%function-offset-slot)
clc::i-vector-header-size)))
;;; DEBUG-FUNCTION-KIND -- Public.
;;;
(defun debug-function-kind (debug-function)
"Returns the kind of the function which is one of :optional, :external,
:top-level, :cleanup, nil."
(etypecase debug-function
(compiled-debug-function
(c::compiled-debug-function-kind
(compiled-debug-function-compiler-debug-fun debug-function)))
(interpreted-debug-function
(error "We don't debug interpreted functions now."))))
;;; DEBUG-FUNCTION-SYMBOL-VARIABLES -- Public.
;;;
(defun debug-function-symbol-variables (debug-function symbol)
"Returns a list of debug-variables in debug-function having the same name
and package as symbol. If symbol is uninterned, then this returns a list of
debug-variables without package names and with the same name as symbol. The
result of this function is limited to the availability of variable
information in debug-function; for example, possibly debug-function only
knows about its arguments."
(let ((vars (ambiguous-debug-variables debug-function (symbol-name symbol)))
(package (if (symbol-package symbol)
(package-name (symbol-package symbol)))))
(delete-if (if (stringp package)
#'(lambda (var)
(let ((p (debug-variable-package var)))
(or (not (stringp p))
(string/= p package))))
#'(lambda (var)
(stringp (debug-variable-package var))))
vars)))
;;; AMBIGUOUS-DEBUG-VARIABLES -- Public.
;;;
(defun ambiguous-debug-variables (debug-function name-prefix-string)
"Returns a list of debug-variables in debug-function whose names contain
name-prefix-string as an intial substring. The result of this function is
limited to the availability of variable information in debug-function; for
example, possibly debug-function only knows about its arguments."
(declare (simple-string name-prefix-string))
(let* ((variables (debug-function-debug-variables debug-function))
(len (length variables))
(prefix-len (length name-prefix-string))
(pos (find-variable name-prefix-string variables len))
(res nil))
(declare (simple-vector variables))
(when pos
;; Find names from pos to variable's len that contain prefix.
(do ((i pos (1+ i)))
((= i len))
(let* ((var (svref variables i))
(name (debug-variable-name var))
(name-len (length name)))
(declare (simple-string name))
(when (/= (or (string/= name-prefix-string name
:end1 prefix-len :end2 name-len)
prefix-len)
prefix-len)
(return))
(push var res)))
(setq res (nreverse res)))
res))
;;; FIND-VARIABLE -- Internal.
;;;
;;; This returns a position in variables for one containing name as an initial
;;; substring. End is the length of variables if supplied.
;;;
(defun find-variable (name variables &optional end)
(declare (simple-vector variables)
(simple-string name))
(let ((name-len (length name)))
(position name variables
:test #'(lambda (x y)
(let* ((y (debug-variable-name y))
(y-len (length y)))
(declare (simple-string y))
(and (>= y-len name-len)
(string= x y :end1 name-len :end2 name-len))))
:end (or end (length variables)))))
#|
(multiple-value-bind (pos found)
(find-variable name-prefix-string variables len)
(declare (ignore found))
;;
;; Find names from pos to variable's len that contain prefix.
(do ((i pos (1+ i)))
((= i len))
(let* ((var (svref variables i))
(name (debug-variable-name var))
(name-len (length name)))
(declare (simple-string name))
(when (/= (or (string/= name-prefix-string name
:end1 prefix-len :end2 name-len)
prefix-len)
prefix-len)
(return))
(push var res)))
(setq res (nreverse res))
;;
;; Find names from pos to initial variable containing prefix.
(do ((i (1- pos) (1- i)))
((minusp i))
(let* ((var (svref variables i))
(name (debug-variable-name var))
(name-len (length name)))
(declare (simple-string name))
(when (/= (or (string/= name-prefix-string name
:end1 prefix-len :end2 name-len)
prefix-len)
prefix-len)
(return))
(push var res))))
;;; FIND-VARIABLE -- Internal.
;;;
;;; This does a binary search on variables for the one containing name as an
;;; initial substring. End is the length of variables if supplied. This
;;; returns two values: the position of the entry, and whether it was found.
;;; When it wasn't found, the position is where to insert a new entry.
;;;
(defun find-variable (name variables &optional end)
(declare (simple-vector variables)
(simple-string name))
(let ((low 0)
(high (or end (length variables)))
(mid 0)
(name-len (length name)))
(declare (fixnum low high mid name-len))
(loop
(when (< high low) (return (values low nil)))
(setf mid (+ (the fixnum (ash (the fixnum (- high low)) -1)) low))
(let* ((test-name (debug-variable-name (svref variables mid)))
(test-name-len (length test-name)))
(declare (simple-string test-name) (fixnum test-name-len))
(let ((res (string/= name test-name
:end1 name-len :end2 test-name-len)))
(declare (type (or null fixnum) res))
(cond ((null res)
(return (values mid t)))
((= res name-len)
(setf high (1- mid)))
((= res test-name-len)
(setf low (1+ mid)))
((char< (schar name res) (schar test-name res))
(setf high (1- mid)))
(t (setf low (1+ mid)))))))))
|#
;;; DEBUG-FUNCTION-LAMBDA-LIST -- Public.
;;;
(defun debug-function-lambda-list (debug-function)
"Returns a list representing the lambda-list for debug-function. The list
has the following structure:
(required-var1 required-var2
...
(:optional var3 suppliedp-var4)
(:optional var5)
...
(:rest var6) (:rest var7)
...
(:keyword keyword-symbol var8 suppliedp-var9)
(:keyword keyword-symbol var10)
...
)
Each VARi is a debug-variable."
(let ((lambda-list (debug-function-%lambda-list debug-function)))
(cond ((eq lambda-list :unparsed)
(etypecase debug-function
(compiled-debug-function
(multiple-value-bind
(args argsp)
(compiled-debug-function-lambda-list debug-function)
(setf (debug-function-%lambda-list debug-function) args)
(if argsp
args
(debug-signal 'lambda-list-unavailable
:debug-function debug-function))))
(interpreted-debug-function
(error "Can't get lambda-lists for interpreted-debug-functions ~
currently."))))
(lambda-list)
((c::compiled-debug-function-arguments
(compiled-debug-function-compiler-debug-fun
debug-function))
;; If the packed information is there (whether empty or not) as
;; opposed to being nil, then returned our cached value (nil).
nil)
(t
;; Our cached value is nil, and the packed lambda-list information
;; is nil, so we don't have anything available.
(debug-signal 'lambda-list-unavailable
:debug-function debug-function)))))
;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
;;;
;;; DEBUG-FUNCTION-LAMBDA-LIST calls this when a compiled-debug-function has no
;;; lambda-list information cached. It returns the lambda-list as the first
;;; value and whether there was any argument information as the second value.
;;;
(defun compiled-debug-function-lambda-list (debug-function)
(let ((args (c::compiled-debug-function-arguments
(compiled-debug-function-compiler-debug-fun
debug-function))))
(declare (type (or (simple-array * (*)) null) args))
(if (not args)
(values nil nil)
(let ((vars (debug-function-debug-variables debug-function))
(i 0)
(len (length args))
(res nil))
(declare (simple-vector vars))
(loop
(when (>= i len) (return))
(let ((ele (aref args i)))
(if (symbolp ele)
(case ele
(c::deleted
;; Deleted required arg at beginning of args array.
(push :deleted res))
(c::supplied-p
;; supplied-p var immediately following keyword or optional.
;; Stick the extra var in the result element representing
;; the keyword or optional.
;; ACTUALLY, WE DON'T HANDLE OPTIONALS CORRECTLY YET. ???
(let ((last (car res))
(v (compiled-debug-function-lambda-list-var
args (incf i) vars)))
(if (typep last 'cons)
(nconc last (list v))
(setf (car res) (list :optional last v)))))
(c::rest-arg
(push (list :rest
(compiled-debug-function-lambda-list-var
args (incf i) vars))
res))
(c::more-arg
(error "I thought I'd never see a more-arg?"))
(t
;; Keyword arg.
(push (list :keyword
ele
(compiled-debug-function-lambda-list-var
args (incf i) vars))
res)))
;; Required arg at beginning of args array.
(push (svref vars ele) res)))
(incf i))
(values (nreverse res) t)))))
;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST-VAR -- Internal
;;;
;;; Used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
;;;
(defun compiled-debug-function-lambda-list-var (args i vars)
(declare (type (simple-array * (*)) args)
(simple-vector vars))
(let ((ele (aref args i)))
(cond ((not (symbolp ele)) (svref vars ele))
((eq ele 'c::deleted) :deleted)
(t (error "Malformed arguments description.")))))
;;; DEBUG-FUNCTION-DEBUG-INFO -- Internal Interface.
;;;
(defun debug-function-debug-info (debug-fun)
(etypecase debug-fun
(compiled-debug-function
(system:%primitive header-ref
(compiled-debug-function-component debug-fun)
system:%function-constants-debug-info-slot))
(interpreted-debug-function
(error "Can't currently get the debug-info for an ~
interpreted-debug-function."))))
;;;; Unpacking variable and basic block data.
(defvar *parsing-buffer*
(make-array 20 :adjustable t :fill-pointer t))
(defvar *other-parsing-buffer*
(make-array 20 :adjustable t :fill-pointer t))
;;;
;;; WITH-PARSING-BUFFER -- Internal.
;;;
;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARIABLES use this to unpack binary
;;; encoded information. It returns the values returned by the last form
;;; in body.
;;;
;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at element
;;; zero, and makes sure if we unwind, we nil out any set elements for GC
;;; purposes.
;;;
;;; This also binds other-var to *other-parsing-buffer* when it is supplied,
;;; making sure it starts at element zero and that we nil out any elements if
;;; we unwind.
;;;
;;; This defines the local macro RESULT that takes a buffer, copies its
;;; elements to a resulting simple-vector, nil's out elements, and restarts
;;; the buffer at element zero. RESULT returns the simple-vector.
;;;
(eval-when (compile eval)
(defmacro with-parsing-buffer ((buffer-var &optional other-var) &body body)
(let ((len (gensym))
(res (gensym)))
`(unwind-protect
(let ((,buffer-var *parsing-buffer*)
,@(if other-var `((,other-var *other-parsing-buffer*))))
(setf (fill-pointer ,buffer-var) 0)
,@(if other-var `((setf (fill-pointer ,other-var) 0)))
(macrolet ((result (buf)
`(let* ((,',len (length ,buf))
(,',res (make-array ,',len)))
(replace ,',res ,buf :end1 ,',len :end2 ,',len)
(fill ,buf nil :end ,',len)
(setf (fill-pointer ,buf) 0)
,',res)))
,@body))
(fill *parsing-buffer* nil)
,@(if other-var `((fill *other-parsing-buffer* nil))))))
) ;eval-when
;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal Interface.
;;;
;;; The argument is a debug internals structure. This returns the debug-blocks
;;; for debug-function, regardless of whether we have unpacked them yet. It
;;; signals a no-debug-blocks condition if it can't return the blocks.
;;;
(defun debug-function-debug-blocks (debug-function)
(etypecase debug-function
(compiled-debug-function
(let ((blocks (debug-function-blocks debug-function)))
(cond ((eq blocks :unparsed)
(setf (debug-function-blocks debug-function)
(parse-debug-blocks debug-function))
(unless (debug-function-blocks debug-function)
(debug-signal 'no-debug-blocks
:debug-function debug-function))
(debug-function-blocks debug-function))
(blocks)
(t
(debug-signal 'no-debug-blocks
:debug-function debug-function)))))
(interpreted-debug-function
(error "We don't currently support interpreted-debug-functions."))))
;;; PARSE-DEBUG-BLOCKS -- Internal.
;;;
;;; Debug-fun is a c::compiled-debug-function. Var-count is how many variables
;;; the live-set data in packed binary form represents.
;;;
(defun parse-debug-blocks (debug-function)
(let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
(var-count (length (the simple-vector (debug-function-debug-variables
debug-function))))
(blocks (c::compiled-debug-function-blocks debug-fun))
;; 8 is a hard-wired constant in the compiler for the element size of
;; of the packed binary form of the blocks data.
(live-set-len (ceiling var-count 8))
(tlf-number (c::compiled-debug-function-tlf-number debug-fun)))
(unless blocks (return-from parse-debug-blocks nil))
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(with-parsing-buffer (blocks-buffer locations-buffer)
(let ((i 0)
(len (length blocks))
(last-pc 0))
(loop
(when (>= i len) (return))
(let ((succ-and-flags (aref+ blocks i))
(successors nil))
(declare (type (unsigned-byte 8) succ-and-flags)
(list successors))
(dotimes (k (ldb c::compiled-debug-block-nsucc-byte
succ-and-flags))
(push (c::read-var-integer blocks i) successors))
(let* ((locations
(dotimes (k (c::read-var-integer blocks i)
(result locations-buffer))
(let ((kind (svref c::compiled-code-location-kinds
(aref+ blocks i)))
(pc (+ last-pc (c::read-var-integer blocks i)))
(tlf-offset (or tlf-number
(c::read-var-integer blocks i)))
(form-number (c::read-var-integer blocks i))
(live-set (c::read-packed-bit-vector
live-set-len blocks i)))
(vector-push-extend (make-code-location
pc debug-function tlf-offset
form-number live-set kind)
locations-buffer)
(setf last-pc pc))))
(block (make-debug-block
locations successors
(not (zerop (logand
c::compiled-debug-block-elsewhere-p
succ-and-flags))))))
(vector-push-extend block blocks-buffer)
(dotimes (k (length locations))
(setf (code-location-%debug-block (svref locations k))
block))))))
(let ((res (result blocks-buffer)))
(declare (simple-vector res))
(dotimes (i (length res))
(let* ((block (svref res i))
(succs nil))
(dolist (ele (debug-block-successors block))
(push (svref res ele) succs))
(setf (debug-block-successors block) succs)))
res)))))
;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal Interface.
;;;
;;; The argument is a debug internals structure. The resulting vector may be
;;; empty.
;;;
(defun debug-function-debug-variables (debug-function)
(etypecase debug-function
(compiled-debug-function
(let ((vars (debug-function-debug-vars debug-function)))
(if (eq vars :unparsed)
(setf (debug-function-debug-vars debug-function)
(parse-debug-variables debug-function))
vars)))
(interpreted-debug-function
(error "We don't currently support interpreted-debug-functions."))))
;;; PARSE-DEBUG-VARIABLES -- Internal.
;;;
;;; This parses the packed binary representation of debug-variables from
;;; debug-function's c::compiled-debug-function.
;;;
(defun parse-debug-variables (debug-function)
(let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
(packed-vars (c::compiled-debug-function-variables debug-fun))
(default-package (c::compiled-debug-info-package
(debug-function-debug-info debug-function))))
(when (or (not packed-vars) (zerop (length packed-vars)))
(return-from parse-debug-variables '#()))
(let ((i 0)
(len (length packed-vars)))
(with-parsing-buffer (buffer)
(loop
(let ((flags (aref packed-vars i)))
(declare (type (unsigned-byte 8) flags))
(incf i)
;; The routines in the "C" package are macros that advance the index.
(let ((name (c::read-var-string packed-vars i))
(package (cond ((not
(zerop
(logand c::compiled-debug-variable-packaged
flags)))
(c::read-var-string packed-vars i))
((zerop
(logand c::compiled-debug-variable-uninterned
flags))
default-package)
(t nil)))
(id (if (zerop (logand c::compiled-debug-variable-id-p
flags))
0
(c::read-var-integer packed-vars i)))
(sc-offset (c::read-var-integer packed-vars i))
(save-sc-offset (if (zerop
(logand
c::compiled-debug-variable-save-loc-p
flags))
nil
(c::read-var-integer packed-vars i))))
(vector-push-extend
(make-debug-variable
name package id
(not (zerop (logand c::compiled-debug-variable-environment-live
flags)))
sc-offset save-sc-offset)
buffer)))
(when (>= i len) (return)))
(result buffer)))))
;;;; Code-locations.
;;; CODE-LOCATION-UNKNOWN-P -- Public.
;;;
;;; If we're sure of whether code-location is known, return t or nil. If we're
;;; :unsure, then try to fill in the code-location's slots. This determines
;;; whether there is any debug-block information, and if code-location is
;;; known.
;;;
;;; ??? IF this conses closures every time it's called, then break off the
;;; :unsure part to get the HANDLER-CASE into another function.
;;;
(defun code-location-unknown-p (basic-code-location)
"Returns whether basic-code-location is unknown. It returns nil when the
code-location is known."
(ecase (code-location-%unknown-p basic-code-location)
((t) t)
((nil) nil)
(:unsure
(setf (code-location-%unknown-p basic-code-location)
(handler-case (not (fill-in-code-location basic-code-location))
(no-debug-blocks () t))))))
;;; CODE-LOCATION-DEBUG-BLOCK -- Public.
;;;
;;; We don't use CODE-LOCATION= since the code-location may be unknown, but
;;; even when it is, we can determine the block. To do this we have to check
;;; pc ranges for the blocks. We use DEBUG-FUNCTION-DEBUG-BLOCKS to make sure
;;; any block info is unparsed and to signal a no-debug-blocks condition when
;;; appropriate.
;;;
;;; If there's only one block, it must be it. If there's more than one, we
;;; skip the first one and find the first block whose first code-location is
;;; greater than we want. Then we know we want the previous block. The last
;;; block is special since it may represent elsewhere code which has no start
;;; code-location. If it is elsewhere code, it starts where the
;;; c::compiled-debug-function tells us the elsewhere code starts.
;;;
;;; ??? How to write this for interpreted code-locations.
;;;
(defun code-location-debug-block (basic-code-location)
"Returns the debug-block containing code-location if it is available. Some
debug policies inhibit debug-block information, and if none is available,
then this signals a no-debug-blocks condition."
(let ((block (code-location-%debug-block basic-code-location)))
(if (eq block :unparsed)
(let* ((pc (code-location-pc basic-code-location))
(debug-function (code-location-debug-function
basic-code-location))
(blocks (debug-function-debug-blocks debug-function))
(len (length blocks)))
(declare (simple-vector blocks))
(setf
(code-location-%debug-block basic-code-location)
(if (= len 1)
(svref blocks 0)
(do ((i 1 (1+ i))
(end (1- len)))
((= i end)
(let ((last (svref blocks end)))
(cond
((debug-block-elsewhere-p last)
(if (< pc
(c::compiled-debug-function-elsewhere-pc
(compiled-debug-function-compiler-debug-fun
debug-function)))
(svref blocks (1- end))
last))
((< pc
(code-location-pc
(svref (debug-block-code-locations last)
0)))
(svref blocks (1- end)))
(t last))))
(declare (type c::index i end))
(when (< pc
(code-location-pc
(svref (debug-block-code-locations (svref blocks i))
0)))
(return (svref blocks (1- i))))))))
block)))
;;; CODE-LOCATION-DEBUG-SOURCE -- Public.
;;;
(defun code-location-debug-source (code-location)
"Returns the code-location's debug-source."
(let ((info (debug-function-debug-info
(code-location-debug-function code-location))))
(etypecase info
(c::compiled-debug-info
(let* ((sources (c::compiled-debug-info-source info))
(len (length sources)))
(declare (list sources))
(if (= len 1)
(car sources)
(do ((prev (car sources) src)
(src (cdr sources) (cdr src))
(offset (code-location-top-level-form-offset code-location)))
((null src) (car prev))
(when (< offset (c::debug-source-source-root (car src)))
(car prev))))))
(interpreted-debug-info
(error "Can't handle interpreted-debug-infos.")))))
;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public.
;;;
(defun code-location-top-level-form-offset (code-location)
"Returns the number of top-level forms before the one containing
code-location as seen by the compiler in some compilation unit. A
compilation unit is not necessarily a single file, see the section on
debug-sources."
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(let ((tlf-offset (code-location-%tlf-offset code-location)))
(cond ((eq tlf-offset :unparsed)
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing debug info
;; the compiler should have dumped.
(error "Unknown code location? It should be known."))
(code-location-%tlf-offset code-location))
(t tlf-offset))))
;;; CODE-LOCATION-FORM-NUMBER -- Public.
;;;
(defun code-location-form-number (code-location)
"Returns the number of the form corresponding to code-location. The form
number is derived by a walking the subforms of a top-level form in
depth-first order."
(when (code-location-unknown-p code-location)
(error 'unknown-code-location :code-location code-location))
(let ((form-num (code-location-%form-number code-location)))
(cond ((eq form-num :unparsed)
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing debug info
;; the compiler should have dumped.
(error "Unknown code location? It should be known."))
(code-location-%form-number code-location))
(t form-num))))
;;; CODE-LOCATION-LIVE-SET -- Internal Interface.
;;;
;;; This returns the code-location's live-set if it is available. If there
;;; is no debug-block information, this returns nil.
;;;
(defun code-location-live-set (code-location)
(if (code-location-unknown-p code-location)
nil
(let ((live-set (code-location-%live-set code-location)))
(cond ((eq live-set :unparsed)
(unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing debug info
;; the compiler should have dumped.
(error "Unknown code location? It should be known."))
(code-location-%live-set code-location))
(t live-set)))))
;;; CODE-LOCATION= -- Public.
;;;
(defun code-location= (obj1 obj2)
"Returns whether obj1 and obj2 are the same place in the code."
(let ((d-fun1 (code-location-debug-function obj1))
(d-fun2 (code-location-debug-function obj2)))
(and (eq d-fun1 d-fun2)
(sub-code-location= d-fun1 obj1 obj2))))
(defun sub-code-location= (d-fun1 obj1 obj2)
(etypecase d-fun1
(compiled-debug-function
(= (code-location-pc obj1) (code-location-pc obj2)))
(interpreted-debug-function
;; ??? compare IR1 nodes?
(error "Cannot compare interpreted-debug-functions currently."))))
;;; FILL-IN-CODE-LOCATION -- Internal.
;;;
;;; This fills in location's :unparsed slots. It returns t or nil depending on
;;; whether the code-location was known in its debug-function's debug-block
;;; information. This may signal a no-debug-blocks condition due to
;;; DEBUG-FUNCTION-DEBUG-BLOCKS, and it assumes the %unknown-p slot is already
;;; set or going to be set.
;;;
(defun fill-in-code-location (code-location)
(let* ((debug-function (code-location-debug-function code-location))
(blocks (debug-function-debug-blocks debug-function)))
(declare (simple-vector blocks))
(dotimes (i (length blocks) nil)
(let* ((block (svref blocks i))
(locations (debug-block-code-locations block)))
(declare (simple-vector locations))
(dotimes (j (length locations))
(let ((loc (svref locations j)))
(when (sub-code-location= debug-function code-location loc)
(setf (code-location-%debug-block code-location) block)
(setf (code-location-%tlf-offset code-location)
(code-location-%tlf-offset loc))
(setf (code-location-%form-number code-location)
(code-location-%form-number loc))
(setf (code-location-%live-set code-location)
(code-location-%live-set loc))
(setf (code-location-kind code-location)
(code-location-kind loc))
(return-from fill-in-code-location t))))))))
;;;; Debug-blocks.
;;; DO-DEBUG-BLOCK-LOCATIONS -- Public.
;;;
(defmacro do-debug-block-locations ((code-var debug-block &optional return)
&body body)
"Executes forms in a context with code-var bound to each code-location in
debug-block. This returns the value of executing result (defaults to nil)."
(let ((code-locations (gensym))
(i (gensym)))
`(let ((,code-locations (debug-block-code-locations ,debug-block)))
(declare (simple-vector ,code-locations))
(dotimes (,i (length ,code-locations) ,return)
(let ((,code-var (svref ,code-locations ,i)))
,@body)))))
;;; DEBUG-BLOCK-FUNCTION-NAME -- Internal.
;;;
(defun debug-block-function-name (debug-block)
"Returns the name of the function represented by debug-function. This may
be a string or a cons; do not assume it is a symbol."
(let ((code-locs (debug-block-code-locations debug-block)))
(declare (simple-vector code-locs))
(when (zerop (length code-locs))
(error "No code-locations in debug-block? -- ~S." debug-block))
(debug-function-name (code-location-debug-function (svref code-locs 0)))))
;;;; Variables.
;;; DEBUG-VARIABLE-SYMBOL -- Public.
;;;
(defun debug-variable-symbol (debug-var)
"Returns the symbol from interning DEBUG-VARIABLE-NAME in the package named
by DEBUG-VARIABLE-PACKAGE."
(let ((package (debug-variable-package debug-var)))
(if package
(intern (debug-variable-name debug-var) package)
(make-symbol (debug-variable-name debug-var)))))
;;; DEBUG-VARIABLE-VALID-VALUE -- Public.
;;;
(defun debug-variable-valid-value (debug-var frame)
"Returns the value stored for debug-variable in frame. If the value is not
:valid, then this signals an invalid-value error."
(unless (eq (debug-variable-validity debug-var (frame-code-location frame))
:valid)
(error 'invalid-value :debug-variable debug-var :frame frame))
(debug-variable-value debug-var frame))
;;; DEBUG-VARIABLE-VALUE -- Public.
;;;
(defun debug-variable-value (debug-var frame)
"Returns the value stored for debug-variable in frame. The value may be
invalid."
(let ((escaped (frame-escaped frame)))
(if escaped
(sub-debug-var-value (frame-pointer frame)
(debug-variable-sc-offset debug-var)
escaped)
(sub-debug-var-value (frame-pointer frame)
(or (debug-variable-save-sc-offset debug-var)
(debug-variable-sc-offset debug-var))))))
(defun sub-debug-var-value (fp sc-offset &optional escaped)
(ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register.
(if escaped
(stack-ref escaped (+ system:%escape-frame-general-register-start-slot
(c::sc-offset-offset sc-offset)))
:invalid-value-for-unescaped-register-storage))
(2 (error "Local non-descriptor register access?"))
(3 ;; String-char register (w/o tag bits)
(if escaped
(code-char
(stack-ref escaped (+ system:%escape-frame-general-register-start-slot
(c::sc-offset-offset sc-offset))))
:invalid-value-for-unescaped-register-storage))
(4 ;; Descriptors on the stack.
(stack-ref fp (c::sc-offset-offset sc-offset)))
(5 ;; String-chars on the stack (w/o tag bits).
(code-char (stack-ref fp (c::sc-offset-offset sc-offset))))))
(defun %set-debug-variable-value (debug-var frame value)
(let ((escaped (frame-escaped frame)))
(if escaped
(sub-%set-debug-var-value (frame-pointer frame)
(debug-variable-sc-offset debug-var)
value
escaped)
(sub-%set-debug-var-value (frame-pointer frame)
(or (debug-variable-save-sc-offset debug-var)
(debug-variable-sc-offset debug-var))
value))))
;;;
(defun sub-%set-debug-var-value (fp sc-offset value &optional escaped)
(ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register.
(if escaped
(setf (stack-ref escaped
(+ system:%escape-frame-general-register-start-slot
(c::sc-offset-offset sc-offset)))
value)
value))
(2 (error "Local non-descriptor register access?"))
(3 ;; String-char register (w/o tag bits)
(if escaped
(setf (stack-ref escaped
(+ system:%escape-frame-general-register-start-slot
(c::sc-offset-offset sc-offset)))
(char-code value))
value))
(4 ;; Descriptors on the stack.
(setf (stack-ref fp (c::sc-offset-offset sc-offset)) value))
(5 ;; String-chars on the stack (w/o tag bits).
(setf (stack-ref fp (c::sc-offset-offset sc-offset))
(char-code value)))))
;;;
(defsetf debug-variable-value %set-debug-variable-value)
;;; DEBUG-VARIABLE-VALIDITY -- Public.
;;;
;;; If the variable is always alive, then it is valid. If the code-location is
;;; unknown, then the variable's validity is :unknown. Once we've called
;;; CODE-LOCATION-UNKNOWN-P, we know the live-set information has been cached
;;; in the code-location.
;;;
(defun debug-variable-validity (debug-var basic-code-loc)
"Returns three values reflecting the validity of debug-variable's value
at basic-code-location:
:valid The value is known to be available.
:invalid The value is known to be unavailable.
:unknown The value's availability is unknown."
(cond ((debug-variable-alive-p debug-var)
(let ((debug-fun (code-location-debug-function basic-code-loc)))
(etypecase debug-fun
(compiled-debug-function
(if (>= (code-location-pc basic-code-loc)
(c::compiled-debug-function-start-pc
(compiled-debug-function-compiler-debug-fun debug-fun)))
:valid
:invalid))
(interpreted-debug-function
(error "Don't do interpreted debug-variable validity now.")))))
((code-location-unknown-p basic-code-loc) :unknown)
(t
(let ((pos (position debug-var
(debug-function-debug-variables
(code-location-debug-function basic-code-loc)))))
(unless pos
(error 'unknown-debug-variable
:debug-variable debug-var
:debug-function
(code-location-debug-function basic-code-loc)))
;; There must be live-set info since basic-code-loc is known.
(if (zerop (sbit (code-location-live-set basic-code-loc) pos))
:invalid
:valid)))))
;;;; Sources.
;;; Written by Rob Maclachlan.
;;; Documented by Bill Chiles.
;;;
;;; This code produces and uses what we call source-paths. A source-path is a
;;; list whose first element is a form number as returned by
;;; CODE-LOCATION-FORM-NUMBER and whose last element is a top-level-form number
;;; as returned by CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the
;;; last to the first, exclusively, are the numbered subforms into which to
;;; descend. For example:
;;; (defun foo (x)
;;; (let ((a (aref x 3)))
;;; (cons a 3)))
;;; The call to AREF in this example is form number 5. Assuming this DEFUN is
;;; the 11'th top-level-form, the source-path for the AREF call is as follows:
;;; (5 1 0 1 3 11)
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 gets the
;;; first binding, and 1 gets the AREF form.
;;;
;;; Temporary buffer used to build form-number => source-path translation in
;;; FORM-NUMBER-TRANSLATIONS.
;;;
(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
;;;
(defvar *form-number-circularity-table* (make-hash-table :test #'eq))
;;; FORM-NUMBER-TRANSLATIONS -- Public.
;;;
;;; The vector elements are in the same format as the compiler's
;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
;;; is the top-level-form number.
;;;
(defun form-number-translations (form tlf-number)
"This returns a table mapping form numbers to source-paths. A source-path
indicates a descent into the top-level-form form, going directly to the
subform corressponding to the form number."
(clrhash *form-number-circularity-table*)
(setf (fill-pointer *form-number-temp*) 0)
(sub-translate-form-numbers form (list tlf-number))
(coerce *form-number-temp* 'simple-vector))
;;;
(defun sub-translate-form-numbers (form path)
(unless (gethash form *form-number-circularity-table*)
(setf (gethash form *form-number-circularity-table*) t)
(vector-push-extend (cons (fill-pointer *form-number-temp*) path)
*form-number-temp*)
(let ((pos 0)
(subform form)
(trail form))
(declare (fixnum pos))
(macrolet ((frob ()
'(progn
(when (atom subform) (return))
(let ((fm (car subform)))
(when (consp fm)
(sub-translate-form-numbers fm (cons pos path)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
(loop
(frob)
(frob)
(setq trail (cdr trail)))))))
;;; SOURCE-PATH-CONTEXT -- Public.
;;;
(defun source-path-context (form path context)
"Form is a top-level form, and path is a source-path into it. This returns
the form indicated by the source-path. Context is the number of enclosing
forms to return instead of directly returning the source-path form. When
context is non-zero, the form returned contains a marker, #:****HERE****,
immediately before the form indicated by path."
(declare (type unsigned-byte context))
;;
;; Get to the form indicated by path or the enclosing form indicated by
;; context and path.
(let ((path (nreverse (butlast (cdr path)))))
(dotimes (i (- (length path) context))
(setq form (elt form (first path)))
(setq path (rest path)))
;;
;; Recursively rebuild the source form resulting from the above descent,
;; copying the beginning of each subform up to the next subform we descend
;; into according to path. At the bottom of the recursion, we return the
;; form indicated by path preceded by our marker, and this gets spliced
;; into the resulting list structure on the way back up.
(labels ((frob (form path level)
(if (or (zerop level) (null path))
(if (zerop context)
form
`(#:***here*** ,form))
(let* ((n (first path))
(res (frob (elt form n) (rest path) (1- level))))
(nconc (subseq form 0 n)
(cons res (nthcdr (1+ n) form)))))))
(frob form path context))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment