Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
0.9.15.23: finding defintions of profiled functions
 * Patch by Troels Henriksen.
 * Test-case missing from 0.9.15.22.
  • Loading branch information
nikodemus committed Aug 10, 2006
1 parent c9b36f0 commit e15ca90
Show file tree
Hide file tree
Showing 5 changed files with 25 additions and 8 deletions.
2 changes: 2 additions & 0 deletions NEWS
Expand Up @@ -7,6 +7,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15:
(thanks to Lutz Euler)
* optimization: hashing of general arrays and vectors has been
improved. (reported by Any Fingerhut)
* enhancement: SB-INTROSPECT is now able to find definitions of
profiled functions. (thanks to Troels Henriksen)
* fixed bug #337: use of MAKE-METHOD in method combination now works
even in the presence of user-defined method classes. (reported by
Bruno Haible and Pascal Costanza)
Expand Down
22 changes: 15 additions & 7 deletions contrib/sb-introspect/sb-introspect.lisp
Expand Up @@ -143,7 +143,14 @@ If an unsupported TYPE is requested, the function will return NIL.
(list x)))
(get-class (name)
(and (symbolp name)
(find-class name nil))))
(find-class name nil)))
(real-fdefinition (name)
;; for getting the real function object, even if the
;; function is being profiled
(let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*)))
(if profile-info
(sb-profile::profile-info-encapsulated-fun profile-info)
(fdefinition name)))))
(listify
(case type
((:variable)
Expand All @@ -169,7 +176,7 @@ If an unsupported TYPE is requested, the function will return NIL.
(when (and (fboundp name)
(or (not (symbolp name))
(not (macro-function name))))
(let ((fun (fdefinition name)))
(let ((fun (real-fdefinition name)))
(when (eq (not (typep fun 'generic-function))
(not (eq type :generic-function)))
(find-definition-source fun)))))
Expand All @@ -178,12 +185,13 @@ If an unsupported TYPE is requested, the function will return NIL.
(when expander-fun
(find-definition-source expander-fun))))
((:method)
(when (and (fboundp name)
(typep (fdefinition name) 'generic-function))
(loop for method in (sb-mop::generic-function-methods
(fdefinition name))
(when (fboundp name)
(let ((fun (real-fdefinition name)))
(when (typep fun 'generic-function)
(loop for method in (sb-mop::generic-function-methods
fun)
for source = (find-definition-source method)
when source collect source)))
when source collect source)))))
((:setf-expander)
(when (and (consp name)
(eq (car name) 'setf))
Expand Down
3 changes: 3 additions & 0 deletions contrib/sb-introspect/test-driver.lisp
Expand Up @@ -68,6 +68,9 @@
(assert (matchp-name :method-combination 'cl-user::r 26))
(assert (matchp-name :setf-expander 'cl-user::s 27))

(sb-profile:profile cl-user::one)
(assert (matchp-name :function 'cl-user::one 2))
(sb-profile:unprofile cl-user::one)

;;; Unix success convention for exit codes
(sb-ext:quit :unix-status 0)
4 changes: 4 additions & 0 deletions tests/print.impure.lisp
Expand Up @@ -412,4 +412,8 @@

(assert (string= (eval '(format nil "~:C" #\a)) "a"))
(assert (string= (format nil (formatter "~:C") #\a) "a"))

;;; This used to trigger an AVER instead.
(assert (raises-error? (format t "~>") sb-format:format-error))

;;; success
2 changes: 1 addition & 1 deletion version.lisp-expr
Expand Up @@ -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.9.15.22"
"0.9.15.23"

0 comments on commit e15ca90

Please sign in to comment.