diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 1326de04a647b19228c3c8dedb2aa5560825c89e..3196762b3c3fac2e0066e452d885f5b5c3df7062 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.112 2004/08/03 11:59:42 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.113 2004/08/30 14:55:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,7 +32,7 @@ top-frame frame-down frame-up flush-frames-above frame-debug-function frame-code-location eval-in-frame return-from-frame frame-catches - frame-number frame frame-p + frame-number frame frame-p find-debug-tag-for-frame do-debug-function-blocks debug-function-lambda-list debug-variable-info-available do-debug-function-variables @@ -3836,6 +3836,28 @@ (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) +;;; FIND-DEBUG-TAG-FOR-FRAME -- Public. +;;; +;;; helper function, used also by debug:debug-return. +(defun find-debug-tag-for-frame (frame) + "Find and return the debug catch tag for a given frame, if it exists." + (assoc-if #'(lambda (x) + (and (symbolp x) + (not (symbol-package x)) + (string= x :cmucl-debug-catch-tag))) + (frame-catches frame))) + + +;;; RETURN-FROM-FRAME -- Public. +;;; +(defun return-from-frame (frame form) + (declare (type frame frame)) + "Evaluate Form in the lexical context of Frame's current code location, + returning from the current frame the results of the evaluation." + (let ((tag (find-debug-tag-for-frame frame))) + (when tag (throw (car tag) (eval-in-frame frame form))))) + + ;;;; Breakpoints. diff --git a/code/debug.lisp b/code/debug.lisp index 374e2afb84e1d29f454df02463e76a97c1aef095..2d814cc3b97ec53ef6978aeafdd8f3a1381d7016 100644 --- a/code/debug.lisp +++ b/code/debug.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.63 2003/08/08 11:36:25 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.64 2004/08/30 14:55:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -124,13 +124,10 @@ Breakpoints and steps: Abbreviations: BR, BP STEP [n] step to the next location or step n times. -Function and macro commands: - (DEBUG:DEBUG-RETURN expression) +Actions on frames: + DEBUG-RETURN expression returns expression's values from the current frame, exiting the debugger. - (DEBUG:ARG n) - returns the n'th argument, remaining in the debugger. - (DEBUG:VAR string-or-symbol [id]) - returns the specified variable's value, remaining in the debugger. + Abbreviations: R See the CMU Common Lisp User's Manual for more information. ") @@ -1239,6 +1236,21 @@ See the CMU Common Lisp User's Manual for more information. (def-debug-command-alias "F" "FRAME") +;; debug-return, equivalent to return-from-frame in some other lisps, +;; allows us to return an arbitrary value from any frame +(def-debug-command "DEBUG-RETURN" (&optional + (return (read-prompting-maybe + "debug-return: "))) + (unless (di:return-from-frame *current-frame* return) + ;; the "unless" here is for aesthetical purposes only. If all goes + ;; well with return-from-frame, the code after it will never get + ;; reached anyway. + (format t "~@<can't find a tag for this frame ~ + ~2I~_(hint: try increasing the DEBUG optimization quality ~ + and recompiling)~:@>"))) + +(def-debug-command-alias "R" "DEBUG-RETURN") + ;;; ;;; In and Out commands. diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index fa681cc400eb6d3d41861fe4db0b30d3dde64756..600b9df58424fb5c092459321457116d8feefa32 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.82 2003/10/26 17:31:25 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.83 2004/08/30 14:55:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1662,7 +1662,12 @@ (fun (ir1-convert-lambda `(lambda (&optional ,@dums &rest ,ignore) (declare (ignore ,ignore)) - (funcall ,(ref-leaf ref) ,@dums))))) + (funcall ,(ref-leaf ref) ,@dums)) + nil ; name + nil ; parent-form + nil ; allow-debug-catch-tag + 'ir1-optimize-mv-call ; caller + ))) (change-ref-leaf ref fun) (assert (eq (basic-combination-kind node) :full)) (local-call-analyze *current-component*) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 393f0a64eae36768a01b73c79dc3daf94e08e4bb..630c94c1b265a69e049c61f184a4e6c67ad526ae 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.170 2004/04/28 17:58:08 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.171 2004/08/30 14:55:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -141,6 +141,17 @@ (member (car y) '(flet labels)) (equal x (cadr y))))) + +;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the +;;; insertion a (CATCH ...) around code to allow the debugger +;;; return-from-frame (RETURN) command to work. +(defvar *allow-debug-catch-tag* t) + +;;; This is for debugging the return-from-frame functionality. These are +;;; supposed to go away in the future. --jwr +(defvar *print-debug-tag-conversions* nil) +(defvar *print-debug-tag-converted-bodies* nil) + ;;;; Dynamic-Extent @@ -669,6 +680,8 @@ (setq trail (cdr trail))))))) + + ;;;; IR1-CONVERT, macroexpansion and special-form dispatching. (declaim (start-block ir1-convert ir1-convert-progn-body @@ -722,7 +735,12 @@ (compiler-error "Illegal function call.")) (t (ir1-convert-combination start cont form - (ir1-convert-lambda fun))))))))) + ;; TODO: check this case --jwr + (ir1-convert-lambda fun + nil ; name + nil ; parent-form + t + 'ir1-convert))))))))) ;;; Reference-Constant -- Internal @@ -1476,6 +1494,97 @@ key)) +;;; IR1-wrap-for-debug -- Internal +;;; +;;; Wrap a piece of code in a catch form, so that we can later throw to it +;;; in the debugger, to return a value. +;;; +(defun ir1-wrap-for-debug (body) + (let ((new-body `((catch (make-symbol "CMUCL-DEBUG-CATCH-TAG") + ,@body)))) + (when (and *compile-print* + *print-debug-tag-conversions* + *print-debug-tag-converted-bodies*) + (format t "new-body: ~S~%" new-body)) + new-body)) + + +;;; IR1-Convert-Lambda -- Internal +;;; +;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf. NAME and +;;; PARENT-FORM are context that is used to drive the context sensitive +;;; declaration mechanism. If we find an entry in *CONTEXT-DECLARATIONS* that +;;; matches this context (by returning a non-null value) then we add it into +;;; the local declarations. +;;; +(defun ir1-convert-lambda (form &optional + name + parent-form + allow-debug-catch-tag + caller) + (unless (consp form) + (compiler-error "Found a ~S when expecting a lambda expression:~% ~S" + (type-of form) form)) + (unless (eq (car form) 'lambda) + (compiler-error "Expecting a lambda, but form begins with ~S:~% ~S" + (car form) form)) + (unless (and (consp (cdr form)) (listp (cadr form))) + (compiler-error "Lambda-list absent or not a list:~% ~S" form)) + + (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) + (find-lambda-vars (cadr form)) + (multiple-value-bind (body decls) + (system:parse-body (cddr form) *lexical-environment* t) + (let* ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* + allow-debug-catch-tag)) + (new-body (if (and parent-form + *allow-debug-catch-tag* + (policy nil (= debug 3))) ; TODO: check the policy settings --jwr + (progn + (when (and *compile-print* *print-debug-tag-conversions*) + (format t "ir1-convert-lambda: called by: ~S, parent-form: ~S~%" + caller parent-form)) + (ir1-wrap-for-debug body)) + body)) + (*current-function-names* + (if (member parent-form + '(flet labels defun defmacro define-compiler-macro) + :test #'eq) + (list name) + *current-function-names*)) + (context-decls + (and parent-form + (loop for fun in *context-declarations* + append (funcall (the function fun) + name parent-form)))) + (cont (make-continuation)) + (*lexical-environment* + (process-declarations (append context-decls decls) + (append aux-vars vars) + nil cont)) + (res (if (or (find-if #'lambda-var-arg-info vars) keyp) + (ir1-convert-hairy-lambda new-body vars keyp + allow-other-keys + aux-vars aux-vals cont) + (ir1-convert-lambda-body new-body vars aux-vars aux-vals + t cont)))) + (setf (functional-inline-expansion res) form) + (setf (functional-arg-documentation res) (cadr form)) + (setf (leaf-name res) + (or name + ;; PCL-generated lambdas end up here without an explicit NAME. + ;; To avoid ending up with IR1 lambda-nodes that are unnamed, + ;; we extract a name from the "method-name" declaration that + ;; is inserted by PCL. A cleaner solution would be to add a + ;; NAMED-LAMBDA IR1 translator, similar to that used in SBCL, + ;; and make PCL use that instead of LAMBDA. + (let ((decl (find 'pcl::method-name decls :key 'caadr))) + (and decl + (eq 'declare (first decl)) + (cons 'pcl::method (cadadr decl)))))) + res)))) + + ;;; Find-Lambda-Vars -- Internal ;;; ;;; Parse a lambda-list into a list of Var structures, stripping off any aux @@ -2196,65 +2305,6 @@ res)) -;;; IR1-Convert-Lambda -- Internal -;;; -;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf. NAME and -;;; PARENT-FORM are context that is used to drive the context sensitive -;;; declaration mechanism. If we find an entry in *CONTEXT-DECLARATIONS* that -;;; matches this context (by returning a non-null value) then we add it into -;;; the local declarations. -;;; -(defun ir1-convert-lambda (form &optional name parent-form) - (unless (consp form) - (compiler-error "Found a ~S when expecting a lambda expression:~% ~S" - (type-of form) form)) - (unless (eq (car form) 'lambda) - (compiler-error "Expecting a lambda, but form begins with ~S:~% ~S" - (car form) form)) - (unless (and (consp (cdr form)) (listp (cadr form))) - (compiler-error "Lambda-list absent or not a list:~% ~S" form)) - - (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) - (find-lambda-vars (cadr form)) - (multiple-value-bind (body decls) - (system:parse-body (cddr form) *lexical-environment* t) - (let* ((*current-function-names* - (if (member parent-form - '(flet labels defun defmacro define-compiler-macro) - :test #'eq) - (list name) - *current-function-names*)) - (context-decls - (and parent-form - (loop for fun in *context-declarations* - append (funcall (the function fun) - name parent-form)))) - (cont (make-continuation)) - (*lexical-environment* - (process-declarations (append context-decls decls) - (append aux-vars vars) - nil cont)) - (res (if (or (find-if #'lambda-var-arg-info vars) keyp) - (ir1-convert-hairy-lambda body vars keyp - allow-other-keys - aux-vars aux-vals cont) - (ir1-convert-lambda-body body vars aux-vars aux-vals - t cont)))) - (setf (functional-inline-expansion res) form) - (setf (functional-arg-documentation res) (cadr form)) - (setf (leaf-name res) - (or name - ;; PCL-generated lambdas end up here without an explicit NAME. - ;; To avoid ending up with IR1 lambda-nodes that are unnamed, - ;; we extract a name from the "method-name" declaration that - ;; is inserted by PCL. A cleaner solution would be to add a - ;; NAMED-LAMBDA IR1 translator, similar to that used in SBCL, - ;; and make PCL use that instead of LAMBDA. - (let ((decl (find 'pcl::method-name decls :key 'caadr))) - (and decl - (eq 'declare (first decl)) - (cons 'pcl::method (cadadr decl)))))) - res)))) (declaim (end-block)) @@ -2695,11 +2745,14 @@ (reference-leaf start cont fn)))) (if (consp thing) (case (car thing) - ((lambda) - (reference-leaf start cont (ir1-convert-lambda thing nil 'function))) + ((lambda) + ;; we set allow-debug-catch-tag here, needed for CLOS --jwr + (reference-leaf start cont (ir1-convert-lambda thing nil 'function t))) ((instance-lambda) + ;; TODO: check if we should allow-debug-catch-tag here --jwr (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) - nil 'function))) + nil ; name + 'function))) (setf (getf (functional-plist res) :fin-function) t) (reference-leaf start cont res))) (t @@ -3132,6 +3185,11 @@ (multiple-value-bind (names defs) (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar #'(lambda (n d) + ;; There is no point in allowing debug + ;; catch tag to be inserted here, since in + ;; CMUCL (as opposed to SBCL) flet + ;; function calls do not make it to the + ;; debugger anyway? --jwr (ir1-convert-lambda d n 'flet)) names defs)) (*lexical-environment* @@ -3158,6 +3216,9 @@ (real-funs (let ((*lexical-environment* (make-lexenv :functions new-fenv))) (mapcar #'(lambda (n d) + ;; see comments in (def-ir1-translator flet) + ;; on why we don't set allow-debug-catch-tag + ;; to t here --jwr (ir1-convert-lambda d n 'labels)) names defs)))) @@ -3635,7 +3696,9 @@ (let ((name (eval name)) (def (second def))) ; Don't want to make a function just yet... (let* ((*current-path* (revert-source-path 'define-compiler-macro)) - (fun (ir1-convert-lambda def name 'define-compiler-macro))) + (fun (ir1-convert-lambda def + name + 'define-compiler-macro))) (setf (leaf-name fun) (list :compiler-macro name)) (setf (functional-arg-documentation fun) (eval lambda-list)) @@ -3842,7 +3905,18 @@ (unless (eq (defined-function-inlinep var) :inline) (setf (defined-function-inline-expansion var) nil)) (let* ((name (leaf-name var)) - (fun (funcall converter lambda name parent-form)) + ;; converter is either ir1-convert-lambda or ir1-convert-inline-lambda + ;; we allow-debug-catch-tag if it's not inline --jwr + (fun (if (eq converter #'ir1-convert-inline-lambda) + (funcall converter + lambda + name + parent-form) + (funcall converter + lambda + name + parent-form + t))) (function-info (info function info name))) (setf (functional-inlinep fun) (defined-function-inlinep var)) (assert-new-definition var fun)