Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
300b7156
Commit
300b7156
authored
34 years ago
by
chiles
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
87fd9c7c
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/debug-int.lisp
+1894
-0
1894 additions, 0 deletions
code/debug-int.lisp
with
1894 additions
and
0 deletions
code/debug-int.lisp
0 → 100644
+
1894
−
0
View file @
300b7156
;;; -*- 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
))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment