over, in code compiled with (DEBUG 2) or higher
* improvement: support for executable cores on NetBSD (thanks to
Richard Kreuter)
+ * new feature: added a RESTART-FRAME debugger command
+ * optimization: the function call overhead in code compiled with
+ a high DEBUG optimization setting is significantly
* bug fix: an error is signaled for attempts to use READ-SEQUENCE
for a (SIGNED-BYTE 8) stream and (UNSIGNED-BYTE 8) vector, or vice versa.
(thanks to Tony Martinez)
Obviously, it would be better if a) we only performed one MOV prior to
all three comparisons or b) eliminated the necessity of the MOV(s)
altogether. The former option is probably easier than the latter.
+
+--------------------------------------------------------------------------------
+#37
+
+Dynamic extent allocation doesn't currently work for one-element lists,
+since there's a source transform from (LIST X) to (CONS X NIL).
+
as the case may be.
@end deffn
-@deffn {Debugger Command} return @var{value}
+@deffn {Debugger Command} return @var{value}
Returns @var{value} from the current stack frame. This command is
available when the @code{debug} optimization quality is greater than
both @code{speed} and @code{space}. Care must be taken that the value
is of the same type as SBCL expects the stack frame to return.
@end deffn
+@deffn {Debugger Command} restart-frame
+Restarts execution of the current stack frame. This command is
+available when the @code{debug} optimization quality is greater than
+both @code{speed} and @code{space} and when the frame is for is a global
+function. If the function is redefined in the debugger before the frame
+is restarted, the new function will be used.
+@end deffn
@node Information Commands
@comment node-name, next, previous, up
"CURRENT-BINDING-POINTER" "CURRENT-NFP-TN"
"CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE"
"DEALLOC-NUMBER-STACK-SPACE"
+ "DEBUG-CATCH-TAG"
"DEF-IR1-TRANSLATOR"
"!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
"DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
"*PRINT-LOCATION-KIND*"
"*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"
"*TRACE-VALUES*" "DO-DEBUG-COMMAND"
- "*TRACE-ENCAPSULATE-DEFAULT*"))
+ "*TRACE-ENCAPSULATE-DEFAULT*"
+ "FRAME-HAS-DEBUG-TAG-P"
+ "UNWIND-TO-FRAME-AND-CALL"))
#s(sb-cold:package-data
:name "SB!DI"
"FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION"
"FRAME-DEBUG-FUN" "FRAME-DOWN"
"FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
+ "REPLACE-FRAME-CATCH-TAG"
"FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P"
"INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"
"LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS"
(sap-ref-32 catch
(* sb!vm:catch-block-previous-catch-slot
sb!vm:n-word-bytes)))))))
+
+;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
+(defun replace-frame-catch-tag (frame old-tag new-tag)
+ (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+ (fp (frame-pointer frame)))
+ (loop until (zerop (sap-int catch))
+ do (when (sap= fp
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))))
+ (let ((current-tag
+ #!-(or x86 x86-64)
+ (stack-ref catch sb!vm:catch-block-tag-slot)
+ #!+(or x86 x86-64)
+ (make-lisp-obj
+ (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes)))))
+ (when (eq current-tag old-tag)
+ #!-(or x86 x86-64)
+ (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag)
+ #!+(or x86 x86-64)
+ (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes))
+ (get-lisp-obj-address new-tag)))))
+ do (setf catch
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes)))))))
+
+
\f
;;;; operations on DEBUG-FUNs
current frame, if this frame was compiled with a sufficiently high
DEBUG optimization quality.
+ RESTART-FRAME
+ Restart execution of the current frame, if this frame is for a
+ global function which was compiled with a sufficiently high
+ DEBUG optimization quality.
+
SLURP
Discard all pending input on *STANDARD-INPUT*. (This can be
useful when the debugger was invoked to handle an error in
(sb!di:lambda-list-unavailable
()
(make-unprintable-object "unavailable lambda list")))))
-(legal-fun-name-p '(lambda ()))
+
(defvar *show-entry-point-details* nil)
(defun clean-xep (name args)
(!def-debug-command "SLURP" ()
(loop while (read-char-no-hang *standard-input*)))
+(defun unwind-to-frame-and-call (frame thunk)
+ (let ((tag (gensym)))
+ (sb!di:replace-frame-catch-tag frame
+ 'sb!c:debug-catch-tag
+ tag)
+ (throw tag thunk)))
+
(!def-debug-command "RETURN" (&optional
(return (read-prompting-maybe
"return: ")))
- (let ((tag (find-if (lambda (x)
- (and (typep (car x) 'symbol)
- (not (symbol-package (car x)))
- (string= (car x) "SB-DEBUG-CATCH-TAG")))
- (sb!di::frame-catches *current-frame*))))
- (if tag
- (throw (car tag)
- (funcall (sb!di:preprocess-for-eval
- return
- (sb!di:frame-code-location *current-frame*))
- *current-frame*))
- (format *debug-io*
- "~@<can't find a tag for this frame ~
+ (if (frame-has-debug-tag-p *current-frame*)
+ (let* ((code-location (sb!di:frame-code-location *current-frame*))
+ (values (multiple-value-list
+ (funcall (sb!di:preprocess-for-eval return code-location)
+ *current-frame*))))
+ (unwind-to-frame-and-call *current-frame* (lambda ()
+ (values-list values))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
~2I~_(hint: try increasing the DEBUG optimization quality ~
- and recompiling)~:@>"))))
+ and recompiling)~:@>")))
+
+(!def-debug-command "RESTART-FRAME" ()
+ (if (frame-has-debug-tag-p *current-frame*)
+ (let* ((call-list (frame-call-as-list *current-frame*))
+ (fun (fdefinition (car call-list))))
+ (unwind-to-frame-and-call *current-frame*
+ (lambda ()
+ (apply fun (cdr call-list)))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>")))
+
+(defun frame-has-debug-tag-p (frame)
+ (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car))
+
\f
;;;; debug loop command utilities
(let ((fvars (mapcar (lambda (n d)
(ir1-convert-lambda d
:source-name n
+ :maybe-add-debug-catch t
:debug-name (debug-name 'flet n)))
names defs)))
(processing-decls (decls nil fvars next result)
(mapcar (lambda (name def)
(ir1-convert-lambda def
:source-name name
+ :maybe-add-debug-catch t
:debug-name (debug-name 'labels name)))
names defs))))
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
- debug-name)
+ debug-name maybe-add-debug-catch)
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
(type-of form)
(binding* (((*lexenv* result-type post-binding-lexenv)
(process-decls decls (append aux-vars vars) nil
:binding-form-p t))
- (forms (if (and *allow-instrumenting*
+ (forms (if (and maybe-add-debug-catch
+ *allow-instrumenting*
(policy *lexenv* (>= insert-debug-catch 2)))
- `((catch (locally
- (declare (optimize (insert-step-conditions 0)))
- ;; Using MAKE-SYMBOL would lead
- ;; to recursive disaster.
- (%make-symbol "SB-DEBUG-CATCH-TAG"))
- ,@forms))
+ (wrap-forms-in-debug-catch forms)
forms))
(forms (if (eq result-type *wild-type*)
forms
(setf (functional-arg-documentation res) (cadr form))
res))))
+(defun wrap-forms-in-debug-catch (forms)
+ `( ;; Normally, we'll return from this block with the below RETURN-FROM.
+ (block
+ return-value-tag
+ ;; If DEBUG-CATCH-TAG is thrown (with a thunk as the value) the
+ ;; RETURN-FROM is elided and we funcall the thunk instead. That
+ ;; thunk might either return a value (for a RETURN-FROM-FRAME)
+ ;; or call this same function again (for a RESTART-FRAME).
+ ;; -- JES, 2007-01-09
+ (funcall
+ (the function
+ ;; Use a constant catch tag instead of consing a new one for every
+ ;; entry to this block. The uniquencess of the catch tags is
+ ;; ensured when the tag is throw by the debugger. It'll allocate a
+ ;; new tag, and modify the reference this tag in the proper
+ ;; catch-block structure to refer to that new tag. This
+ ;; significantly decreases the runtime cost of high debug levels.
+ ;; -- JES, 2007-01-09
+ (catch 'debug-catch-tag
+ (return-from return-value-tag
+ (progn
+ ,@forms))))))))
+
;;; helper for LAMBDA-like things, to massage them into a form
;;; suitable for IR1-CONVERT-LAMBDA.
(defun ir1-convert-lambdalike (thing
(ecase (car thing)
((lambda)
(ir1-convert-lambda thing
+ :maybe-add-debug-catch t
:source-name source-name
:debug-name debug-name))
((instance-lambda)
(if (legal-fun-name-p name)
(let ((defined-fun-res (get-defined-fun name))
(res (ir1-convert-lambda lambda-expression
+ :maybe-add-debug-catch t
:source-name name)))
(assert-global-function-definition-type name res)
(setf (defined-fun-functional defined-fun-res) res)
(policy ref (> recognize-self-calls 0)))
res defined-fun-res))
res)
- (ir1-convert-lambda lambda-expression :debug-name name))))
+ (ir1-convert-lambda lambda-expression
+ :maybe-add-debug-catch t
+ :debug-name name))))
((lambda-with-lexenv)
(ir1-convert-inline-lambda thing
:source-name source-name
(debug-name 'initial-component name))
(setf (component-kind component) :initial)
(let* ((locall-fun (let ((*allow-instrumenting* t))
- (apply #'ir1-convert-lambdalike
- definition
- (list :source-name name))))
+ (funcall #'ir1-convert-lambdalike
+ definition
+ :source-name name)))
(debug-name (debug-name 'tl-xep name))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.1.14"
+"1.0.1.15"
projects / sbcl.git / commitdiff