X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=ea6149bdde346fad8c333769331294ff2ea5af2a;hb=95f5ac2fa70b3f14d052e20f4250166f219dcc39;hp=c61ab787849464e83eed6122436de0d38a1b114e;hpb=31361af9eb64344f521abbb245ea784c76c746e5;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index c61ab78..ea6149b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -670,7 +670,7 @@ ;;;; frames -;;; This is used in FIND-ESCAPE-FRAME and with the bogus components +;;; This is used in FIND-ESCAPED-FRAME and with the bogus components ;;; and LRAs used for :function-end breakpoints. When a components ;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the ;;; real component to continue executing, as opposed to the bogus @@ -967,9 +967,10 @@ ;;; to replace FRAME. The interpreted frame points to FRAME. (defun possibly-an-interpreted-frame (frame up-frame) (if (or (not frame) - #!+sb-interpreter - (not (eq (debug-function-name (frame-debug-function frame)) - 'sb!eval::internal-apply-loop)) + #!+sb-interpreter (not (eq (debug-function-name (frame-debug-function + frame)) + 'sb!eval::internal-apply-loop)) + #!-sb-interpreter t *debugging-interpreter* (compiled-frame-escaped frame)) frame @@ -1063,27 +1064,22 @@ #!+x86 (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) -; (format t "ccf: ~A ~A ~A~%" caller ra up-frame) (when (cstack-pointer-valid-p caller) -; (format t "ccf2~%") ;; First check for an escaped frame. (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) (cond (code ;; If it's escaped it may be a function end breakpoint trap. -; (format t "ccf2: escaped ~S ~S~%" code pc-offset) (when (and (code-component-p code) (eq (%code-debug-info code) :bogus-lra)) ;; If :bogus-lra grab the real lra. (setq pc-offset (code-header-ref code (1+ real-lra-slot))) (setq code (code-header-ref code real-lra-slot)) -; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset) (aver code))) (t - ;; Not escaped + ;; not escaped (multiple-value-setq (pc-offset code) (compute-lra-data-from-pc ra)) -; (format t "ccf4 ~S ~S~%" code pc-offset) (unless code (setf code :foreign-function pc-offset 0 @@ -1110,6 +1106,13 @@ #!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) + + ;; FIXME: These conditionals are a hack to get the system to + ;; bootstrap itself despite a byte interpreter/compiler bug. Without + ;; it, the byte interpreter blows up when trying to cross-compile + ;; this function, hitting #:UNINITIALIZED-EVAL-STACK-ELEMENT while + ;; executing (SB-XC:MACRO-FUNCTION 'SB!EXT:WITH-ALIEN). + #+sb-xc (values nil 0 nil) #-sb-xc ; REMOVEME (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (sb!alien:with-alien ((lisp-interrupt-contexts (array (* os-context-t) nil) @@ -1364,14 +1367,14 @@ ;;;; operations on DEBUG-FUNCTIONs +;;; Execute 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-DEBUG-FUNCTION-BLOCKS +;;; returns nil if there is no result form. This signals a +;;; no-debug-blocks condition when the debug-function lacks +;;; debug-block information. (defmacro do-debug-function-blocks ((block-var debug-function &optional result) &body body) - #!+sb-doc - "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-DEBUG-FUNCTION-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))) @@ -1380,14 +1383,13 @@ (let ((,block-var (svref ,blocks ,i))) ,@body))))) +;;; Execute body in a context with var bound to each debug-var 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. (defmacro do-debug-function-variables ((var debug-function &optional result) &body body) - #!+sb-doc - "Executes body in a context with var bound to each debug-var 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-vars ,debug-function))) @@ -1398,11 +1400,10 @@ ,@body)) ,result)))) +;;; Return 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. (defun debug-function-function (debug-function) - #!+sb-doc - "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." (let ((cached-value (debug-function-%function debug-function))) (if (eq cached-value :unparsed) (setf (debug-function-%function debug-function) @@ -1429,10 +1430,9 @@ (bogus-debug-function nil))) cached-value))) +;;; Return the name of the function represented by debug-function. This may +;;; be a string or a cons; do not assume it is a symbol. (defun debug-function-name (debug-function) - #!+sb-doc - "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 (sb!c::compiled-debug-function-name @@ -1443,9 +1443,8 @@ (bogus-debug-function (bogus-debug-function-%name debug-function)))) +;;; Return a debug-function that represents debug information for function. (defun function-debug-function (fun) - #!+sb-doc - "Returns a debug-function that represents debug information for function." (case (get-type fun) (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) @@ -1482,10 +1481,9 @@ (get-header-data component)) sb!vm:word-bytes))))))) +;;; Return the kind of the function, which is one of :OPTIONAL, +;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL. (defun debug-function-kind (debug-function) - #!+sb-doc - "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL, - :TOP-level, :CLEANUP, or NIL." ;; FIXME: This "is one of" information should become part of the function ;; declamation, not just a doc string (etypecase debug-function @@ -1498,19 +1496,17 @@ (bogus-debug-function nil))) +;;; Is there any variable information for DEBUG-FUNCTION? (defun debug-var-info-available (debug-function) - #!+sb-doc - "Is there any variable information for DEBUG-FUNCTION?" (not (not (debug-function-debug-vars debug-function)))) +;;; Return a list of debug-vars in debug-function having the same name +;;; and package as symbol. If symbol is uninterned, then this returns +;;; a list of debug-vars 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. (defun debug-function-symbol-variables (debug-function symbol) - #!+sb-doc - "Returns a list of debug-vars in debug-function having the same name - and package as symbol. If symbol is uninterned, then this returns a list of - debug-vars 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-vars debug-function (symbol-name symbol))) (package (and (symbol-package symbol) (package-name (symbol-package symbol))))) @@ -1523,11 +1519,12 @@ (stringp (debug-var-package-name var)))) vars))) +;;; Return a list of debug-vars 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. (defun ambiguous-debug-vars (debug-function name-prefix-string) - "Returns a list of debug-vars 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-vars debug-function))) (declare (type (or null simple-vector) variables)) @@ -1568,24 +1565,25 @@ (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) +;;; Return 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-VAR; however it may be the symbol :DELETED if +;;; it is unreferenced in DEBUG-FUNCTION. This signals a +;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list +;;; information. (defun debug-function-lambda-list (debug-function) #!+sb-doc - "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-VAR; however it may be the symbol :deleted it - is unreferenced in debug-function. This signals a lambda-list-unavailable - condition when there is no argument list information." (etypecase debug-function (compiled-debug-function (compiled-debug-function-lambda-list debug-function))