\f
;;;; 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
;;; 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
#!+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
#!+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)
\f
;;;; 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)))
(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)))
,@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)
(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
(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))))
(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
(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)))))
(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))
(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))
(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
(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
;; 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)
projects / sbcl.git / blobdiff