From: Christophe Rhodes Date: Mon, 10 May 2004 15:02:59 +0000 (+0000) Subject: 0.8.10.17: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4ccd8dcd4b936ca6a0f989e12397bd9426905a11;p=sbcl.git 0.8.10.17: Merge nikodemus' "faster debug-namify" sbcl-devel 2004-05-10 ... use FIND-SYMBOL rather than SB!IMPL::FIND-EXTERNAL-SYMBOL; ... a little more commentary around DEBUG-NAMIFY --- diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index edbc93c..d5bc4f2 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -41,7 +41,7 @@ ;; If we want to move over to list-style names ;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like ;; functionality] here might be a good place to start. - (debug-name (debug-namify "DEFMACRO ~S" name))) + (debug-name (sb!c::debug-namify "DEFMACRO " name))) `(eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%defmacro ',name #',def ',lambda-list ,doc ,debug-name))))))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index feb191c..a45cd62 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -134,7 +134,7 @@ (let ((def `(lambda (,whole ,environment) ,@local-decs ,body)) - (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name))) + (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name))) `(eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%define-compiler-macro ',name #',def diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 3923da3..51a5953 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -365,7 +365,7 @@ (the simple-string (if (stringp leaf-debug-name) leaf-debug-name - (debug-namify "function ~S" leaf-debug-name))))) + (debug-namify "function " leaf-debug-name))))) ;;; Given a list of top level lambdas, return ;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS). diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 6b793b7..1de88a5 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -171,19 +171,58 @@ dynamic binding, even though the symbol name follows the usual naming~@ convention (names like *FOO*) for special variables" symbol)) (values)) -;;; shorthand for creating debug names from source names or other -;;; stems, e.g. -;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME) -;;; (DEBUG-NAMIFY "top level form ~S" FORM) +;;; Hacky (duplicating machinery found elsewhere because this function +;;; turns out to be on a critical path in the compiler) shorthand for +;;; creating debug names from source names or other stems, e.g. ;;; -;;; FIXME: This function seems to have a lot in common with -;;; STRINGIFY-FORM, and perhaps there's some way to merge the two -;;; functions. -(declaim (ftype (sfunction (string &rest t) string) debug-namify)) -(defun debug-namify (format-string &rest format-arguments) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* *cl-package*) - (*print-length* 3) - (*print-level* 2)) - (apply #'format nil format-string format-arguments)))) +;;; (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR" +;;; (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)" +;;; +;;; If ALT is given it must be a string -- it is then used in place of +;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS. +;;; +(declaim (inline debug-namify)) +(defun debug-namify (head tail &optional alt) + (declare (type (or null string) alt)) + (flet ((symbol-debug-name (symbol) + ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL. + (if (and alt (eq '.anonymous. symbol)) + alt + (let ((package (symbol-package symbol)) + (name (symbol-name symbol))) + (cond + ((eq package *keyword-package*) + (concatenate 'string ":" name)) + ((eq package *cl-package*) + name) + ((null package) + (concatenate 'string "#:" name)) + (t + (multiple-value-bind (symbol status) + (find-symbol name package) + (declare (ignore symbol)) + (concatenate 'string + (package-name package) + (if (eq status :external) ":" "::") + name)))))))) + (cond ((and (stringp head) (stringp tail)) + (concatenate 'string head tail)) + ((and (stringp head) (symbolp tail)) + (concatenate 'string head (symbol-debug-name tail))) + ((and (symbolp head) (stringp tail)) + (concatenate 'string (symbol-debug-name head) tail)) + (t + (macrolet ((out (obj s) + `(typecase ,obj + (string (write-string ,obj ,s)) + (symbol (write-string (symbol-debug-name ,obj) ,s)) + (t (prin1 ,obj ,s))))) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *cl-package*) + (*print-length* 3) + (*print-level* 2)) + (with-output-to-string (s) + (out head s) + (out tail s))))))))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 0bd6161..eb93a2e 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -430,7 +430,7 @@ '(lambda named-lambda instance-lambda lambda-with-lexenv)) (ir1-convert-lambdalike thing - :debug-name (debug-namify "#'~S" thing) + :debug-name (debug-namify "#'" thing) :allow-debug-catch-tag t)) ((legal-fun-name-p thing) (find-lexically-apparent-fun @@ -544,8 +544,8 @@ (processing-decls (decls vars nil next result) (let ((fun (ir1-convert-lambda-body forms vars - :debug-name (debug-namify "LET ~S" - bindings)))) + :debug-name (debug-namify "LET " + bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) (ir1-convert-combination-args fun-lvar ctran next result values)))))) @@ -625,7 +625,7 @@ (ir1-convert-lambda d :source-name n :debug-name (debug-namify - "FLET ~S" n) + "FLET " n) :allow-debug-catch-tag t)) names defs))) (processing-decls (decls nil fvars next result) @@ -647,7 +647,7 @@ (make-functional :%source-name name :%debug-name (debug-namify - "LABELS placeholder ~S" + "LABELS placeholder " name))) names)) ;; (like PAIRLIS but guaranteed to preserve ordering:) @@ -660,7 +660,7 @@ (ir1-convert-lambda def :source-name name :debug-name (debug-namify - "LABELS ~S" name) + "LABELS " name) :allow-debug-catch-tag t)) names defs)))) @@ -833,7 +833,7 @@ (let ((fun (ir1-convert-lambda `(lambda () (return-from ,tag (%unknown-values))) - :debug-name (debug-namify "escape function for ~S" tag)))) + :debug-name (debug-namify "escape function for " tag)))) (setf (functional-kind fun) :escape) (reference-leaf start next result fun))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 3a5b8f1..370c5a9 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1084,10 +1084,9 @@ (block-next (node-block call))) (let ((new-fun (ir1-convert-inline-lambda res - :debug-name (debug-namify "LAMBDA-inlined ~A" - (as-debug-name - source-name - "")))) + :debug-name (debug-namify "LAMBDA-inlined " + source-name + ""))) (ref (lvar-use (combination-fun call)))) (change-ref-leaf ref new-fun) (setf (combination-kind call) :full) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 5dcac30..27a2cf3 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -195,31 +195,6 @@ (format nil "~<~@; ~S~:>" (list form)) (prin1-to-string form))))) -;;; shorthand for a repeated idiom in creating debug names -;;; -;;; the problem, part I: We want to create debug names that look like -;;; "&MORE processor for " where might be -;;; either a source-name value (typically a symbol) or a non-symbol -;;; debug-name value (typically a string). It's awkward to handle this -;;; with FORMAT because we'd like to splice a source-name value using -;;; "~S" (to get package qualifiers) but a debug-name value using "~A" -;;; (to avoid irrelevant quotes at string splice boundaries). -;;; -;;; the problem, part II: The is represented as a pair -;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used -;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily -;;; we don't use a value if it's NIL, instead defaulting it. But we -;;; can't safely/comfortably use NIL for that in this context, since -;;; the app programmer can use NIL as a name, so we use the private -;;; symbol .ANONYMOUS. instead.) -;;; -;;; the solution: Use this function to convert whatever it is to a -;;; string, which FORMAT can then splice using "~A". -(defun as-debug-name (source-name debug-name) - (if (eql source-name '.anonymous.) - debug-name - (debug-namify "~S" source-name))) - ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current ;;; error context, or NIL if we can't figure anything out. ARGS is a ;;; list of things that are going to be printed out in the error diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 88d3429..ec19c9e 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -214,7 +214,7 @@ :aux-vars (rest aux-vars) :aux-vals (rest aux-vals) :debug-name (debug-namify - "&AUX bindings ~S" + "&AUX bindings " aux-vars)))) (reference-leaf start ctran fun-lvar fun) (ir1-convert-combination-args fun-lvar ctran next result @@ -427,8 +427,8 @@ ,@(default-vals)))) arg-vars :debug-name - (debug-namify "&OPTIONAL processor ~D" - (random 100)) + (debug-namify "&OPTIONAL processor " + (gensym)) :note-lexical-bindings nil)))) (mapc (lambda (var arg-var) (when (cdr (leaf-refs arg-var)) @@ -622,7 +622,7 @@ (%funcall ,(optional-dispatch-main-entry res) ,@(arg-vals)))) (arg-vars) - :debug-name (debug-namify "~S processing" '&more) + :debug-name "&MORE processing" :note-lexical-bindings nil))) (setf (optional-dispatch-more-entry res) (register-entry-point ep res))))) @@ -708,9 +708,8 @@ body (main-vars) :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) - :debug-name (debug-namify "varargs entry for ~A" - (as-debug-name source-name - debug-name)))) + :debug-name (debug-namify + "varargs entry for " source-name debug-name))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) @@ -778,9 +777,9 @@ :aux-vars aux-vars :aux-vals aux-vals :debug-name (debug-namify - "hairy arg processor for ~A" - (as-debug-name source-name - debug-name))))) + "hairy arg processor for " + source-name + debug-name)))) (setf (optional-dispatch-main-entry res) fun) (register-entry-point fun res) (push (if supplied-p-p @@ -847,7 +846,7 @@ &key (source-name '.anonymous.) (debug-name (debug-namify - "OPTIONAL-DISPATCH ~S" + "OPTIONAL-DISPATCH " vars))) (declare (list body vars aux-vars aux-vals)) (let ((res (make-optional-dispatch :arglist vars diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index a583be1..a58d8d7 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -396,7 +396,7 @@ (let* ((forms (if for-value `(,form) `(,form nil))) (res (ir1-convert-lambda-body forms () - :debug-name (debug-namify "top level form ~S" form)))) + :debug-name (debug-namify "top level form " form)))) (setf (functional-entry-fun res) res (functional-arg-documentation res) () (functional-kind res) :toplevel) @@ -520,7 +520,7 @@ (ir1-convert-lambda opname :debug-name (debug-namify - "LAMBDA CAR ~S" + "LAMBDA CAR " opname) :allow-debug-catch-tag t)))))))) (values)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 0e9ba01..d26584f 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -186,7 +186,7 @@ (with-ir1-environment-from-node (lambda-bind (main-entry fun)) (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun) :debug-name (debug-namify - "XEP for ~A" + "XEP for " (leaf-debug-name fun))))) (setf (functional-kind res) :external (leaf-ever-used res) t @@ -345,7 +345,7 @@ (ir1-convert-lambda (functional-inline-expansion original-functional) :debug-name (debug-namify - "local inline ~A" + "local inline " (leaf-debug-name original-functional))))))) (cond (losing-local-functional @@ -546,7 +546,7 @@ `(lambda ,vars (declare (ignorable ,@ignores)) (%funcall ,entry ,@args)) - :debug-name (debug-namify "hairy function entry ~S" + :debug-name (debug-namify "hairy function entry " (lvar-fun-name (basic-combination-fun call))))))) (convert-call ref call new-fun) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 1af1fbd..d74d3ae 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -909,8 +909,8 @@ (setf (component-kind component) :initial) (let* ((locall-fun (ir1-convert-lambdalike definition - :debug-name (debug-namify "top level local call ~S" - name) + :debug-name (debug-namify "top level local call " + name) ;; KLUDGE: we do this so that we get to have ;; nice debug returnness in functions defined ;; from the REPL diff --git a/version.lisp-expr b/version.lisp-expr index 879865e..ce981eb 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".) -"0.8.10.16" +"0.8.10.17"