Skip to content
Snippets Groups Projects
Commit 4efb990b authored by ram's avatar ram
Browse files

Mucho changes for interpreted code debugging. Also a couple of stack

parsing bug fixes and definitions for EVAL-IN-FRAME/PROCESS-FRAME.
parent 2f1d01e9
No related branches found
No related tags found
No related merge requests found
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
;;; ;;;
(import '(c::debug-source-from c::debug-source-name c::debug-source-created (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-compiled c::debug-source-start-positions
c::debug-source c::debug-source-p)) c::make-debug-source c::debug-source c::debug-source-p))
(export '(debug-variable-name debug-variable-package debug-variable-symbol (export '(debug-variable-name debug-variable-package debug-variable-symbol
debug-variable-id debug-variable-value debug-variable-validity debug-variable-id debug-variable-value debug-variable-validity
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
code-location-debug-function code-location-debug-block code-location-debug-function code-location-debug-block
code-location-top-level-form-offset code-location-form-number code-location-top-level-form-offset code-location-form-number
code-location-debug-source code-location code-location-p code-location-debug-source code-location code-location-p
unknown-code-location unknown-code-location-p code-location-unknown-p code-location=
debug-source-from debug-source-name debug-source-created debug-source-from debug-source-name debug-source-created
debug-source-compiled debug-source-root-number debug-source-compiled debug-source-root-number
...@@ -59,7 +59,10 @@ ...@@ -59,7 +59,10 @@
no-debug-blocks lambda-list-unavailable no-debug-blocks lambda-list-unavailable
debug-error unhandled-condition invalid-control-stack-pointer debug-error unhandled-condition invalid-control-stack-pointer
unknown-code-location unknown-debug-variable invalid-value)) unknown-code-location unknown-debug-variable invalid-value
ambiguous-variable-name frame-function-mismatch
*debugging-interpreter*))
...@@ -116,6 +119,13 @@ ...@@ -116,6 +119,13 @@
(format stream "~S has no debug-block information." (format stream "~S has no debug-block information."
(no-debug-blocks-debug-function condition))))) (no-debug-blocks-debug-function condition)))))
(define-condition no-debug-variables (debug-condition)
(debug-function)
(:documentation "The debug-function has no debug-variable information.")
(:report (lambda (condition stream)
(format stream "~S has no debug-variable information."
(no-debug-variables-debug-function condition)))))
(define-condition lambda-list-unavailable (debug-condition) (define-condition lambda-list-unavailable (debug-condition)
(debug-function) (debug-function)
(:documentation (:documentation
...@@ -125,6 +135,21 @@ ...@@ -125,6 +135,21 @@
(format stream "~S has no lambda-list information available." (format stream "~S has no lambda-list information available."
(lambda-list-unavailable-debug-function condition))))) (lambda-list-unavailable-debug-function condition)))))
(define-condition invalid-value (debug-condition)
((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)))))
(define-condition ambiguous-variable-name (debug-condition)
((name)
(frame))
(:report (lambda (condition stream)
(format stream "~S names more than one valid variable in ~S."
(ambiguous-variable-name-name condition)
(ambiguous-variable-name-frame condition)))))
;;;; Errors and DEBUG-SIGNAL. ;;;; Errors and DEBUG-SIGNAL.
...@@ -168,13 +193,16 @@ ...@@ -168,13 +193,16 @@
(unknown-debug-variable-debug-variable condition) (unknown-debug-variable-debug-variable condition)
(unknown-debug-variable-debug-function condition))))) (unknown-debug-variable-debug-function condition)))))
(define-condition invalid-value (debug-error) (define-condition frame-function-mismatch (debug-error)
((debug-variable) ((code-location)
(frame)) (frame)
(form))
(:report (lambda (condition stream) (:report (lambda (condition stream)
(format stream "~S has :invalid or :unknown value in ~S." (format stream
(invalid-value-debug-variable condition) "Form was preprocessed for ~S,~% but called on ~S:~% ~S"
(invalid-value-frame condition))))) (frame-function-mismatch-code-location condition)
(frame-function-mismatch-frame condition)
(frame-function-mismatch-form condition)))))
;;; DEBUG-SIGNAL -- Internal. ;;; DEBUG-SIGNAL -- Internal.
...@@ -206,10 +234,7 @@ ...@@ -206,10 +234,7 @@
;;; These exist for caching data stored in packed binary form in compiler ;;; These exist for caching data stored in packed binary form in compiler
;;; debug-functions. Debug-functions store these. ;;; debug-functions. Debug-functions store these.
;;; ;;;
(defstruct (debug-variable (:print-function print-debug-variable) (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. ;; String name of variable.
(name nil :type simple-string) (name nil :type simple-string)
...@@ -222,17 +247,11 @@ ...@@ -222,17 +247,11 @@
(id 0 :type c::index) (id 0 :type c::index)
;; ;;
;; Whether the variable always has a valid value. ;; Whether the variable always has a valid value.
(alive-p nil :type c::boolean) (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) (defun print-debug-variable (obj str n)
(declare (ignore n)) (declare (ignore n))
(format str "#<Debug-variable ~A:~A:~A>" (format str "#<Debug-Variable ~A:~A:~A>"
(debug-variable-package obj) (debug-variable-package obj)
(debug-variable-name obj) (debug-variable-name obj)
(debug-variable-id obj))) (debug-variable-id obj)))
...@@ -249,16 +268,34 @@ ...@@ -249,16 +268,34 @@
"Returns the integer that makes debug-variable's name and package name unique "Returns the integer that makes debug-variable's name and package name unique
with respect to other debug-variable's in the same function.") with respect to other debug-variable's in the same function.")
(defstruct (compiled-debug-variable
(:include debug-variable)
(:constructor make-compiled-debug-variable
(name package id alive-p sc-offset save-sc-offset)))
;;
;; Storage class and offset. (unexported).
(sc-offset nil :type c::sc-offset)
;;
;; Storage class and offset when saved somewhere.
(save-sc-offset nil :type (or c::sc-offset null)))
(defstruct (interpreted-debug-variable
(:include debug-variable
(alive-p t))
(:constructor make-interpreted-debug-variable
(name package ir1-var)))
;;
;; This is the IR1 structure that holds information about interpreted vars.
(ir1-var nil :type c::lambda-var))
;;; ;;;
;;; Frames ;;; Frames
;;; ;;;
;;; These represents call-frames on the stack. ;;; These represents call-frames on the stack.
;;; ;;;
(defstruct (frame (:print-function print-frame) (defstruct frame
(:constructor make-frame
(pointer up debug-function code-location number
&optional escaped)))
;; ;;
;; Next frame up. Null when top frame. ;; Next frame up. Null when top frame.
(up nil :type (or frame null)) (up nil :type (or frame null))
...@@ -279,21 +316,12 @@ ...@@ -279,21 +316,12 @@
(%catches :unparsed :type (or list (member :unparsed))) (%catches :unparsed :type (or list (member :unparsed)))
;; ;;
;; Pointer to frame on control stack. (unexported) ;; Pointer to frame on control stack. (unexported)
;; When is an interpreted-frame, this is an index into the interpreter's stack.
pointer 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. ;; This is the frame's number for prompt printing. Top is zero.
number) 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) (setf (documentation 'frame-up 'function)
"Returns the frame immediately above frame on the stack. When frame is "Returns the frame immediately above frame on the stack. When frame is
the top of the stack, this returns nil.") the top of the stack, this returns nil.")
...@@ -306,6 +334,43 @@ ...@@ -306,6 +334,43 @@
running when program execution returns to this frame. If someone running when program execution returns to this frame. If someone
interrupted this frame, the result could be an unknown code-location.") interrupted this frame, the result could be an unknown code-location.")
(defstruct (compiled-frame
(:include frame)
(:print-function print-compiled-frame)
(:constructor make-compiled-frame
(pointer up debug-function code-location number
&optional escaped)))
;;
;; Indicates whether someone interrupted frame. (unexported).
;; If escaped, this is a pointer to the escape frame on the control stack.
escaped)
(defun print-compiled-frame (obj str n)
(declare (ignore n))
(format str "#<Compiled-Frame ~S~:[~;, interrupted~]>"
(debug-function-name (frame-debug-function obj))
(compiled-frame-escaped obj)))
(defstruct (interpreted-frame
(:include frame)
(:print-function print-interpreted-frame)
(:constructor make-interpreted-frame
(pointer up debug-function code-location number
real-frame closure)))
;;
;; This points to the compiled-frame for EVAL:INTERNAL-APPLY-LOOP.
(real-frame nil :type compiled-frame)
;;
;; This is the closed over data used by the interpreter.
(closure nil :type simple-vector))
(defun print-interpreted-frame (obj str n)
(declare (ignore n))
(format str "#<Interpreted-Frame ~S>"
(debug-function-name (frame-debug-function obj))))
;;; ;;;
;;; Debug-functions ;;; Debug-functions
;;; ;;;
...@@ -324,11 +389,11 @@ ...@@ -324,11 +389,11 @@
;; NOTE: must parse vars before parsing arg list stuff. ;; NOTE: must parse vars before parsing arg list stuff.
(%lambda-list :unparsed) (%lambda-list :unparsed)
;; ;;
;; Cached Debug-variable information. (unexported). ;; Cached debug-variable information. (unexported).
;; These are sorted by their name. ;; These are sorted by their name.
(debug-vars :unparsed :type (or simple-vector null (member :unparsed))) (debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
;; ;;
;; Cached Debug-block information. This is nil when we have tried to parse ;; Cached debug-block information. This is nil when we have tried to parse
;; the packed binary info, but none is available. ;; the packed binary info, but none is available.
(blocks :unparsed :type (or simple-vector null (member :unparsed))) (blocks :unparsed :type (or simple-vector null (member :unparsed)))
;; ;;
...@@ -337,7 +402,11 @@ ...@@ -337,7 +402,11 @@
(defun print-debug-function (obj str n) (defun print-debug-function (obj str n)
(declare (ignore n)) (declare (ignore n))
(format str "#<Debug-function ~S>" (debug-function-name obj))) (format str "#<~A-Debug-Function ~S>"
(etypecase obj
(compiled-debug-function "Compiled")
(interpreted-debug-function "Interpreted"))
(debug-function-name obj)))
(defstruct (compiled-debug-function (defstruct (compiled-debug-function
...@@ -370,7 +439,20 @@ ...@@ -370,7 +439,20 @@
(%make-compiled-debug-function compiler-debug-fun component)))) (%make-compiled-debug-function compiler-debug-fun component))))
(defstruct (interpreted-debug-function (:include debug-function))) (defstruct (interpreted-debug-function
(:include debug-function)
(:constructor %make-interpreted-debug-function (ir1-lambda)))
;;
;; This is the ir1 lambda this debug-function represents.
(ir1-lambda nil :type c::clambda))
(defvar *ir1-lambda-debug-function* (make-hash-table :test #'eq))
(defun make-interpreted-debug-function (ir1-lambda)
(let ((home-lambda (c::lambda-home ir1-lambda)))
(or (gethash home-lambda *ir1-lambda-debug-function*)
(setf (gethash home-lambda *ir1-lambda-debug-function*)
(%make-interpreted-debug-function home-lambda)))))
;;; ;;;
;;; Debug-blocks. ;;; Debug-blocks.
...@@ -379,25 +461,24 @@ ...@@ -379,25 +461,24 @@
;;; These exist for caching data stored in packed binary form in compiler ;;; These exist for caching data stored in packed binary form in compiler
;;; debug-blocks. ;;; debug-blocks.
;;; ;;;
(defstruct (debug-block (:print-function print-debug-block) (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. ;; Code-locations where execution continues after this block.
(successors nil :type list) (successors nil :type list)
;; ;;
;; This notes the block as a special glob of code shared by various functions ;; This indicates whether the block is a special glob of code shared by
;; and tucked away elsewhere in a component. This kind of block has not ;; various functions and tucked away elsewhere in a component. This kind of
;; start code-location. ;; block has no start code-location. In an interpreted-debug-block, this is
;; always nil. This slot is in all debug-blocks since it is an exported
;; interface.
(elsewhere-p nil :type c::boolean)) (elsewhere-p nil :type c::boolean))
(defun print-debug-block (obj str n) (defun print-debug-block (obj str n)
(declare (ignore n)) (declare (ignore n))
(format str "#<Debug-block ~S>" (format str "#<~A-Debug-Block ~S>"
;; Fix up, for now assuming always have a code-location in 0. (etypecase obj
(compiled-debug-block "Compiled")
(interpreted-debug-block "Interpreted"))
(debug-block-function-name obj))) (debug-block-function-name obj)))
(setf (documentation 'debug-block-successors 'function) (setf (documentation 'debug-block-successors 'function)
...@@ -407,6 +488,62 @@ ...@@ -407,6 +488,62 @@
(setf (documentation 'debug-block-elsewhere-p 'function) (setf (documentation 'debug-block-elsewhere-p 'function)
"Returns whether debug-block represents elsewhere code.") "Returns whether debug-block represents elsewhere code.")
(defstruct (compiled-debug-block (:include debug-block)
(:constructor
make-compiled-debug-block
(code-locations successors elsewhere-p)))
;;
;; Code-location information for the block.
(code-locations nil :type simple-vector))
(defstruct (interpreted-debug-block (:include debug-block
(elsewhere-p nil))
(:constructor %make-interpreted-debug-block
(ir1-block)))
;;
;; This is the IR1 block this debug-block represents.
(ir1-block nil :type c::cblock)
;;
;; Code-location information for the block.
(locations :unparsed :type (or (member :unparsed) simple-vector)))
(defvar *ir1-block-debug-block* (make-hash-table :test #'eq))
;;; MAKE-INTERPRETED-DEBUG-BLOCK -- Internal.
;;;
;;; This makes a debug-block for the interpreter's ir1-block. If we have it in
;;; the cache, return it. If we need to make it, then first make debug-blocks
;;; for all the ir1-blocks in ir1-block's home lambda; this makes sure all the
;;; successors of ir1-block have debug-blocks. We need this to fill in the
;;; resulting debug-block's successors list with debug-blocks, not ir1-blocks.
;;; After making all the possible debug-blocks we'll need to reference, go back
;;; over the list of new debug-blocks and fill in their successor slots with
;;; lists of debug-blocks. Then look up our argument ir1-block to find its
;;; debug-block since we know we have it now.
;;;
(defun make-interpreted-debug-block (ir1-block)
(check-type ir1-block c::cblock)
(let ((res (gethash ir1-block *ir1-block-debug-block*)))
(or res
(let ((lambda (c::block-home-lambda ir1-block)))
(c::do-blocks (block (c::block-component ir1-block))
(when (eq lambda (c::block-home-lambda block))
(push (setf (gethash block *ir1-block-debug-block*)
(%make-interpreted-debug-block block))
res)))
(dolist (block res)
(let ((successors nil))
(dolist (succ (c::block-succ
(interpreted-debug-block-ir1-block block)))
(let ((dblock (gethash succ *ir1-block-debug-block*)))
(unless dblock
(error "Block ~S has successor ~S in different lambda."
(interpreted-debug-block-ir1-block block) succ))
(push dblock successors)))
(setf (debug-block-successors block) (nreverse successors))))
(gethash ir1-block *ir1-block-debug-block*)))))
;;; ;;;
;;; Breakpoints. ;;; Breakpoints.
;;; ;;;
...@@ -434,17 +571,7 @@ ...@@ -434,17 +571,7 @@
;;; Code-locations. ;;; Code-locations.
;;; ;;;
(defstruct (code-location (:print-function print-code-location) (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. ;; This is the debug-function containing code-location.
(debug-function nil :type debug-function) (debug-function nil :type debug-function)
...@@ -469,22 +596,15 @@ ...@@ -469,22 +596,15 @@
;; ;;
;; This is the depth-first number of the node that begins code-location ;; This is the depth-first number of the node that begins code-location
;; within its top-level form. ;; within its top-level form.
(%form-number :unparsed :type (or c::index (member :unparsed))) (%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) (defun print-code-location (obj str n)
(declare (ignore n)) (declare (ignore n))
(format str "#<~A ~S>" (format str "#<~A ~S>"
(ecase (code-location-unknown-p obj) (ecase (code-location-unknown-p obj)
((nil) "Code-Location") ((nil) (etypecase obj
(compiled-code-location "Compiled-Code-Location")
(interpreted-code-location "Interpreted-Code-Location")))
((t) "Unknown-Code-Location")) ((t) "Unknown-Code-Location"))
(debug-function-name (code-location-debug-function obj)))) (debug-function-name (code-location-debug-function obj))))
...@@ -492,6 +612,39 @@ ...@@ -492,6 +612,39 @@
"Returns the debug-function representing information about the function "Returns the debug-function representing information about the function
corresponding to the code-location.") corresponding to the code-location.")
(defstruct (compiled-code-location
(:include code-location)
(:constructor make-compiled-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 :unsure))))
;;
;; This is an index into debug-function's component slot.
(pc nil :type c::index)
;;
;; This is a bit-vector indexed by a variable's position in
;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a valid
;; value at this code-location. (unexported).
(%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
;;
;; (unexported)
(kind :unparsed :type (member :unparsed :unknown-return :known-return
:internal-error :non-local-exit :block-start)))
(defstruct (interpreted-code-location
(:include code-location
(%unknown-p nil))
(:constructor make-interpreted-code-location
(ir1-node debug-function)))
;;
;; This is an index into debug-function's component slot.
(ir1-node nil :type c::node))
;;; ;;;
;;; Debug-sources ;;; Debug-sources
;;; ;;;
...@@ -528,21 +681,14 @@ ...@@ -528,21 +681,14 @@
"Returns the time someone compiled the source. This is nil if the source "Returns the time someone compiled the source. This is nil if the source
is uncompiled.") is uncompiled.")
(setf (documentation 'c::debug-source-start-positions 'function)
"This function returns the file position of each top-level form as an array
if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp or :stream,
this returns nil.")
(setf (documentation 'c::debug-source-p 'function) (setf (documentation 'c::debug-source-p 'function)
"Returns whether object is a debug-source.") "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. ;;;; Frames.
...@@ -585,28 +731,81 @@ ...@@ -585,28 +731,81 @@
(defsetf stack-ref %set-stack-ref) (defsetf stack-ref %set-stack-ref)
;;; 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. ;;; TOP-FRAME -- Public.
;;; ;;;
(defun top-frame () (defun top-frame ()
"Returns the top frame of the control stack as it was before calling this "Returns the top frame of the control stack as it was before calling this
function." function."
(compute-calling-frame (system:%primitive current-fp) nil)) (possibly-an-interpreted-frame
(compute-calling-frame (system:%primitive current-fp) nil)
nil))
;;; FRAME-DOWN -- Public.
;;;
(defun frame-down (frame) (defun frame-down (frame)
"Returns the frame immediately below frame on the stack. When frame is "Returns the frame immediately below frame on the stack. When frame is
the bottom of the stack, this returns nil." the bottom of the stack, this returns nil."
(let ((down (frame-%down frame))) (let ((down (frame-%down frame)))
(if (eq down :unparsed) (if (eq down :unparsed)
(setf (frame-%down frame) (setf (frame-%down frame)
(compute-calling-frame (frame-pointer frame) frame)) (possibly-an-interpreted-frame
(etypecase frame
(compiled-frame
(compute-calling-frame (frame-pointer frame) frame))
(interpreted-frame
(compute-calling-frame
(frame-pointer (interpreted-frame-real-frame frame))
frame)))
frame))
down))) down)))
(defvar *debugging-interpreter* nil
"When set, the debugger foregoes making interpreted-frames, so you can
debug the functions that manifest the interpreter.")
;;; POSSIBLY-AN-INTERPRETED-FRAME -- Internal.
;;;
;;; This takes a newly computed frame, frame, and the frame above it on the
;;; stack, up-frame, which is possibly nil. Frame is nil when we hit the
;;; bottom of the control stack. When frame represents a call to
;;; EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame to replace frame.
;;; The interpreted frame points to frame.
;;;
(defun possibly-an-interpreted-frame (frame up-frame)
(if (or (not frame)
(not (eq (debug-function-name (frame-debug-function frame))
'eval::internal-apply-loop))
*debugging-interpreter*
(compiled-frame-escaped frame))
frame
(flet ((get-var (name location)
(let ((vars (di:ambiguous-debug-variables
(di:frame-debug-function frame) name)))
(when (or (null vars) (> (length vars) 1))
(error "Zero or more than one ~A variable in ~
EVAL::INTERNAL-APPLY-LOOP?"
(string-downcase name)))
(if (eq (debug-variable-validity (car vars) location)
:valid)
(car vars)))))
(let* ((code-loc (frame-code-location frame))
(ptr-var (get-var "FRAME-PTR" code-loc))
(node-var (get-var "NODE" code-loc))
(closure-var (get-var "CLOSURE" code-loc)))
(if (and ptr-var node-var closure-var)
(let* ((node (debug-variable-value node-var frame))
(d-fun (make-interpreted-debug-function
(c::block-home-lambda (c::node-block node)))))
(make-interpreted-frame
(debug-variable-value ptr-var frame)
up-frame
d-fun
(make-interpreted-code-location node d-fun)
(frame-number frame)
frame
(debug-variable-value closure-var frame)))
frame)))))
;;; COMPUTE-CALLING-FRAME -- Internal. ;;; COMPUTE-CALLING-FRAME -- Internal.
;;; ;;;
;;; This returns a frame for the one existing in time immediately prior to the ;;; This returns a frame for the one existing in time immediately prior to the
...@@ -625,33 +824,28 @@ ...@@ -625,33 +824,28 @@
(return-from compute-calling-frame nil)) (return-from compute-calling-frame nil))
(multiple-value-bind (env env-fp escaped) (multiple-value-bind (env env-fp escaped)
(fp-env caller current-fp) (fp-env caller current-fp)
(cond (escaped (if escaped
;; If env-fp is escaped, then caller is the escape frame. ;; If env-fp is escaped, then caller is the escape frame.
(multiple-value-bind (multiple-value-bind
(env pc) (env pc)
(pc-offset (escape-register caller c::return-pc-offset) (pc-offset (escape-register caller c::return-pc-offset)
env up-frame) env up-frame)
(let ((d-fun (debug-function-from-pc env pc))) (let ((d-fun (debug-function-from-pc env pc)))
(make-frame env-fp up-frame d-fun (make-compiled-frame env-fp up-frame d-fun
(code-location-from-pc d-fun pc) (code-location-from-pc d-fun pc escaped)
(if up-frame (1+ (frame-number up-frame)) 0) (if up-frame (1+ (frame-number up-frame)) 0)
escaped)))) escaped)))
#|((member (system:%primitive header-ref env (multiple-value-bind
system:%function-name-slot) (env pc)
interpreter-function-names) (pc-offset (stack-ref current-fp c::return-pc-save-offset)
;; Just print calls within the interpreter as ... uh ... real calls env up-frame)
;; for now (let ((d-fun (debug-function-from-pc env pc)))
)|# ;; env-fp = caller.
(t (make-compiled-frame env-fp up-frame d-fun
(multiple-value-bind (code-location-from-pc d-fun pc escaped)
(env pc) (if up-frame
(pc-offset (stack-ref current-fp c::return-pc-save-offset) (1+ (frame-number up-frame))
env up-frame) 0))))))))
(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. ;;; PC-OFFSET -- Internal.
;;; ;;;
...@@ -826,6 +1020,7 @@ ...@@ -826,6 +1020,7 @@
(#.system:%function-constants-subtype (#.system:%function-constants-subtype
fun))) fun)))
;;; CODE-LOCATION-FROM-PC -- Internal. ;;; CODE-LOCATION-FROM-PC -- Internal.
;;; ;;;
;;; This returns a code-location for the compiled-debug-function, debug-fun, ;;; This returns a code-location for the compiled-debug-function, debug-fun,
...@@ -833,26 +1028,32 @@ ...@@ -833,26 +1028,32 @@
;;; the code-location is known by making a default one. It may later prove ;;; the code-location is known by making a default one. It may later prove
;;; to be unknown as :unparsed slots are accessed. ;;; to be unknown as :unparsed slots are accessed.
;;; ;;;
(defun code-location-from-pc (debug-fun pc) (defun code-location-from-pc (debug-fun pc escaped)
;; For now, and this might be right: ;; For now, and this might be right:
(if (c::compiled-debug-function-blocks (if (and (c::compiled-debug-function-blocks
(compiled-debug-function-compiler-debug-fun (compiled-debug-function-compiler-debug-fun debug-fun))
debug-fun)) (not escaped))
(make-code-location pc debug-fun) (make-compiled-code-location pc debug-fun)
(make-unknown-code-location pc debug-fun))) (make-unknown-code-location pc debug-fun)))
;;; FRAME-CATCHES -- Public.
;;;
(defun frame-catches (frame) (defun frame-catches (frame)
"Returns an a-list mapping catch tags to code-locations. These are "Returns an a-list mapping catch tags to code-locations. These are
code-locations at which execution would continue with frame as the top code-locations at which execution would continue with frame as the top
frame if someone threw to the corresponding tag." frame if someone threw to the corresponding tag."
(let ((catch (system:%primitive active-catch-frame)) (let ((catch (system:%primitive active-catch-frame))
(res nil) (res nil)
(fp (frame-pointer frame))) (fp (etypecase frame
(compiled-frame (frame-pointer frame))
(interpreted-frame (frame-pointer
(interpreted-frame-real-frame frame))))))
(loop (loop
(when (eql catch 0) (return (nreverse res))) (when (eql catch 0) (return (nreverse res)))
(when (eq fp (stack-ref catch system:%unwind-block-current-fp)) (when (eq fp (stack-ref catch system:%unwind-block-current-fp))
(push (cons (stack-ref catch system:%catch-block-tag) (push (cons (stack-ref catch system:%catch-block-tag)
(make-code-location (make-compiled-code-location
(- (stack-ref catch system:%unwind-block-entry-pc) (- (stack-ref catch system:%unwind-block-entry-pc)
clc::i-vector-header-size) clc::i-vector-header-size)
(frame-debug-function frame))) (frame-debug-function frame)))
...@@ -910,10 +1111,14 @@ ...@@ -910,10 +1111,14 @@
(compiled-debug-function (compiled-debug-function
(setf (debug-function-%function debug-function) nil)) (setf (debug-function-%function debug-function) nil))
(interpreted-debug-function (interpreted-debug-function
(error "Can't currently debug interpreted functions.")))) (c::lambda-eval-info-function
(c::leaf-info (interpreted-debug-function-ir1-lambda debug-function))))))
;;; DEBUG-FUNCTION-NAME -- Public. ;;; DEBUG-FUNCTION-NAME -- Public.
;;; ;;;
;;; NOTE: This doesn't cache the name making the the DEBUG-FUNCTION-%FUNCTION
;;; slot useless.
;;;
(defun debug-function-name (debug-function) (defun debug-function-name (debug-function)
"Returns the name of the function represented by debug-function. This may "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." be a string or a cons; do not assume it is a symbol."
...@@ -922,16 +1127,21 @@ ...@@ -922,16 +1127,21 @@
(c::compiled-debug-function-name (c::compiled-debug-function-name
(compiled-debug-function-compiler-debug-fun debug-function))) (compiled-debug-function-compiler-debug-fun debug-function)))
(interpreted-debug-function (interpreted-debug-function
(error "Can't get interpreted-debug-function names now.")))) (c::lambda-name (interpreted-debug-function-ir1-lambda debug-function)))))
;;; FUNCTION-DEBUG-FUNCTION -- Public. ;;; FUNCTION-DEBUG-FUNCTION -- Public.
;;; ;;;
(defun function-debug-function (fun) (defun function-debug-function (fun)
"Returns a debug-function that represents debug information for function." "Returns a debug-function that represents debug information for function."
(debug-function-from-pc (if (eval:interpreted-function-p fun)
fun (let ((eval-fun (eval::get-eval-function fun)))
(- (system:%primitive header-ref fun system:%function-offset-slot) (make-interpreted-debug-function
clc::i-vector-header-size))) (or (eval::eval-function-definition eval-fun)
(eval::convert-eval-fun eval-fun))))
(debug-function-from-pc
fun
(- (system:%primitive header-ref fun system:%function-offset-slot)
clc::i-vector-header-size))))
;;; DEBUG-FUNCTION-KIND -- Public. ;;; DEBUG-FUNCTION-KIND -- Public.
;;; ;;;
...@@ -943,7 +1153,7 @@ ...@@ -943,7 +1153,7 @@
(c::compiled-debug-function-kind (c::compiled-debug-function-kind
(compiled-debug-function-compiler-debug-fun debug-function))) (compiled-debug-function-compiler-debug-fun debug-function)))
(interpreted-debug-function (interpreted-debug-function
(error "We don't debug interpreted functions now.")))) (c::lambda-kind (interpreted-debug-function-ir1-lambda debug-function)))))
;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public. ;;; DEBUG-VARIABLE-INFO-AVAILABLE -- Public.
;;; ;;;
...@@ -1038,22 +1248,96 @@ ...@@ -1038,22 +1248,96 @@
(:keyword keyword-symbol var10) (:keyword keyword-symbol var10)
... ...
) )
Each VARi is a debug-variable." Each VARi is a debug-variable; however it may be the symbol :deleted it
is unreferenced in debug-function. This signals a lambda-list-unavaliable
condition when there is no argument list information."
(etypecase debug-function
(compiled-debug-function
(compiled-debug-function-lambda-list debug-function))
(interpreted-debug-function
(interpreted-debug-function-lambda-list debug-function))))
;;; INTERPRETED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
;;;
;;; The hard part is when the lambda-list is unparsed. If it is unparsed,
;;; and all the arguments are required, this is still pretty easy; just
;;; whip the appropriate debug-variables into a list. Otherwise, we have
;;; to pick out the funny arguments including any suppliedp variables. In
;;; this situation, the ir1-lambda is an external entry point that takes
;;; arguments users really pass in. It looks at those and computes defaults
;;; and suppliedp variables, ultimately passing everything defined as a
;;; a parameter to the real function as final arguments. If this has to
;;; compute the lambda list, it caches it in debug-function.
;;;
(defun interpreted-debug-function-lambda-list (debug-function)
(let ((lambda-list (debug-function-%lambda-list debug-function))
(debug-vars (debug-function-debug-variables debug-function))
(ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))
(res nil))
(if (eq lambda-list :unparsed)
(flet ((frob (v debug-vars)
(if (c::lambda-var-refs v)
(find v debug-vars
:key #'interpreted-debug-variable-ir1-var)
:deleted)))
(let ((xep-args (c::lambda-optional-dispatch ir1-lambda)))
(if (and xep-args
(eq (c::optional-dispatch-main-entry xep-args) ir1-lambda))
;;
;; There are rest, optional, keyword, and suppliedp vars.
(let ((final-args (c::lambda-vars ir1-lambda)))
(dolist (xep-arg (c::optional-dispatch-arglist xep-args))
(let ((info (c::lambda-var-arg-info xep-arg))
(final-arg (pop final-args)))
(cond (info
(case (c::arg-info-kind info)
(:required
(push (frob final-arg debug-vars) res))
(:keyword
(push (list :keyword
(c::arg-info-keyword info)
(frob final-arg debug-vars))
res))
(:rest
(push (list :rest (frob final-arg debug-vars))
res))
(:optional
(push (list :optional
(frob final-arg debug-vars))
res)))
(when (c::arg-info-supplied-p info)
(nconc
(car res)
(list (frob (pop final-args) debug-vars)))))
(t
(push (frob final-arg debug-vars) res)))))
(setf (debug-function-%lambda-list debug-function)
(nreverse res)))
;;
;; All required args, so return them in a list.
(dolist (v (c::lambda-vars ir1-lambda)
(setf (debug-function-%lambda-list debug-function)
(nreverse res)))
(push (frob v debug-vars) res)))))
;;
;; Everything's unparsed and cached, so return it.
lambda-list)))
;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
;;;
;;; If this has to compute the lambda list, it caches it in debug-function.
;;;
(defun compiled-debug-function-lambda-list (debug-function)
(let ((lambda-list (debug-function-%lambda-list debug-function))) (let ((lambda-list (debug-function-%lambda-list debug-function)))
(cond ((eq lambda-list :unparsed) (cond ((eq lambda-list :unparsed)
(etypecase debug-function (multiple-value-bind
(compiled-debug-function (args argsp)
(multiple-value-bind (parse-compiled-debug-function-lambda-list debug-function)
(args argsp) (setf (debug-function-%lambda-list debug-function) args)
(compiled-debug-function-lambda-list debug-function) (if argsp
(setf (debug-function-%lambda-list debug-function) args) args
(if argsp (debug-signal 'lambda-list-unavailable
args :debug-function debug-function))))
(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) (lambda-list)
((c::compiled-debug-function-arguments ((c::compiled-debug-function-arguments
(compiled-debug-function-compiler-debug-fun (compiled-debug-function-compiler-debug-fun
...@@ -1067,15 +1351,15 @@ ...@@ -1067,15 +1351,15 @@
(debug-signal 'lambda-list-unavailable (debug-signal 'lambda-list-unavailable
:debug-function debug-function))))) :debug-function debug-function)))))
;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal. ;;; PARSE-COMPILED-DEBUG-FUNCTION-LAMBDA-LIST -- Internal.
;;; ;;;
;;; DEBUG-FUNCTION-LAMBDA-LIST calls this when a compiled-debug-function has no ;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a
;;; lambda-list information cached. It returns the lambda-list as the first ;;; compiled-debug-function has no lambda-list information cached. It returns
;;; value and whether there was any argument information as the second value. ;;; the lambda-list as the first value and whether there was any argument
;;; Therefore, nil and t means there were no arguments, but nil and nil means ;;; information as the second value. Therefore, nil and t means there were no
;;; there was no argument information. ;;; arguments, but nil and nil means there was no argument information.
;;; ;;;
(defun compiled-debug-function-lambda-list (debug-function) (defun parse-compiled-debug-function-lambda-list (debug-function)
(let ((args (c::compiled-debug-function-arguments (let ((args (c::compiled-debug-function-arguments
(compiled-debug-function-compiler-debug-fun (compiled-debug-function-compiler-debug-fun
debug-function)))) debug-function))))
...@@ -1141,17 +1425,12 @@ ...@@ -1141,17 +1425,12 @@
((eq ele 'c::deleted) :deleted) ((eq ele 'c::deleted) :deleted)
(t (error "Malformed arguments description."))))) (t (error "Malformed arguments description.")))))
;;; DEBUG-FUNCTION-DEBUG-INFO -- Internal Interface. ;;; COMPILED-DEBUG-FUNCTION-DEBUG-INFO -- Internal.
;;; ;;;
(defun debug-function-debug-info (debug-fun) (defun compiled-debug-function-debug-info (debug-fun)
(etypecase debug-fun (system:%primitive header-ref
(compiled-debug-function (compiled-debug-function-component debug-fun)
(system:%primitive header-ref system:%function-constants-debug-info-slot))
(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."))))
...@@ -1202,36 +1481,43 @@ ...@@ -1202,36 +1481,43 @@
) ;eval-when ) ;eval-when
;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal Interface. ;;; DEBUG-FUNCTION-DEBUG-BLOCKS -- Internal.
;;; ;;;
;;; The argument is a debug internals structure. This returns the debug-blocks ;;; The argument is a debug internals structure. This returns the debug-blocks
;;; for debug-function, regardless of whether we have unpacked them yet. It ;;; 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. ;;; signals a no-debug-blocks condition if it can't return the blocks.
;;; ;;;
(defun debug-function-debug-blocks (debug-function) (defun debug-function-debug-blocks (debug-function)
(etypecase debug-function (let ((blocks (debug-function-blocks debug-function)))
(compiled-debug-function (cond ((eq blocks :unparsed)
(let ((blocks (debug-function-blocks debug-function))) (setf (debug-function-blocks debug-function)
(cond ((eq blocks :unparsed) (parse-debug-blocks debug-function))
(setf (debug-function-blocks debug-function) (unless (debug-function-blocks debug-function)
(parse-debug-blocks debug-function)) (debug-signal 'no-debug-blocks
(unless (debug-function-blocks debug-function) :debug-function debug-function))
(debug-signal 'no-debug-blocks (debug-function-blocks debug-function))
:debug-function debug-function)) (blocks)
(debug-function-blocks debug-function)) (t
(blocks) (debug-signal 'no-debug-blocks
(t :debug-function debug-function)))))
(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. ;;; PARSE-DEBUG-BLOCKS -- Internal.
;;; ;;;
;;; Debug-fun is a c::compiled-debug-function. Var-count is how many variables ;;; This returns a simple-vector of debug-blocks or nil. Nil indicates there
;;; the live-set data in packed binary form represents. ;;; was no basic block information.
;;; ;;;
(defun parse-debug-blocks (debug-function) (defun parse-debug-blocks (debug-function)
(etypecase debug-function
(compiled-debug-function
(parse-compiled-debug-blocks debug-function))
(interpreted-debug-block
(parse-interpreted-debug-blocks debug-function))))
;;; PARSE-COMPILED-DEBUG-BLOCKS -- Internal.
;;;
;;; This does some of the work of PARSE-DEBUG-BLOCKS.
;;;
(defun parse-compiled-debug-blocks (debug-function)
(let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
(var-count (length (debug-function-debug-variables debug-function))) (var-count (length (debug-function-debug-variables debug-function)))
(blocks (c::compiled-debug-function-blocks debug-fun)) (blocks (c::compiled-debug-function-blocks debug-fun))
...@@ -1239,7 +1525,7 @@ ...@@ -1239,7 +1525,7 @@
;; the packed binary representation of the blocks data. ;; the packed binary representation of the blocks data.
(live-set-len (ceiling var-count 8)) (live-set-len (ceiling var-count 8))
(tlf-number (c::compiled-debug-function-tlf-number debug-fun))) (tlf-number (c::compiled-debug-function-tlf-number debug-fun)))
(unless blocks (return-from parse-debug-blocks nil)) (unless blocks (return-from parse-compiled-debug-blocks nil))
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i)))) (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(with-parsing-buffer (blocks-buffer locations-buffer) (with-parsing-buffer (blocks-buffer locations-buffer)
(let ((i 0) (let ((i 0)
...@@ -1265,12 +1551,12 @@ ...@@ -1265,12 +1551,12 @@
(form-number (c::read-var-integer blocks i)) (form-number (c::read-var-integer blocks i))
(live-set (c::read-packed-bit-vector (live-set (c::read-packed-bit-vector
live-set-len blocks i))) live-set-len blocks i)))
(vector-push-extend (make-code-location (vector-push-extend (make-compiled-code-location
pc debug-function tlf-offset pc debug-function tlf-offset
form-number live-set kind) form-number live-set kind)
locations-buffer) locations-buffer)
(setf last-pc pc)))) (setf last-pc pc))))
(block (make-debug-block (block (make-compiled-debug-block
locations successors locations successors
(not (zerop (logand (not (zerop (logand
c::compiled-debug-block-elsewhere-p c::compiled-debug-block-elsewhere-p
...@@ -1289,7 +1575,21 @@ ...@@ -1289,7 +1575,21 @@
(setf (debug-block-successors block) succs))) (setf (debug-block-successors block) succs)))
res))))) res)))))
;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal Interface. ;;; PARSE-INTERPRETED-DEBUG-BLOCKS -- Internal.
;;;
;;; This does some of the work of PARSE-DEBUG-BLOCKS.
;;;
(defun parse-interpreted-debug-blocks (debug-function)
(let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)))
(with-parsing-buffer (buffer)
(c::do-blocks (block (c::block-component
(c::node-block (c::lambda-bind ir1-lambda))))
(when (eq ir1-lambda (c::block-home-lambda block))
(vector-push-extend (make-interpreted-debug-block block) buffer)))
(result buffer))))
;;; DEBUG-FUNCTION-DEBUG-VARIABLES -- Internal.
;;; ;;;
;;; The argument is a debug internals structure. This returns nil if there is ;;; The argument is a debug internals structure. This returns nil if there is
;;; no variable information. It returns an empty simple-vector if there were ;;; no variable information. It returns an empty simple-vector if there were
...@@ -1297,31 +1597,80 @@ ...@@ -1297,31 +1597,80 @@
;;; debug-variables. ;;; debug-variables.
;;; ;;;
(defun debug-function-debug-variables (debug-function) (defun debug-function-debug-variables (debug-function)
(etypecase debug-function (let ((vars (debug-function-debug-vars debug-function)))
(compiled-debug-function (if (eq vars :unparsed)
(let ((vars (debug-function-debug-vars debug-function))) (setf (debug-function-debug-vars debug-function)
(if (eq vars :unparsed) (etypecase debug-function
(setf (debug-function-debug-vars debug-function) (compiled-debug-function
(parse-debug-variables debug-function)) (parse-compiled-debug-variables debug-function))
vars))) (interpreted-debug-function
(interpreted-debug-function (parse-interpreted-debug-variables debug-function))))
(error "We don't currently support interpreted-debug-functions.")))) vars)))
;;; PARSE-DEBUG-VARIABLES -- Internal. ;;; PARSE-INTERPRETED-DEBUG-VARIABLES -- Internal.
;;;
;;; This grabs all the variables from debug-fun's ir1-lambda, from the IR1
;;; lambda vars, and all of it's LET's. Each LET is an IR1 lambda. For each
;;; variable, we make an interpreted-debug-variable. We then SORT all the
;;; variables by name. Then we go through, and for any duplicated names we
;;; distinguish the interpreted-debug-variables by setting their id slots to a
;;; distinct number.
;;;
(defun parse-interpreted-debug-variables (debug-fun)
(let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun))
(vars (flet ((frob (ir1-lambda buf)
(dolist (v (c::lambda-vars ir1-lambda))
(vector-push-extend
(let ((id (c::leaf-name v)))
(make-interpreted-debug-variable
(symbol-name id)
(package-name (symbol-package id))
v))
buf))))
(with-parsing-buffer (buf)
(frob ir1-lambda buf)
(dolist (let-lambda (c::lambda-lets ir1-lambda))
(frob let-lambda buf))
(result buf)))))
(declare (simple-vector vars))
(sort vars #'string< :key #'debug-variable-name)
(let ((len (length vars)))
(when (> len 1)
(let ((i 0)
(j 1))
(loop
(let* ((var-i (svref vars i))
(var-j (svref vars j))
(name (debug-variable-name var-i)))
(when (string= name (debug-variable-name var-j))
(let ((count 1))
(loop
(setf (debug-variable-id var-j) count)
(when (= (incf j) len) (return))
(setf var-j (svref vars j))
(when (string/= name (debug-variable-name var-j))
(return))
(incf count))))
(setf i j)
(incf j)
(when (= j len) (return)))))))
vars))
;;; PARSE-COMPILED-DEBUG-VARIABLES -- Internal.
;;; ;;;
;;; This parses the packed binary representation of debug-variables from ;;; This parses the packed binary representation of debug-variables from
;;; debug-function's c::compiled-debug-function. ;;; debug-function's c::compiled-debug-function.
;;; ;;;
(defun parse-debug-variables (debug-function) (defun parse-compiled-debug-variables (debug-function)
(let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function)) (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
(packed-vars (c::compiled-debug-function-variables debug-fun)) (packed-vars (c::compiled-debug-function-variables debug-fun))
(default-package (c::compiled-debug-info-package (default-package (c::compiled-debug-info-package
(debug-function-debug-info debug-function)))) (compiled-debug-function-debug-info debug-function))))
(unless packed-vars (unless packed-vars
(return-from parse-debug-variables nil)) (return-from parse-compiled-debug-variables nil))
(when (zerop (length packed-vars)) (when (zerop (length packed-vars))
;; Return a simple-vector not whatever packed-vars may be. ;; Return a simple-vector not whatever packed-vars may be.
(return-from parse-debug-variables '#())) (return-from parse-compiled-debug-variables '#()))
(let ((i 0) (let ((i 0)
(len (length packed-vars))) (len (length packed-vars)))
(with-parsing-buffer (buffer) (with-parsing-buffer (buffer)
...@@ -1353,7 +1702,7 @@ ...@@ -1353,7 +1702,7 @@
nil nil
(c::read-var-integer packed-vars i)))) (c::read-var-integer packed-vars i))))
(vector-push-extend (vector-push-extend
(make-debug-variable (make-compiled-debug-variable
name package id name package id
(not (zerop (logand c::compiled-debug-variable-environment-live (not (zerop (logand c::compiled-debug-variable-environment-live
flags))) flags)))
...@@ -1389,84 +1738,100 @@ ...@@ -1389,84 +1738,100 @@
;;; CODE-LOCATION-DEBUG-BLOCK -- Public. ;;; 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) (defun code-location-debug-block (basic-code-location)
"Returns the debug-block containing code-location if it is available. Some "Returns the debug-block containing code-location if it is available. Some
debug policies inhibit debug-block information, and if none is available, debug policies inhibit debug-block information, and if none is available,
then this signals a no-debug-blocks condition." then this signals a no-debug-blocks condition."
(let ((block (code-location-%debug-block basic-code-location))) (let ((block (code-location-%debug-block basic-code-location)))
(if (eq block :unparsed) (if (eq block :unparsed)
(let* ((pc (code-location-pc basic-code-location)) (etypecase basic-code-location
(debug-function (code-location-debug-function (compiled-code-location
basic-code-location)) (compute-compiled-code-location-debug-block basic-code-location))
(blocks (debug-function-debug-blocks debug-function)) (interpreted-code-location
(len (length blocks))) (setf (code-location-%debug-block basic-code-location)
(declare (simple-vector blocks)) (make-interpreted-debug-block
(setf (c::node-block
(code-location-%debug-block basic-code-location) (interpreted-code-location-ir1-node 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))) block)))
;;; COMPUTE-COMPILED-CODE-LOCATION-DEBUG-BLOCK -- Internal.
;;;
;;; This stores and returns basic-code-location's debug-block. It determines
;;; the correct one using the code-location's pc. This uses
;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information or
;;; signal a 'no-debug-blocks condition. The blocks are sorted by their first
;;; code-location's pc, in ascending order. Therefore, as soon as we find a
;;; block that starts with a pc greater than basic-code-location's pc, we know
;;; the previous block contains the pc. If we get to the last block, then the
;;; code-location is either in the second to last block or the last block, and
;;; we have to be careful in determining this since the last block could be
;;; random code at the end of the function. We have to check for the last
;;; block being random code first to see how to compare the code-location's pc.
;;;
(defun compute-compiled-code-location-debug-block (basic-code-location)
(let* ((pc (compiled-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
(compiled-code-location-pc
(svref (compiled-debug-block-code-locations last)
0)))
(svref blocks (1- end)))
(t last))))
(declare (type c::index i end))
(when (< pc
(compiled-code-location-pc
(svref (compiled-debug-block-code-locations
(svref blocks i))
0)))
(return (svref blocks (1- i)))))))))
;;; CODE-LOCATION-DEBUG-SOURCE -- Public. ;;; CODE-LOCATION-DEBUG-SOURCE -- Public.
;;; ;;;
(defun code-location-debug-source (code-location) (defun code-location-debug-source (code-location)
"Returns the code-location's debug-source." "Returns the code-location's debug-source."
(let ((info (debug-function-debug-info (etypecase code-location
(code-location-debug-function code-location)))) (compiled-code-location
(etypecase info (let* ((info (compiled-debug-function-debug-info
(c::compiled-debug-info (code-location-debug-function code-location)))
(let* ((sources (c::compiled-debug-info-source info)) (sources (c::compiled-debug-info-source info))
(len (length sources))) (len (length sources)))
(declare (list sources)) (declare (list sources))
(if (= len 1) (if (= len 1)
(car sources) (car sources)
(do ((prev (car sources) src) (do ((prev sources src)
(src (cdr sources) (cdr src)) (src (cdr sources) (cdr src))
(offset (code-location-top-level-form-offset code-location))) (offset (code-location-top-level-form-offset code-location)))
((null src) (car prev)) ((null src) (car prev))
(when (< offset (c::debug-source-source-root (car src))) (when (< offset (c::debug-source-source-root (car src)))
(car prev)))))) (return (car prev)))))))
(interpreted-debug-info (interpreted-code-location
(error "Can't handle interpreted-debug-infos."))))) (first
(let ((c::*lexical-environment* (c::make-null-environment)))
(c::debug-source-for-info
(c::component-source-info
(c::block-component
(c::node-block
(interpreted-code-location-ir1-node code-location))))))))))
;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public. ;;; CODE-LOCATION-TOP-LEVEL-FORM-OFFSET -- Public.
;;; ;;;
...@@ -1479,11 +1844,18 @@ ...@@ -1479,11 +1844,18 @@
(error 'unknown-code-location :code-location code-location)) (error 'unknown-code-location :code-location code-location))
(let ((tlf-offset (code-location-%tlf-offset code-location))) (let ((tlf-offset (code-location-%tlf-offset code-location)))
(cond ((eq tlf-offset :unparsed) (cond ((eq tlf-offset :unparsed)
(unless (fill-in-code-location code-location) (etypecase code-location
;; This check should be unnecessary. We're missing debug info (compiled-code-location
;; the compiler should have dumped. (unless (fill-in-code-location code-location)
(error "Unknown code location? It should be known.")) ;; This check should be unnecessary. We're missing debug info
(code-location-%tlf-offset code-location)) ;; the compiler should have dumped.
(error "Unknown code location? It should be known."))
(code-location-%tlf-offset code-location))
(interpreted-code-location
(setf (code-location-%tlf-offset code-location)
(c::source-path-tlf-number
(c::node-source-path
(interpreted-code-location-ir1-node code-location)))))))
(t tlf-offset)))) (t tlf-offset))))
;;; CODE-LOCATION-FORM-NUMBER -- Public. ;;; CODE-LOCATION-FORM-NUMBER -- Public.
...@@ -1496,46 +1868,60 @@ ...@@ -1496,46 +1868,60 @@
(error 'unknown-code-location :code-location code-location)) (error 'unknown-code-location :code-location code-location))
(let ((form-num (code-location-%form-number code-location))) (let ((form-num (code-location-%form-number code-location)))
(cond ((eq form-num :unparsed) (cond ((eq form-num :unparsed)
(unless (fill-in-code-location code-location) (etypecase code-location
;; This check should be unnecessary. We're missing debug info (compiled-code-location
;; the compiler should have dumped. (unless (fill-in-code-location code-location)
(error "Unknown code location? It should be known.")) ;; This check should be unnecessary. We're missing debug info
(code-location-%form-number code-location)) ;; the compiler should have dumped.
(error "Unknown code location? It should be known."))
(code-location-%form-number code-location))
(interpreted-code-location
(setf (code-location-%form-number code-location)
(c::source-path-form-number
(c::node-source-path
(interpreted-code-location-ir1-node code-location)))))))
(t form-num)))) (t form-num))))
;;; CODE-LOCATION-LIVE-SET -- Internal Interface. ;;; COMPILED-CODE-LOCATION-LIVE-SET -- Internal.
;;; ;;;
;;; This returns the code-location's live-set if it is available. If there ;;; This returns the code-location's live-set if it is available. If there
;;; is no debug-block information, this returns nil. ;;; is no debug-block information, this returns nil.
;;; ;;;
(defun code-location-live-set (code-location) (defun compiled-code-location-live-set (code-location)
(if (code-location-unknown-p code-location) (if (code-location-unknown-p code-location)
nil nil
(let ((live-set (code-location-%live-set code-location))) (let ((live-set (compiled-code-location-%live-set code-location)))
(cond ((eq live-set :unparsed) (cond ((eq live-set :unparsed)
(unless (fill-in-code-location code-location) (unless (fill-in-code-location code-location)
;; This check should be unnecessary. We're missing debug info ;; This check should be unnecessary. We're missing debug info
;; the compiler should have dumped. ;; the compiler should have dumped.
(error "Unknown code location? It should be known.")) (error "Unknown code location? It should be known."))
(code-location-%live-set code-location)) (compiled-code-location-%live-set code-location))
(t live-set))))) (t live-set)))))
;;; CODE-LOCATION= -- Public. ;;; CODE-LOCATION= -- Public.
;;; ;;;
(defun code-location= (obj1 obj2) (defun code-location= (obj1 obj2)
"Returns whether obj1 and obj2 are the same place in the code." "Returns whether obj1 and obj2 are the same place in the code."
(let ((d-fun1 (code-location-debug-function obj1)) (etypecase obj1
(d-fun2 (code-location-debug-function obj2))) (compiled-code-location
(and (eq d-fun1 d-fun2) (etypecase obj2
(sub-code-location= d-fun1 obj1 obj2)))) (compiled-code-location
(and (eq (code-location-debug-function obj1)
(defun sub-code-location= (d-fun1 obj1 obj2) (code-location-debug-function obj2))
(etypecase d-fun1 (sub-compiled-code-location= obj1 obj2)))
(compiled-debug-function (interpreted-code-location
(= (code-location-pc obj1) (code-location-pc obj2))) nil)))
(interpreted-debug-function (interpreted-code-location
;; ??? compare IR1 nodes? (etypecase obj2
(error "Cannot compare interpreted-debug-functions currently.")))) (compiled-code-location
nil)
(interpreted-code-location
(eq (interpreted-code-location-ir1-node obj1)
(interpreted-code-location-ir1-node obj2)))))))
;;;
(defun sub-compiled-code-location= (obj1 obj2)
(= (compiled-code-location-pc obj1) (compiled-code-location-pc obj2)))
;;; FILL-IN-CODE-LOCATION -- Internal. ;;; FILL-IN-CODE-LOCATION -- Internal.
;;; ;;;
...@@ -1551,20 +1937,20 @@ ...@@ -1551,20 +1937,20 @@
(declare (simple-vector blocks)) (declare (simple-vector blocks))
(dotimes (i (length blocks) nil) (dotimes (i (length blocks) nil)
(let* ((block (svref blocks i)) (let* ((block (svref blocks i))
(locations (debug-block-code-locations block))) (locations (compiled-debug-block-code-locations block)))
(declare (simple-vector locations)) (declare (simple-vector locations))
(dotimes (j (length locations)) (dotimes (j (length locations))
(let ((loc (svref locations j))) (let ((loc (svref locations j)))
(when (sub-code-location= debug-function code-location loc) (when (sub-compiled-code-location= code-location loc)
(setf (code-location-%debug-block code-location) block) (setf (code-location-%debug-block code-location) block)
(setf (code-location-%tlf-offset code-location) (setf (code-location-%tlf-offset code-location)
(code-location-%tlf-offset loc)) (code-location-%tlf-offset loc))
(setf (code-location-%form-number code-location) (setf (code-location-%form-number code-location)
(code-location-%form-number loc)) (code-location-%form-number loc))
(setf (code-location-%live-set code-location) (setf (compiled-code-location-%live-set code-location)
(code-location-%live-set loc)) (compiled-code-location-%live-set loc))
(setf (code-location-kind code-location) (setf (compiled-code-location-kind code-location)
(code-location-kind loc)) (compiled-code-location-kind loc))
(return-from fill-in-code-location t)))))))) (return-from fill-in-code-location t))))))))
...@@ -1590,11 +1976,44 @@ ...@@ -1590,11 +1976,44 @@
(defun debug-block-function-name (debug-block) (defun debug-block-function-name (debug-block)
"Returns the name of the function represented by debug-function. This may "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." be a string or a cons; do not assume it is a symbol."
(let ((code-locs (debug-block-code-locations debug-block))) (etypecase debug-block
(declare (simple-vector code-locs)) (compiled-debug-block
(when (zerop (length code-locs)) (let ((code-locs (compiled-debug-block-code-locations debug-block)))
(error "No code-locations in debug-block? -- ~S." debug-block)) (declare (simple-vector code-locs))
(debug-function-name (code-location-debug-function (svref code-locs 0))))) (if (zerop (length code-locs))
"??? Can't get name of debug-block's function."
(debug-function-name
(code-location-debug-function (svref code-locs 0))))))
(interpreted-debug-block
(c::lambda-name (c::block-home-lambda
(interpreted-debug-block-ir1-block debug-block))))))
;;; DEBUG-BLOCK-CODE-LOCATIONS -- Internal.
;;;
(defun debug-block-code-locations (debug-block)
(etypecase debug-block
(compiled-debug-block
(compiled-debug-block-code-locations debug-block))
(interpreted-debug-block
(interpreted-debug-block-code-locations debug-block))))
;;; INTERPRETED-DEBUG-BLOCK-CODE-LOCATIONS -- Internal.
;;;
(defun interpreted-debug-block-code-locations (debug-block)
(let ((code-locs (interpreted-debug-block-locations debug-block)))
(if (eq code-locs :unparsed)
(with-parsing-buffer (buf)
(c::do-nodes (node cont (interpreted-debug-block-ir1-block
debug-block))
(vector-push-extend (make-interpreted-code-location
node
(make-interpreted-debug-function
(c::block-home-lambda (c::node-block node))))
buf))
(setf (interpreted-debug-block-locations debug-block)
(result buf)))
code-locs)))
...@@ -1625,24 +2044,43 @@ ...@@ -1625,24 +2044,43 @@
(defun debug-variable-value (debug-var frame) (defun debug-variable-value (debug-var frame)
"Returns the value stored for debug-variable in frame. The value may be "Returns the value stored for debug-variable in frame. The value may be
invalid." invalid."
(let ((res (access-debug-var-slot debug-var frame))) (etypecase debug-var
(if (indirect-value-cell-p res) (compiled-debug-variable
(system:%primitive header-ref res (check-type frame compiled-frame)
system:%function-value-cell-value-slot) (let ((res (access-compiled-debug-var-slot debug-var frame)))
res))) (if (indirect-value-cell-p res)
(system:%primitive header-ref res
(defun access-debug-var-slot (debug-var frame) system:%function-value-cell-value-slot)
(let ((escaped (frame-escaped frame))) res)))
(interpreted-debug-variable
(check-type frame interpreted-frame)
(eval::leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-variable-ir1-var debug-var)
(frame-pointer frame)
(interpreted-frame-closure frame)))))
;;; ACCESS-COMPILED-DEBUG-VAR-SLOT -- Internal.
;;;
;;; This returns what is stored for the variable represented by debug-var
;;; relative to the frame. This may be an indirect value cell if the
;;; variable is both closed over and set.
;;;
(defun access-compiled-debug-var-slot (debug-var frame)
(let ((escaped (compiled-frame-escaped frame)))
(if escaped (if escaped
(sub-access-debug-var-slot (sub-access-debug-var-slot
(frame-pointer frame) (frame-pointer frame)
(debug-variable-sc-offset debug-var) (compiled-debug-variable-sc-offset debug-var)
escaped) escaped)
(sub-access-debug-var-slot (sub-access-debug-var-slot
(frame-pointer frame) (frame-pointer frame)
(or (debug-variable-save-sc-offset debug-var) (or (compiled-debug-variable-save-sc-offset debug-var)
(debug-variable-sc-offset debug-var)))))) (compiled-debug-variable-sc-offset debug-var))))))
;;; SUB-ACCESS-DEBUG-VAR-SLOT -- Internal.
;;;
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(ecase (c::sc-offset-scn sc-offset) (ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register. ((0 1) ;; Any register or descriptor register.
...@@ -1662,27 +2100,58 @@ ...@@ -1662,27 +2100,58 @@
(5 ;; String-chars on the stack (w/o tag bits). (5 ;; String-chars on the stack (w/o tag bits).
(code-char (stack-ref fp (c::sc-offset-offset sc-offset)))))) (code-char (stack-ref fp (c::sc-offset-offset sc-offset))))))
;;; %SET-DEBUG-VARIABLE-VALUE -- Internal.
;;;
;;; This stores value as the value of debug-var in frame. In the
;;; compiled-debug-variable case, access the current value to determine if it
;;; is an indirect value cell. This occurs when the variable is both closed
;;; over and set. For interpreted-debug-variables just call
;;; EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter objects.
;;;
(defun %set-debug-variable-value (debug-var frame value) (defun %set-debug-variable-value (debug-var frame value)
(let ((current-value (access-debug-var-slot debug-var frame))) (etypecase debug-var
(if (indirect-value-cell-p current-value) (compiled-debug-variable
(system:%primitive header-set current-value (check-type frame compiled-frame)
system:%function-value-cell-value-slot (let ((current-value (access-compiled-debug-var-slot debug-var frame)))
value) (if (indirect-value-cell-p current-value)
(set-debug-variable-slot debug-var frame value)))) (system:%primitive header-set current-value
system:%function-value-cell-value-slot
(defun set-debug-variable-slot (debug-var frame value) value)
(let ((escaped (frame-escaped frame))) (set-compiled-debug-variable-slot debug-var frame value))))
(interpreted-debug-variable
(check-type frame interpreted-frame)
(eval::set-leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-variable-ir1-var debug-var)
(frame-pointer frame)
(interpreted-frame-closure frame)
value)))
value)
;;;
(defsetf debug-variable-value %set-debug-variable-value)
;;; SET-COMPILED-DEBUG-VARIABLE-SLOT -- Internal.
;;;
;;; This stores value for the variable represented by debug-var relative to the
;;; frame. This assumes the location directly contains the variable's value;
;;; that is, there is no indirect value cell currently there in case the
;;; variable is both closed over and set.
;;;
(defun set-compiled-debug-variable-slot (debug-var frame value)
(let ((escaped (compiled-frame-escaped frame)))
(if escaped (if escaped
(sub-set-debug-var-slot (frame-pointer frame) (sub-set-debug-var-slot (frame-pointer frame)
(debug-variable-sc-offset debug-var) (debug-variable-sc-offset debug-var)
value value escaped)
escaped)
(sub-set-debug-var-slot (sub-set-debug-var-slot
(frame-pointer frame) (frame-pointer frame)
(or (debug-variable-save-sc-offset debug-var) (or (debug-variable-save-sc-offset debug-var)
(debug-variable-sc-offset debug-var)) (debug-variable-sc-offset debug-var))
value)))) value))))
;;; SUB-SET-DEBUG-VAR-SLOT -- Internal.
;;;
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
(ecase (c::sc-offset-scn sc-offset) (ecase (c::sc-offset-scn sc-offset)
((0 1) ;; Any register or descriptor register. ((0 1) ;; Any register or descriptor register.
...@@ -1705,8 +2174,14 @@ ...@@ -1705,8 +2174,14 @@
(5 ;; String-chars on the stack (w/o tag bits). (5 ;; String-chars on the stack (w/o tag bits).
(setf (stack-ref fp (c::sc-offset-offset sc-offset)) (setf (stack-ref fp (c::sc-offset-offset sc-offset))
(char-code value))))) (char-code value)))))
(defsetf debug-variable-value %set-debug-variable-value)
;;; INDIRECT-VALUE-CELL-P -- Internal.
;;;
;;; The method for setting and accessing compiled-debug-variable values use
;;; this to determine if the value stored is the actual value or an indirection
;;; cell.
;;;
(defun indirect-value-cell-p (x) (defun indirect-value-cell-p (x)
(and (functionp x) (and (functionp x)
(eql (system:%primitive get-vector-subtype x) (eql (system:%primitive get-vector-subtype x)
...@@ -1726,17 +2201,32 @@ ...@@ -1726,17 +2201,32 @@
:valid The value is known to be available. :valid The value is known to be available.
:invalid The value is known to be unavailable. :invalid The value is known to be unavailable.
:unknown The value's availability is unknown." :unknown The value's availability is unknown."
(etypecase debug-var
(compiled-debug-variable
(compiled-debug-variable-validity debug-var basic-code-loc))
(interpreted-debug-variable
(check-type basic-code-loc interpreted-code-location)
(let ((validp (rassoc (interpreted-debug-variable-ir1-var debug-var)
(c::lexenv-variables
(c::node-lexenv
(interpreted-code-location-ir1-node
basic-code-loc))))))
(if validp :valid :invalid)))))
;;; COMPILED-DEBUG-VARIABLE-VALIDITY -- Internal.
;;;
;;; This is the method for DEBUG-VARIABLE-VALIDITY for compiled-debug-variables.
;;; For safety, make sure basic-code-loc is what we think.
;;;
(defun compiled-debug-variable-validity (debug-var basic-code-loc)
(check-type basic-code-loc compiled-code-location)
(cond ((debug-variable-alive-p debug-var) (cond ((debug-variable-alive-p debug-var)
(let ((debug-fun (code-location-debug-function basic-code-loc))) (let ((debug-fun (code-location-debug-function basic-code-loc)))
(etypecase debug-fun (if (>= (compiled-code-location-pc basic-code-loc)
(compiled-debug-function (c::compiled-debug-function-start-pc
(if (>= (code-location-pc basic-code-loc) (compiled-debug-function-compiler-debug-fun debug-fun)))
(c::compiled-debug-function-start-pc :valid
(compiled-debug-function-compiler-debug-fun debug-fun))) :invalid)))
:valid
:invalid))
(interpreted-debug-function
(error "Don't do interpreted debug-variable validity now.")))))
((code-location-unknown-p basic-code-loc) :unknown) ((code-location-unknown-p basic-code-loc) :unknown)
(t (t
(let ((pos (position debug-var (let ((pos (position debug-var
...@@ -1748,7 +2238,8 @@ ...@@ -1748,7 +2238,8 @@
:debug-function :debug-function
(code-location-debug-function basic-code-loc))) (code-location-debug-function basic-code-loc)))
;; There must be live-set info since basic-code-loc is known. ;; There must be live-set info since basic-code-loc is known.
(if (zerop (sbit (code-location-live-set basic-code-loc) pos)) (if (zerop (sbit (compiled-code-location-live-set basic-code-loc)
pos))
:invalid :invalid
:valid))))) :valid)))))
...@@ -1856,3 +2347,70 @@ ...@@ -1856,3 +2347,70 @@
(nconc (subseq form 0 n) (nconc (subseq form 0 n)
(cons res (nthcdr (1+ n) form))))))) (cons res (nthcdr (1+ n) form)))))))
(frob form path context)))) (frob form path context))))
;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME.
;;; PREPROCESS-FOR-EVAL -- Public.
;;;
;;; Create a SYMBOL-MACRO-LET for each variable valid at the location which
;;; accesses that variable from the frame argument.
;;;
(defun preprocess-for-eval (form loc)
"Return a function of one argument that will evaluate Form in the lexical
context of the Basic-Code-Location Loc. The function take the frame to get
values from as its argument, and returns the values of Form."
(declare (type code-location loc))
(let ((n-frame (gensym))
(fun (code-location-debug-function loc)))
(unless (debug-variable-info-available fun)
(debug-signal 'no-debug-variables :debug-function fun))
(ext:collect ((binds)
(specs))
(do-debug-function-variables (var fun)
(let ((validity (debug-variable-validity var loc)))
(unless (eq validity :invalid)
(let* ((sym (debug-variable-symbol var))
(found (assoc sym (binds))))
(if found
(setf (second found) :ambiguous)
(binds (list sym validity var)))))))
(dolist (bind (binds))
(let ((name (first bind))
(var (third bind)))
(ecase (second bind)
(:valid
(specs `(,name (debug-variable-value ',var ,n-frame))))
(:unknown
(specs `(,name
(debug-signal 'invalid-value
:debug-variable ',var
:frame ,n-frame))))
(:ambiguous
(specs `(,name
(debug-signal 'ambiguous-variable-name
:name ',name
:frame ,n-frame)))))))
(let ((res (coerce `(lambda (,n-frame)
(declare (ext:ignorable ,n-frame))
(symbol-macro-let ,(specs)
,form))
'function)))
#'(lambda (frame)
(unless (code-location= (frame-code-location frame)
loc)
(debug-signal 'frame-function-mismatch
:code-location loc :form form :frame frame))
(funcall res frame))))))
;;; EVAL-IN-FRAME -- Public.
;;;
(defun eval-in-frame (frame form)
(declare (type frame frame))
"Evaluate Form in the lexical context of Frame's current code location,
returning the results of the evaluation."
(funcall (preprocess-for-eval form (frame-code-location frame)) frame))
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