From f68d0f59fa6f9c448b3a147b5940937af03f940a Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Tue, 9 Jan 2007 03:25:02 +0000 Subject: [PATCH] 1.0.1.15: Add RESTART-FRAME command to the debugger, reduce the runtime cost of the debug catch tags. * Change the debugger catch tag to funcall the thrown value, rather than just returning it. * Make RETURN throw a thunk that returns an appropriate value, and RESTART-FRAME throw a thunk that calls the same function again with the same arguments. * Always emit the debug catch with a static tag, rather than consing up a new tag every time the catch is entered. * To ensure that the tags are unique, the RETURN and RESTART-FRAME commands will first cons up a new tag, find the right catch-block structure on the stack, assign the new tag to the tag slot, and then throw the new tag. * Don't add the catch tags to some uninteresting (usually compiler-generated) functions, to reduce the compilation speed hit. --- NEWS | 3 +++ OPTIMIZATIONS | 7 +++++ doc/manual/debugger.texinfo | 9 ++++++- package-data-list.lisp-expr | 6 ++++- src/code/debug-int.lisp | 42 +++++++++++++++++++++++++++++ src/code/debug.lisp | 54 ++++++++++++++++++++++++++----------- src/compiler/ir1-translators.lisp | 2 ++ src/compiler/ir1tran-lambda.lisp | 41 +++++++++++++++++++++------- src/compiler/main.lisp | 6 ++--- version.lisp-expr | 2 +- 10 files changed, 142 insertions(+), 30 deletions(-) diff --git a/NEWS b/NEWS index 87ceb27..c09f34a 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,9 @@ changes in sbcl-1.0.2 relative to sbcl-1.0.1: 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) diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index cb963ea..d234ce3 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -403,3 +403,10 @@ comparison VOP receives an TN of the appropriate storage class. 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). + diff --git a/doc/manual/debugger.texinfo b/doc/manual/debugger.texinfo index 9c2b385..93aa28a 100644 --- a/doc/manual/debugger.texinfo +++ b/doc/manual/debugger.texinfo @@ -902,13 +902,20 @@ useful for popping debug command loop levels or aborting to top level, 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a6c6d3e..1fd8ae0 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -247,6 +247,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "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" @@ -397,7 +398,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*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" @@ -439,6 +442,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "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" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 4021963..80b08ce 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1114,6 +1114,48 @@ register." (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))))))) + + ;;;; operations on DEBUG-FUNs diff --git a/src/code/debug.lisp b/src/code/debug.lisp index bb78629..e9c620e 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -141,6 +141,11 @@ Other commands: 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 @@ -261,7 +266,7 @@ is how many frames to show." (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) @@ -1374,24 +1379,43 @@ reset to ~S." (!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* - "~@")))) + 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* + "~@"))) + +(defun frame-has-debug-tag-p (frame) + (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) + ;;;; debug loop command utilities diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 443fef5..bd97ac8 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -743,6 +743,7 @@ lexically apparent function definition in the enclosing environment." (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) @@ -777,6 +778,7 @@ other." (mapcar (lambda (name def) (ir1-convert-lambda def :source-name name + :maybe-add-debug-catch t :debug-name (debug-name 'labels name))) names defs)))) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index a15394a..2486661 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -885,7 +885,7 @@ ;;; 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) @@ -906,14 +906,10 @@ (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 @@ -935,6 +931,29 @@ (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 @@ -944,6 +963,7 @@ (ecase (car thing) ((lambda) (ir1-convert-lambda thing + :maybe-add-debug-catch t :source-name source-name :debug-name debug-name)) ((instance-lambda) @@ -957,6 +977,7 @@ (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) @@ -966,7 +987,9 @@ (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 diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b312c75..74cba28 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -975,9 +975,9 @@ (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.) diff --git a/version.lisp-expr b/version.lisp-expr index 5479fa1..fadbcd1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4