X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=ea6149bdde346fad8c333769331294ff2ea5af2a;hb=95f5ac2fa70b3f14d052e20f4250166f219dcc39;hp=83378bdcc2755380d0090a0969dc8f32bf3f9e5a;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 83378bd..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,8 +967,10 @@ ;;; 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)) - '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 @@ -1062,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 @@ -1109,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) @@ -1363,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))) @@ -1379,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))) @@ -1397,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) @@ -1428,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 @@ -1442,14 +1443,14 @@ (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))) (#.sb!vm:funcallable-instance-header-type - (cond ((sb!eval:interpreted-function-p fun) + (cond #!+sb-interpreter + ((sb!eval:interpreted-function-p fun) (make-interpreted-debug-function (or (sb!eval::interpreted-function-definition fun) (sb!eval::convert-interpreted-fun fun)))) @@ -1480,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 @@ -1496,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))))) @@ -1521,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)) @@ -1566,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)) @@ -2471,6 +2471,7 @@ (if (indirect-value-cell-p res) (sb!c:value-cell-ref res) res))) + #!+sb-interpreter (interpreted-debug-var (aver (typep frame 'interpreted-frame)) (sb!eval::leaf-value-lambda-var @@ -2814,6 +2815,7 @@ (if (indirect-value-cell-p current-value) (sb!c:value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) + #!+sb-interpreter (interpreted-debug-var (aver (typep frame 'interpreted-frame)) (sb!eval::set-leaf-value-lambda-var @@ -3748,8 +3750,10 @@ ;; so we just leave it up to the C code. (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) - ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. - #!-(or hpux irix x86) + ;; Some platforms have no usable sigreturn() call. If your + ;; implementation of arch_do_displaced_inst() doesn't sigreturn(), + ;; add it to this list. + #!-(or hpux irix x86 alpha) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset)