From 09c00481c13d88f6694c7f8ba7222c5c62f39a9e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 3 Feb 2013 12:28:32 +0200 Subject: [PATCH] grab-bag of SB-SPROF improvements. (1) Thread distribution handler must not check *SAMPLING*, as it is thread-local. (2) Return the values from the final round when looping. (3) Better warning on no sampling process: list the reasons users can do something about. (4) Update WITH-PROFILING docstring to reflect reality. (5) When printing *SAMPLES*, don't print the array. --- NEWS | 4 + contrib/sb-sprof/sb-sprof.lisp | 180 ++++++++++++++++++++++------------------ 2 files changed, 102 insertions(+), 82 deletions(-) diff --git a/NEWS b/NEWS index d387fbc..616c7c4 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.4: + * minor incompatible change: SB-SPROF:WITH-PROFILING no longer loops + by default. * new feature: package local nicknames. See manual for details. * new feature: SB-EXT:MAP-DIRECTORY provides a powerful interface for directory traversal: it is the backend used by SBCL for CL:DIRECTORY. @@ -23,6 +25,8 @@ changes relative to sbcl-1.1.4: information is available in less intrusive form as frame annotations. * bug fix: deleting a package removes it from implementation-package lists of other packages. + * bug fix: SB-SPROF:WITH-PROFILING is now usable in the Slime REPL on Darwin. + This does not fix the occasional "interrupt already pending" issue, though. changes in sbcl-1.1.4 relative to sbcl-1.1.3: * optimization: LOOP expressions using "of-type character" have slightly diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index a9f6f05..5ce05aa 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -98,7 +98,7 @@ ;;; reliable? (defpackage #:sb-sprof - (:use #:cl #:sb-ext #:sb-unix #:sb-alien #:sb-sys) + (:use #:cl #:sb-ext #:sb-unix #:sb-alien #:sb-sys :sb-int) (:export #:*sample-interval* #:*max-samples* #:*alloc-interval* #:*report-sort-by* #:*report-sort-order* #:start-sampling #:stop-sampling #:with-sampling @@ -336,6 +336,11 @@ on the depth of the call stack.") (max-samples (sb-int:missing-arg) :type sb-int:index) (sampled-threads nil :type list)) +(defmethod print-object ((samples samples) stream) + (print-unreadable-object (samples stream :type t :identity t) + (let ((*print-array* nil)) + (call-next-method)))) + (defmethod print-object ((call-graph call-graph) stream) (print-unreadable-object (call-graph stream :type t :identity t) (format stream "~d samples" (call-graph-nsamples call-graph)))) @@ -517,22 +522,21 @@ profiling, and :TIME for wallclock profilgin.") ;;; interested using SIGPROF. (defun thread-distribution-handler () (declare (optimize speed (space 0))) - (when *sampling* - #+sb-thread - (let ((lock *distribution-lock*)) - ;; Don't flood the system with more interrupts if the last - ;; set is still being delivered. - (unless (sb-thread:mutex-value lock) - (sb-thread::with-system-mutex (lock) - (dolist (thread (profiled-threads)) - ;; This may occasionally fail to deliver the signal, but that - ;; seems better then using kill_thread_safely with it's 1 - ;; second backoff. - (let ((os-thread (sb-thread::thread-os-thread thread))) - (when os-thread - (pthread-kill os-thread sb-unix:sigprof))))))) - #-sb-thread - (unix-kill 0 sb-unix:sigprof))) + #+sb-thread + (let ((lock *distribution-lock*)) + ;; Don't flood the system with more interrupts if the last + ;; set is still being delivered. + (unless (sb-thread:mutex-value lock) + (sb-thread::with-system-mutex (lock) + (dolist (thread (profiled-threads)) + ;; This may occasionally fail to deliver the signal, but that + ;; seems better then using kill_thread_safely with it's 1 + ;; second backoff. + (let ((os-thread (sb-thread::thread-os-thread thread))) + (when os-thread + (pthread-kill os-thread sb-unix:sigprof))))))) + #-sb-thread + (unix-kill 0 sb-unix:sigprof)) (defun sigprof-handler (signal code scp) (declare (ignore signal code) (optimize speed (space 0)) @@ -649,85 +653,97 @@ profiling, and :TIME for wallclock profilgin.") (threads '(list sb-thread:*current-thread*)) (report nil report-p)) &body body) - "Repeatedly evaluate BODY with statistical profiling turned on. - In multi-threaded operation, only the thread in which WITH-PROFILING - was evaluated will be profiled by default. If you want to profile - multiple threads, invoke the profiler with START-PROFILING. + "Evaluate BODY with statistical profiling turned on. If LOOP is true, +loop around the BODY until a sufficient number of samples has been collected. +Returns the values from the last evaluation of BODY. - The following keyword args are recognized: +In multi-threaded operation, only the thread in which WITH-PROFILING was +evaluated will be profiled by default. If you want to profile multiple +threads, invoke the profiler with START-PROFILING. - :SAMPLE-INTERVAL - Take a sample every seconds. Default is *SAMPLE-INTERVAL*. +The following keyword args are recognized: - :ALLOC-INTERVAL - Take a sample every time allocation regions (approximately - 8kB) have been allocated since the last sample. Default is - *ALLOC-INTERVAL*. + :SAMPLE-INTERVAL + Take a sample every seconds. Default is *SAMPLE-INTERVAL*. - :MODE - If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run the - profiler in allocation profiling mode. If :TIME, run the profiler - in wallclock profiling mode. + :ALLOC-INTERVAL + Take a sample every time allocation regions (approximately + 8kB) have been allocated since the last sample. Default is + *ALLOC-INTERVAL*. - :MAX-SAMPLES - Repeat evaluating body until samples are taken. - Default is *MAX-SAMPLES*. + :MODE + If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run the + profiler in allocation profiling mode. If :TIME, run the profiler + in wallclock profiling mode. - :MAX-DEPTH - Maximum call stack depth that the profiler should consider. Only - has an effect on x86 and x86-64. + :MAX-SAMPLES + Repeat evaluating body until samples are taken. + Default is *MAX-SAMPLES*. - :REPORT - If specified, call REPORT with :TYPE at the end. + :MAX-DEPTH + Maximum call stack depth that the profiler should consider. Only + has an effect on x86 and x86-64. - :RESET - It true, call RESET at the beginning. + :REPORT + If specified, call REPORT with :TYPE at the end. - :THREADS - Form that evaluates to the list threads to profile, or :ALL to indicate - that all threads should be profiled. Defaults to the current - thread. (Note: START-PROFILING defaults to all threads.) + :RESET + It true, call RESET at the beginning. - :THREADS has no effect on call-counting at the moment. + :THREADS + Form that evaluates to the list threads to profile, or :ALL to indicate + that all threads should be profiled. Defaults to the current + thread. (Note: START-PROFILING defaults to all threads.) - On some platforms (eg. Darwin) the signals used by the profiler are - not properly delivered to threads in proportion to their CPU usage - when doing :CPU profiling. If you see empty call graphs, or are obviously - missing several samples from certain threads, you may be falling afoul - of this. + :THREADS has no effect on call-counting at the moment. + + On some platforms (eg. Darwin) the signals used by the profiler are + not properly delivered to threads in proportion to their CPU usage + when doing :CPU profiling. If you see empty call graphs, or are obviously + missing several samples from certain threads, you may be falling afoul + of this. In this case using :MODE :TIME is likely to work better. - :LOOP - If true (the default) repeatedly evaluate BODY. If false, evaluate - if only once." + :LOOP + If false (the default), evaluete BODY only once. If true repeatedly + evaluate BODY." (declare (type report-type report)) (check-type loop boolean) - `(let* ((*sample-interval* ,sample-interval) - (*alloc-interval* ,alloc-interval) - (*sampling* nil) - (*sampling-mode* ,mode) - (*max-samples* ,max-samples)) - ,@(when reset '((reset))) - (unwind-protect - (progn - (start-profiling :max-depth ,max-depth :threads ,threads) - ,(if loop - `(loop - (when (>= (samples-trace-count *samples*) - (samples-max-samples *samples*)) - (return)) - ,@(when show-progress - `((format t "~&===> ~d of ~d samples taken.~%" - (samples-trace-count *samples*) - (samples-max-samples *samples*)))) - (let ((.last-index. (samples-index *samples*))) - ,@body - (when (= .last-index. (samples-index *samples*)) - (warn "No sampling progress; possibly a profiler bug.") - (return)))) - `(progn - ,@body))) - (stop-profiling)) - ,@(when report-p `((report :type ,report))))) + (with-unique-names (values last-index oops) + `(let* ((*sample-interval* ,sample-interval) + (*alloc-interval* ,alloc-interval) + (*sampling* nil) + (*sampling-mode* ,mode) + (*max-samples* ,max-samples)) + ,@(when reset '((reset))) + (flet ((,oops () + (warn "~@"))) + (unwind-protect + (progn + (start-profiling :max-depth ,max-depth :threads ,threads) + ,(if loop + `(let (,values) + (loop + (when (>= (samples-trace-count *samples*) + (samples-max-samples *samples*)) + (return)) + ,@(when show-progress + `((format t "~&===> ~d of ~d samples taken.~%" + (samples-trace-count *samples*) + (samples-max-samples *samples*)))) + (let ((,last-index, (samples-index *samples*))) + (setf ,values (multiple-value-list (progn ,@body))) + (when (= ,last-index (samples-index *samples*)) + (,oops) + (return)))) + (values-list ,values)) + `(let ((,last-index (samples-index *samples*))) + (multiple-value-prog1 (progn ,@body) + (when (= ,last-index (samples-index *samples*)) + (,oops)))))) + (stop-profiling))) + ,@(when report-p `((report :type ,report)))))) (defvar *timer* nil) -- 1.7.10.4