X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-sprof%2Fsb-sprof.lisp;h=ab1edf2c75a4a8da9860d02882ce3e269e1f7b43;hb=ba12c5c0420f28250ef4931b47af92c6d7963195;hp=6d4af4534719b582acbe2f287fe2548d8955e83e;hpb=8e7fa9c4b2c1fd2353414d726efad1607f6badd1;p=sbcl.git diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index 6d4af45..ab1edf2 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -99,9 +99,11 @@ (defpackage #:sb-sprof (:use #:cl #:sb-ext #:sb-unix #:sb-alien #:sb-sys) - (:export #:*sample-interval* #:*max-samples* + (:export #:*sample-interval* #:*max-samples* #:*alloc-interval* + #:*report-sort-by* #:*report-sort-order* #:start-sampling #:stop-sampling #:with-sampling #:with-profiling #:start-profiling #:stop-profiling + #:profile-call-counts #:unprofile-call-counts #:reset #:report)) (in-package #:sb-sprof) @@ -244,12 +246,17 @@ ;;; structures. (defstruct (call-graph (:include graph) (:constructor %make-call-graph)) - ;; the value of *Sample-Interval* at the time the graph was created + ;; the value of *SAMPLE-INTERVAL* or *ALLOC-INTERVAL* at the time + ;; the graph was created (depending on the current allocation mode) (sample-interval (sb-impl::missing-arg) :type number) + ;; the sampling-mode that was used for the profiling run + (sampling-mode (sb-impl::missing-arg) :type (member :cpu :alloc :time)) ;; number of samples taken - (nsamples (sb-impl::missing-arg) :type sb-impl::index) + (nsamples (sb-impl::missing-arg) :type sb-int:index) + ;; threads that have been sampled + (sampled-threads nil :type list) ;; sample count for samples not in any function - (elsewhere-count (sb-impl::missing-arg) :type sb-impl::index) + (elsewhere-count (sb-impl::missing-arg) :type sb-int:index) ;; a flat list of NODEs, sorted by sample count (flat-nodes () :type list)) @@ -262,17 +269,25 @@ ;; gets label 1. This is just for identification purposes in the ;; profiling report. (index 0 :type fixnum) - ;; start and end address of the function's code - (start-pc 0 :type address) - (end-pc 0 :type address) + ;; Start and end address of the function's code. Depending on the + ;; debug-info, this might be either as absolute addresses for things + ;; that won't move around in memory, or as relative offsets from + ;; some point for things that might move. + (start-pc-or-offset 0 :type address) + (end-pc-or-offset 0 :type address) ;; the name of the function (name nil :type t) ;; sample count for this function (count 0 :type fixnum) ;; count including time spent in functions called from this one (accrued-count 0 :type fixnum) + ;; the debug-info that this node was created from + (debug-info nil :type t) ;; list of NODEs for functions calling this one - (callers () :type list)) + (callers () :type list) + ;; the call count for the function that corresponds to this node (or NIL + ;; if call counting wasn't enabled for this function) + (call-count nil :type (or null integer))) ;;; A cycle in a call graph. The functions forming the cycle are ;;; found in the SCC-VERTICES slot of the VERTEX structure. @@ -283,18 +298,43 @@ (defstruct (call (:include edge) (:constructor make-call (vertex))) ;; number of times the call was sampled - (count 1 :type sb-impl::index)) - -;;; Info about a function in dynamic-space. This is used to track -;;; address changes of functions during GC. -(defstruct (dyninfo (:constructor make-dyninfo (code start end))) - ;; component this info is for - (code (sb-impl::missing-arg) :type sb-kernel::code-component) - ;; current start and end address of the component - (start (sb-impl::missing-arg) :type address) - (end (sb-impl::missing-arg) :type address) - ;; new start address of the component, after GC. - (new-start 0 :type address)) + (count 1 :type sb-int:index)) + +(defvar *sample-interval* 0.01 + "Default number of seconds between samples.") +(declaim (type number *sample-interval*)) + +(defvar *alloc-interval* 4 + "Default number of allocation region openings between samples.") +(declaim (type number *alloc-interval*)) + +(defvar *max-samples* 50000 + "Default number of traces taken. This variable is somewhat misnamed: +each trace may actually consist of an arbitrary number of samples, depending +on the depth of the call stack.") +(declaim (type sb-int:index *max-samples*)) + +;;; Encapsulate all the information about a sampling run +(defstruct (samples) + ;; When this vector fills up, we allocate a new one and copy over + ;; the old contents. + (vector (make-array (* *max-samples* + ;; Arbitrary guess at how many samples we'll be + ;; taking for each trace. The exact amount doesn't + ;; matter, this is just to decrease the amount of + ;; re-allocation that will need to be done. + 10 + ;; Each sample takes two cells in the vector + 2)) + :type simple-vector) + (trace-count 0 :type sb-int:index) + (index 0 :type sb-int:index) + (mode nil :type (member :cpu :alloc :time)) + (sample-interval (sb-int:missing-arg) :type number) + (alloc-interval (sb-int:missing-arg) :type number) + (max-depth most-positive-fixnum :type number) + (max-samples (sb-int:missing-arg) :type sb-int:index) + (sampled-threads nil :type list)) (defmethod print-object ((call-graph call-graph) stream) (print-unreadable-object (call-graph stream :type t :identity t) @@ -312,39 +352,33 @@ (deftype report-type () '(member nil :flat :graph)) -(defvar *sample-interval* 0.01 - "Default number of seconds between samples.") -(declaim (number *sample-interval*)) - -(defvar *max-samples* 50000 - "Default number of samples taken.") -(declaim (type sb-impl::index *max-samples*)) - -;; For every profiler event we store this many samples (frames 0-n on -;; the call stack). -(defconstant +sample-depth+ - #+(or x86 x86-64) 8 - #-(or x86 x86-64) 2) +(defvar *sampling-mode* :cpu + "Default sampling mode. :CPU for cpu profiling, :ALLOC for allocation +profiling") +(declaim (type (member :cpu :alloc :time) *sampling-mode*)) -;; We store two elements for each sample. The debug-info of the sample -;; and either its absolute PC or a PC offset, depending on the type of -;; the debug-info. -(defconstant +sample-size+ (* +sample-depth+ 2)) +(defvar *alloc-region-size* + #-gencgc + (get-page-size) + #+gencgc + (max sb-vm:gencgc-alloc-granularity sb-vm:gencgc-card-bytes)) +(declaim (type number *alloc-region-size*)) (defvar *samples* nil) -(declaim (type (or null simple-vector) *samples*)) - -(defvar *samples-index* 0) -(declaim (type sb-impl::index *samples-index*)) +(declaim (type (or null samples) *samples*)) (defvar *profiling* nil) +(declaim (type (member nil :alloc :cpu :time) *profiling*)) (defvar *sampling* nil) -(declaim (type boolean *profiling* *sampling*)) +(declaim (type boolean *sampling*)) (defvar *show-progress* nil) (defvar *old-sampling* nil) +;; Call count encapsulation information +(defvar *encapsulations* (make-hash-table :test 'equal)) + (defun turn-off-sampling () (setq *old-sampling* *sampling*) (setq *sampling* nil)) @@ -367,13 +401,15 @@ (defmacro with-sampling ((&optional (on t)) &body body) "Evaluate body with statistical sampling turned on or off." - `(let ((*sampling* ,on)) + `(let ((*sampling* ,on) + (sb-vm:*alloc-signal* sb-vm:*alloc-signal*)) ,@body)) ;;; Return something serving as debug info for address PC. (declaim (inline debug-info)) (defun debug-info (pc) - (declare (type system-area-pointer pc)) + (declare (type system-area-pointer pc) + (muffle-conditions compiler-note)) (let ((ptr (sb-di::component-ptr-from-pc pc))) (cond ((sap= ptr (int-sap 0)) (let ((name (sap-foreign-symbol pc))) @@ -400,56 +436,169 @@ (t (values nil 0)))))))) +(defun ensure-samples-vector (samples) + (let ((vector (samples-vector samples)) + (index (samples-index samples))) + ;; Allocate a new sample vector if the old one is full + (if (= (length vector) index) + (let ((new-vector (make-array (* 2 index)))) + (format *trace-output* "Profiler sample vector full (~a traces / ~a samples), doubling the size~%" + (samples-trace-count samples) + (truncate index 2)) + (replace new-vector vector) + (setf (samples-vector samples) new-vector)) + vector))) + (declaim (inline record)) -(defun record (pc) - (declare (type system-area-pointer pc)) +(defun record (samples pc) + (declare (type system-area-pointer pc) + (muffle-conditions compiler-note)) (multiple-value-bind (info pc-or-offset) (debug-info pc) - ;; For each sample, store the debug-info and the PC/offset into - ;; adjacent cells. - (setf (aref *samples* *samples-index*) info - (aref *samples* (1+ *samples-index*)) pc-or-offset)) - (incf *samples-index* 2)) + (let ((vector (ensure-samples-vector samples)) + (index (samples-index samples))) + (declare (type simple-vector vector)) + ;; Allocate a new sample vector if the old one is full + (when (= (length vector) index) + (let ((new-vector (make-array (* 2 index)))) + (format *trace-output* "Profiler sample vector full (~a traces / ~a samples), doubling the size~%" + (samples-trace-count samples) + (truncate index 2)) + (replace new-vector vector) + (setf vector new-vector + (samples-vector samples) new-vector))) + ;; For each sample, store the debug-info and the PC/offset into + ;; adjacent cells. + (setf (aref vector index) info + (aref vector (1+ index)) pc-or-offset))) + (incf (samples-index samples) 2)) + +(defun record-trace-start (samples) + ;; Mark the start of the trace. + (let ((vector (ensure-samples-vector samples))) + (declare (type simple-vector vector)) + (setf (aref vector (samples-index samples)) + 'trace-start)) + (incf (samples-index samples) 2)) + +;;; List of thread currently profiled, or :ALL for all threads. +(defvar *profiled-threads* nil) +(declaim (type (or list (member :all)) *profiled-threads*)) + +;;; Thread which runs the wallclock timers, if any. +(defvar *timer-thread* nil) + +(defun profiled-threads () + (let ((profiled-threads *profiled-threads*)) + (remove *timer-thread* + (if (eq :all profiled-threads) + (sb-thread:list-all-threads) + profiled-threads)))) + +(defun profiled-thread-p (thread) + (let ((profiled-threads *profiled-threads*)) + (or (and (eq :all profiled-threads) + (not (eq *timer-thread* thread))) + (member thread profiled-threads :test #'eq)))) -;;; Ensure that only one thread at a time will be executing sigprof handler. -(defvar *sigprof-handler-lock* (sb-thread:make-mutex :name "SIGPROF handler")) - -;;; SIGPROF handler. Record current PC and return address in -;;; *SAMPLES*. #+(or x86 x86-64) -(defun sigprof-handler (signal code scp) - (declare (ignore signal code) - (optimize speed (space 0)) - (type system-area-pointer scp)) - (sb-sys:without-interrupts - (when (and *sampling* - *samples* - (< *samples-index* (length (the simple-vector *samples*)))) - (sb-sys:without-gcing - (sb-thread:with-mutex (*sigprof-handler-lock*) - (with-alien ((scp (* os-context-t) :local scp)) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))) - ;; For some reason completely bogus small values for the - ;; frame pointer are returned every now and then, leading - ;; to segfaults. Try to avoid these cases. - ;; - ;; FIXME: Do a more thorough sanity check on ebp, or figure - ;; out why this is happening. - ;; -- JES, 2005-01-11 - (when (< fp 4096) - (dotimes (i +sample-depth+) - (record (int-sap 0))) - (return-from sigprof-handler nil)) - (let ((fp (int-sap fp)) - (ok t)) - (declare (type system-area-pointer fp pc-ptr)) - (dotimes (i +sample-depth+) - (record pc-ptr) - (when ok - (setf (values ok pc-ptr fp) - (sb-di::x86-call-context fp))))))))))) - nil) +(progn + ;; Ensure that only one thread at a time will be doing profiling stuff. + (defvar *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler")) + (defvar *distribution-lock* (sb-thread:make-mutex :name "Wallclock profiling lock")) + + (declaim (inline pthread-kill)) + (define-alien-routine pthread-kill int (os-thread unsigned-long) (signal int)) + + ;;; A random thread will call this in response to either a timer firing, + ;;; This in turn will distribute the notice to those threads we are + ;;; interested using SIGPROF. + (defun thread-distribution-handler () + (declare (optimize sb-c::merge-tail-calls)) + (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))) + + (defun sigprof-handler (signal code scp) + (declare (ignore signal code) (optimize speed (space 0)) + (disable-package-locks sb-di::x86-call-context) + (muffle-conditions compiler-note) + (type system-area-pointer scp)) + (let ((self sb-thread:*current-thread*) + (profiling *profiling*)) + ;; Turn off allocation counter when it is not needed. Doing this in the + ;; signal handler means we don't have to worry about racing with the runtime + (unless (eq :alloc profiling) + (setf sb-vm::*alloc-signal* nil)) + (when (and *sampling* + ;; Normal SIGPROF gets practically speaking delivered to threads + ;; depending on the run time they use, so we need to filter + ;; out those we don't care about. For :ALLOC and :TIME profiling + ;; only the interesting threads get SIGPROF in the first place. + ;; + ;; ...except that Darwin at least doesn't seem to work like we + ;; would want it to, which makes multithreaded :CPU profiling pretty + ;; pointless there -- though it may be that our mach magic is + ;; partially to blame? + (or (not (eq :cpu profiling)) (profiled-thread-p self))) + (sb-thread::with-system-mutex (*profiler-lock* :without-gcing t) + (let ((samples *samples*)) + (when (and samples + (< (samples-trace-count samples) + (samples-max-samples samples))) + (with-alien ((scp (* os-context-t) :local scp)) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))) + ;; foreign code might not have a useful frame + ;; pointer in ebp/rbp, so make sure it looks + ;; reasonable before walking the stack + (unless (sb-di::control-stack-pointer-valid-p (sb-sys:int-sap fp)) + (record samples pc-ptr) + (return-from sigprof-handler nil)) + (incf (samples-trace-count samples)) + (pushnew self (samples-sampled-threads samples)) + (let ((fp (int-sap fp)) + (ok t)) + (declare (type system-area-pointer fp pc-ptr)) + ;; FIXME: How annoying. The XC doesn't store enough + ;; type information about SB-DI::X86-CALL-CONTEXT, + ;; even if we declaim the ftype explicitly in + ;; src/code/debug-int. And for some reason that type + ;; information is needed for the inlined version to + ;; be compiled without boxing the returned saps. So + ;; we declare the correct ftype here manually, even + ;; if the compiler should be able to deduce this + ;; exact same information. + (declare (ftype (function (system-area-pointer) + (values (member nil t) + system-area-pointer + system-area-pointer)) + sb-di::x86-call-context)) + (record-trace-start samples) + (dotimes (i (samples-max-depth samples)) + (record samples pc-ptr) + (setf (values ok pc-ptr fp) + (sb-di::x86-call-context fp)) + (unless ok + (return)))))) + ;; Reset thread-local allocation counter before interrupts + ;; are enabled. + (when (eq t sb-vm::*alloc-signal*) + (setf sb-vm:*alloc-signal* (1- (samples-alloc-interval samples))))))))) + nil)) ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper ;; than one level. @@ -457,18 +606,23 @@ (defun sigprof-handler (signal code scp) (declare (ignore signal code)) (sb-sys:without-interrupts - (when (and *sampling* - (< *samples-index* (length *samples*))) - (sb-sys:without-gcing - (with-alien ((scp (* os-context-t) :local scp)) - (locally (declare (optimize (inhibit-warnings 2))) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) - (ra (sap-ref-word - (int-sap fp) - (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) - (record pc-ptr) - (record (int-sap ra))))))))) + (let ((samples *samples*)) + (when (and *sampling* + samples + (< (samples-trace-count samples) + (samples-max-samples samples))) + (sb-sys:without-gcing + (with-alien ((scp (* os-context-t) :local scp)) + (locally (declare (optimize (inhibit-warnings 2))) + (incf (samples-trace-count samples)) + (record-trace-start samples) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) + (ra (sap-ref-word + (int-sap fp) + (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) + (record samples pc-ptr) + (record samples (int-sap ra)))))))))) ;;; Return the start address of CODE. (defun code-start (code) @@ -483,87 +637,219 @@ (values start end))) (defmacro with-profiling ((&key (sample-interval '*sample-interval*) + (alloc-interval '*alloc-interval*) (max-samples '*max-samples*) (reset nil) + (mode '*sampling-mode*) + (loop t) + (max-depth most-positive-fixnum) show-progress + (threads '(list sb-thread:*current-thread*)) (report nil report-p)) &body body) - "Repeatedly evaluate Body with statistical profiling turned on. + "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. + The following keyword args are recognized: - :Sample-Interval - Take a sample every seconds. Default is - *Sample-Interval*. + :SAMPLE-INTERVAL + Take a sample every seconds. Default is *SAMPLE-INTERVAL*. + + :ALLOC-INTERVAL + Take a sample every time allocation regions (approximately + 8kB) have been allocated since the last sample. Default is + *ALLOC-INTERVAL*. - :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-SAMPLES Repeat evaluating body until samples are taken. - Default is *Max-Samples*. + Default is *MAX-SAMPLES*. + + :MAX-DEPTH + Maximum call stack depth that the profiler should consider. Only + has an effect on x86 and x86-64. + + :REPORT + If specified, call REPORT with :TYPE at the end. + + :RESET + It true, call RESET at the beginning. + + :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.) - :Report - If specified, call Report with :Type at the end. + :THREADS has no effect on call-counting at the moment. - :Reset - It true, call Reset at the beginning." + 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. + + :LOOP + If true (the default) repeatedly evaluate BODY. If false, evaluate + if only once." (declare (type report-type report)) - `(let ((*sample-interval* ,sample-interval) - (*max-samples* ,max-samples)) + `(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) + (start-profiling :max-depth ,max-depth :threads ,threads) (loop - (when (>= *samples-index* (length *samples*)) + (when (>= (samples-trace-count *samples*) + (samples-max-samples *samples*)) (return)) ,@(when show-progress `((format t "~&===> ~d of ~d samples taken.~%" - (/ *samples-index* +sample-size+) - *max-samples*))) - (let ((.last-index. *samples-index*)) + (samples-trace-count *samples*) + (samples-max-samples *samples*)))) + (let ((.last-index. (samples-index *samples*))) ,@body - (when (= .last-index. *samples-index*) + (when (= .last-index. (samples-index *samples*)) (warn "No sampling progress; possibly a profiler bug.") - (return))))) + (return))) + (unless ,loop + (return)))) (stop-profiling)) ,@(when report-p `((report :type ,report))))) +(defvar *timer* nil) + +(defvar *old-alloc-interval* nil) +(defvar *old-sample-interval* nil) + (defun start-profiling (&key (max-samples *max-samples*) + (mode *sampling-mode*) (sample-interval *sample-interval*) + (alloc-interval *alloc-interval*) + (max-depth most-positive-fixnum) + (threads :all) (sampling t)) - "Start profiling statistically if not already profiling. - The following keyword args are recognized: + "Start profiling statistically in the current thread if not already profiling. +The following keyword args are recognized: + + :SAMPLE-INTERVAL + Take a sample every seconds. Default is *SAMPLE-INTERVAL*. - :Sample-Interval - Take a sample every seconds. Default is - *Sample-Interval*. + :ALLOC-INTERVAL + Take a sample every time allocation regions (approximately + 8kB) have been allocated since the last sample. Default is + *ALLOC-INTERVAL*. - :Max-Samples - Maximum number of samples. 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. - :Sampling + :MAX-SAMPLES + Maximum number of samples. Default is *MAX-SAMPLES*. + + :MAX-DEPTH + Maximum call stack depth that the profiler should consider. Only + has an effect on x86 and x86-64. + + :THREADS + List threads to profile, or :ALL to indicate that all threads should be + profiled. Defaults to :ALL. (Note: WITH-PROFILING defaults to the current + thread.) + + :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. + + :SAMPLING If true, the default, start sampling right away. - If false, Start-Sampling can be used to turn sampling on." + If false, START-SAMPLING can be used to turn sampling on." + #-gencgc + (when (eq mode :alloc) + (error "Allocation profiling is only supported for builds using the generational garbage collector.")) (unless *profiling* (multiple-value-bind (secs usecs) (multiple-value-bind (secs rest) (truncate sample-interval) (values secs (truncate (* rest 1000000)))) - (setq *samples* (make-array (* max-samples +sample-size+))) - (setq *samples-index* 0) - (setq *sampling* sampling) + (setf *sampling* sampling + *samples* (make-samples :max-depth max-depth + :max-samples max-samples + :sample-interval sample-interval + :alloc-interval alloc-interval + :mode mode)) + (enable-call-counting) + (setf *profiled-threads* threads) (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler) - (unix-setitimer :profile secs usecs secs usecs) - (setq *profiling* t))) + (ecase mode + (:alloc + (let ((alloc-signal (1- alloc-interval))) + #+sb-thread + (progn + (when (eq :all threads) + ;; Set the value new threads inherit. + (sb-thread::with-all-threads-lock + (setf sb-thread::*default-alloc-signal* alloc-signal))) + ;; Turn on allocation profiling in existing threads. + (dolist (thread (profiled-threads)) + (sb-thread::%set-symbol-value-in-thread 'sb-vm::*alloc-signal* thread alloc-signal))) + #-sb-thread + (setf sb-vm:*alloc-signal* alloc-signal))) + (:cpu + (unix-setitimer :profile secs usecs secs usecs)) + (:time + #+sb-thread + (let ((setup (sb-thread:make-semaphore :name "Timer thread setup semaphore"))) + (setf *timer-thread* + (sb-thread:make-thread (lambda () + (sb-thread:wait-on-semaphore setup) + (loop while (eq sb-thread:*current-thread* *timer-thread*) + do (sleep 1.0))) + :name "SB-SPROF wallclock timer thread")) + (sb-thread:signal-semaphore setup)) + #-sb-thread + (setf *timer-thread* nil) + (setf *timer* (make-timer #'thread-distribution-handler :name "SB-PROF wallclock timer" + :thread *timer-thread*)) + (schedule-timer *timer* sample-interval :repeat-interval sample-interval))) + (setq *profiling* mode))) (values)) (defun stop-profiling () "Stop profiling if profiling." - (when *profiling* - (unix-setitimer :profile 0 0 0 0) - ;; Even with the timer shut down we cannot be sure that there is - ;; no undelivered sigprof. Besides, leaving the signal handler - ;; installed won't hurt. - (setq *sampling* nil) - (setq *profiling* nil)) + (let ((profiling *profiling*)) + (when profiling + ;; Even with the timers shut down we cannot be sure that there is no + ;; undelivered sigprof. The handler is also responsible for turning the + ;; *ALLOC-SIGNAL* off in individual threads. + (ecase profiling + (:alloc + #+sb-thread + (setf sb-thread::*default-alloc-signal* nil) + #-sb-thread + (setf sb-vm:*alloc-signal* nil)) + (:cpu + (unix-setitimer :profile 0 0 0 0)) + (:time + (unschedule-timer *timer*) + (setf *timer* nil + *timer-thread* nil))) + (disable-call-counting) + (setf *profiling* nil + *sampling* nil + *profiled-threads* nil))) (values)) (defun reset () @@ -571,7 +857,6 @@ (stop-profiling) (setq *sampling* nil) (setq *samples* nil) - (setq *samples-index* 0) (values)) ;;; Make a NODE for debug-info INFO. @@ -580,6 +865,8 @@ (if (and (consp name) (member (first name) '(sb-c::xep sb-c::tl-xep sb-c::&more-processor + sb-c::varargs-entry + sb-c::top-level-form sb-c::hairy-arg-processor sb-c::&optional-processor))) (second name) @@ -588,9 +875,13 @@ (sb-kernel::code-component (multiple-value-bind (start end) (code-bounds info) - (%make-node :name (or (sb-disassem::find-assembler-routine start) - (format nil "~a" info)) - :start-pc start :end-pc end))) + (values + (%make-node :name (or (sb-disassem::find-assembler-routine start) + (format nil "~a" info)) + :debug-info info + :start-pc-or-offset start + :end-pc-or-offset end) + info))) (sb-di::compiled-debug-fun (let* ((name (sb-di::debug-fun-name info)) (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info)) @@ -602,13 +893,17 @@ ;; distinguish a gazillion different (LAMBDA ())'s. (when (equal name '(lambda ())) (setf name (format nil "Unknown component: #x~x" start-pc))) - (%make-node :name (clean-name name) - :start-pc (+ start-pc start-offset) - :end-pc (+ start-pc end-offset)))) + (values (%make-node :name (clean-name name) + :debug-info info + :start-pc-or-offset start-offset + :end-pc-or-offset end-offset) + component))) (sb-di::debug-fun - (%make-node :name (clean-name (sb-di::debug-fun-name info)))) + (%make-node :name (clean-name (sb-di::debug-fun-name info)) + :debug-info info)) (t - (%make-node :name (coerce info 'string)))))) + (%make-node :name (coerce info 'string) + :debug-info info))))) ;;; One function can have more than one COMPILED-DEBUG-FUNCTION with ;;; the same name. Reduce the number of calls to Debug-Info by first @@ -622,24 +917,32 @@ `(let ((*name->node* (make-hash-table :test 'equal))) ,@body)) -;;; Find or make a new node for address PC. Value is the NODE found -;;; or made; NIL if not enough information exists to make a NODE for -;;; PC. +;;; Find or make a new node for INFO. Value is the NODE found or +;;; made; NIL if not enough information exists to make a NODE for INFO. (defun lookup-node (info) (when info - (let* ((new (make-node info)) - (key (cons (node-name new) - (node-start-pc new))) - (found (gethash key *name->node*))) - (cond (found - (setf (node-start-pc found) - (min (node-start-pc found) (node-start-pc new))) - (setf (node-end-pc found) - (max (node-end-pc found) (node-end-pc new))) - found) - (t - (setf (gethash key *name->node*) new) - new))))) + (multiple-value-bind (new key) + (make-node info) + (when (eql (node-name new) 'call-counter) + (return-from lookup-node (values nil nil))) + (let* ((key (cons (node-name new) key)) + (found (gethash key *name->node*))) + (cond (found + (setf (node-start-pc-or-offset found) + (min (node-start-pc-or-offset found) + (node-start-pc-or-offset new))) + (setf (node-end-pc-or-offset found) + (max (node-end-pc-or-offset found) + (node-end-pc-or-offset new))) + found) + (t + (let ((call-count-info (gethash (node-name new) + *encapsulations*))) + (when call-count-info + (setf (node-call-count new) + (car call-count-info)))) + (setf (gethash key *name->node*) new) + new)))))) ;;; Return a list of all nodes created by LOOKUP-NODE. (defun collect-nodes () @@ -647,45 +950,53 @@ collect node)) ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*. -(defun make-call-graph-1 (depth) +(defun make-call-graph-1 (max-depth) (let ((elsewhere-count 0) visited-nodes) (with-lookup-tables () - (loop for i below (- *samples-index* 2) by 2 - for callee = (lookup-node (aref *samples* i)) - for caller = (lookup-node (aref *samples* (+ i 2))) - do - (when (and *show-progress* (plusp i)) - (cond ((zerop (mod i 1000)) - (show-progress "~d" i)) - ((zerop (mod i 100)) - (show-progress ".")))) - (when (< (mod i +sample-size+) depth) - (when (= (mod i +sample-size+) 0) - (setf visited-nodes nil) - (cond (callee - (incf (node-accrued-count callee)) - (incf (node-count callee))) - (t - (incf elsewhere-count)))) - (when callee - (push callee visited-nodes)) - (when caller - (unless (member caller visited-nodes) - (incf (node-accrued-count caller))) - (when callee - (let ((call (find callee (node-edges caller) - :key #'call-vertex))) - (pushnew caller (node-callers callee)) - (if call - (unless (member caller visited-nodes) - (incf (call-count call))) - (push (make-call callee) (node-edges caller)))))))) + (loop for i below (- (samples-index *samples*) 2) by 2 + with depth = 0 + for debug-info = (aref (samples-vector *samples*) i) + for next-info = (aref (samples-vector *samples*) + (+ i 2)) + do (if (eq debug-info 'trace-start) + (setf depth 0) + (let ((callee (lookup-node debug-info)) + (caller (unless (eq next-info 'trace-start) + (lookup-node next-info)))) + (when (< depth max-depth) + (when (zerop depth) + (setf visited-nodes nil) + (cond (callee + (incf (node-accrued-count callee)) + (incf (node-count callee))) + (t + (incf elsewhere-count)))) + (incf depth) + (when callee + (push callee visited-nodes)) + (when caller + (unless (member caller visited-nodes) + (incf (node-accrued-count caller))) + (when callee + (let ((call (find callee (node-edges caller) + :key #'call-vertex))) + (pushnew caller (node-callers callee)) + (if call + (unless (member caller visited-nodes) + (incf (call-count call))) + (push (make-call callee) + (node-edges caller)))))))))) (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count))) (loop for node in sorted-nodes and i from 1 do - (setf (node-index node) i)) - (%make-call-graph :nsamples (/ *samples-index* +sample-size+) - :sample-interval *sample-interval* + (setf (node-index node) i)) + (%make-call-graph :nsamples (samples-trace-count *samples*) + :sample-interval (if (eq (samples-mode *samples*) + :alloc) + (samples-alloc-interval *samples*) + (samples-sample-interval *samples*)) + :sampling-mode (samples-mode *samples*) + :sampled-threads (samples-sampled-threads *samples*) :elsewhere-count elsewhere-count :vertices sorted-nodes))))) @@ -720,16 +1031,18 @@ ;;; *SAMPLES*. The result contain a list of nodes sorted by self-time ;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles ;;; reduced to CYCLE structures. -(defun make-call-graph (depth) +(defun make-call-graph (max-depth) (stop-profiling) (show-progress "~&Computing call graph ") - (let ((call-graph (without-gcing (make-call-graph-1 depth)))) + (let ((call-graph (without-gcing (make-call-graph-1 max-depth)))) (setf (call-graph-flat-nodes call-graph) (copy-list (graph-vertices call-graph))) (show-progress "~&Finding cycles") + #+nil (reduce-call-graph call-graph) (show-progress "~&Propagating counts") - #+nil (compute-accrued-counts call-graph) + #+nil + (compute-accrued-counts call-graph) call-graph)) @@ -748,17 +1061,44 @@ (interval (call-graph-sample-interval call-graph)) (ncycles (loop for v in (graph-vertices call-graph) count (scc-p v)))) - (format t "~2&Number of samples: ~d~%~ - Sample interval: ~f seconds~%~ - Total sampling time: ~f seconds~%~ - Number of cycles: ~d~2%" - nsamples - interval - (* nsamples interval) - ncycles))) + (if (eq (call-graph-sampling-mode call-graph) :alloc) + (format t "~2&Number of samples: ~d~%~ + Alloc interval: ~a regions (approximately ~a kB)~%~ + Total sampling amount: ~a regions (approximately ~a kB)~%~ + Number of cycles: ~d~%~ + Sampled threads:~{~% ~S~}~2%" + nsamples + interval + (truncate (* interval *alloc-region-size*) 1024) + (* nsamples interval) + (truncate (* nsamples interval *alloc-region-size*) 1024) + ncycles + (call-graph-sampled-threads call-graph)) + (format t "~2&Number of samples: ~d~%~ + Sample interval: ~f seconds~%~ + Total sampling time: ~f seconds~%~ + Number of cycles: ~d~%~ + Sampled threads:~{~% ~S~}~2%" + nsamples + interval + (* nsamples interval) + ncycles + (call-graph-sampled-threads call-graph))))) + +(declaim (type (member :samples :cumulative-samples) *report-sort-by*)) +(defvar *report-sort-by* :samples + "Method for sorting the flat report: either by :SAMPLES or by :CUMULATIVE-SAMPLES.") + +(declaim (type (member :descending :ascending) *report-sort-order*)) +(defvar *report-sort-order* :descending + "Order for sorting the flat report: either :DESCENDING or :ASCENDING.") (defun print-flat (call-graph &key (stream *standard-output*) max - min-percent (print-header t)) + min-percent (print-header t) + (sort-by *report-sort-by*) + (sort-order *report-sort-order*)) + (declare (type (member :descending :ascending) sort-order) + (type (member :samples :cumulative-samples) sort-by)) (let ((*standard-output* stream) (*print-pretty* nil) (total-count 0) @@ -769,12 +1109,24 @@ 0))) (when print-header (print-call-graph-header call-graph)) - (format t "~& Self Cumul Total~%") - (format t "~& Nr Count % Count % Count % Function~%") + (format t "~& Self Total Cumul~%") + (format t "~& Nr Count % Count % Count % Calls Function~%") (print-separator) (let ((elsewhere-count (call-graph-elsewhere-count call-graph)) - (i 0)) - (dolist (node (call-graph-flat-nodes call-graph)) + (i 0) + (nodes (stable-sort (copy-list (call-graph-flat-nodes call-graph)) + (let ((cmp (if (eq :descending sort-order) #'> #'<))) + (multiple-value-bind (primary secondary) + (if (eq :samples sort-by) + (values #'node-count #'node-accrued-count) + (values #'node-accrued-count #'node-count)) + (lambda (x y) + (let ((cx (funcall primary x)) + (cy (funcall primary y))) + (if (= cx cy) + (funcall cmp (funcall secondary x) (funcall secondary y)) + (funcall cmp cx cy))))))))) + (dolist (node nodes) (when (or (and max (> (incf i) max)) (< (node-count node) min-count)) (return)) @@ -784,20 +1136,22 @@ (accrued-percent (samples-percent call-graph accrued-count))) (incf total-count count) (incf total-percent percent) - (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%" - (node-index node) + (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~8@a ~s~%" + (incf i) count percent accrued-count accrued-percent total-count total-percent + (or (node-call-count node) "-") (node-name node)) (finish-output))) (print-separator) - (format t "~& ~6d ~5,1f elsewhere~%" + (format t "~& ~6d ~5,1f~36a elsewhere~%" elsewhere-count - (samples-percent call-graph elsewhere-count))))) + (samples-percent call-graph elsewhere-count) + "")))) (defun print-cycles (call-graph) (when (some #'cycle-p (graph-vertices call-graph)) @@ -832,7 +1186,7 @@ (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" count percent indent name index))) (format t "~& Callers~%") - (format t "~& Cumul. Function~%") + (format t "~& Total. Function~%") (format t "~& Count % Count % Callees~%") (do-vertices (node call-graph) (print-separator) @@ -864,43 +1218,62 @@ :min-percent min-percent :print-header nil)))) (defun report (&key (type :graph) max min-percent call-graph + ((:sort-by *report-sort-by*) *report-sort-by*) + ((:sort-order *report-sort-order*) *report-sort-order*) (stream *standard-output*) ((:show-progress *show-progress*))) "Report statistical profiling results. The following keyword args are recognized: - :Type + :TYPE Specifies the type of report to generate. If :FLAT, show flat report, if :GRAPH show a call graph and a flat report. If nil, don't print out a report. - :Stream + :STREAM Specify a stream to print the report on. Default is - *Standard-Output*. + *STANDARD-OUTPUT*. - :Max + :MAX Don't show more than entries in the flat report. - :Min-Percent + :MIN-PERCENT Don't show functions taking less than of the total time in the flat report. - :Show-Progress + :SORT-BY + If :SAMPLES, sort flat report by number of samples taken. + If :CUMULATIVE-SAMPLES, sort flat report by cumulative number of samples + taken (shows how much time each function spent on stack.) Default + is *REPORT-SORT-BY*. + + :SORT-ORDER + If :DESCENDING, sort flat report in descending order. If :ASCENDING, + sort flat report in ascending order. Default is *REPORT-SORT-ORDER*. + + :SHOW-PROGRESS If true, print progress messages while generating the call graph. - :Call-Graph + :CALL-GRAPH Print a report from instead of the latest profiling results. - Value of this function is a Call-Graph object representing the - resulting call-graph." - (let ((graph (or call-graph (make-call-graph (1- +sample-depth+))))) - (ecase type - (:flat - (print-flat graph :stream stream :max max :min-percent min-percent)) - (:graph - (print-graph graph :stream stream :max max :min-percent min-percent)) - ((nil))) - graph)) +Value of this function is a CALL-GRAPH object representing the +resulting call-graph, or NIL if there are no samples (eg. right after +calling RESET.) + +Profiling is stopped before the call graph is generated." + (cond (*samples* + (let ((graph (or call-graph (make-call-graph most-positive-fixnum)))) + (ecase type + (:flat + (print-flat graph :stream stream :max max :min-percent min-percent)) + (:graph + (print-graph graph :stream stream :max max :min-percent min-percent)) + ((nil))) + graph)) + (t + (format stream "~&; No samples to report.~%") + nil))) ;;; Interface to DISASSEMBLE @@ -919,24 +1292,108 @@ (defun add-disassembly-profile-note (chunk stream dstate) (declare (ignore chunk stream)) - (unless (zerop *samples-index*) - (let* ((location - (+ (sb-disassem::seg-virtual-location - (sb-disassem:dstate-segment dstate)) - (sb-disassem::dstate-cur-offs dstate))) - (samples (loop for x from 0 below *samples-index* by +sample-size+ - for sample = (aref *samples* x) - for pc-or-offset = (aref *samples* (1+ x)) + (when *samples* + (let* ((location (+ (sb-disassem::seg-virtual-location + (sb-disassem:dstate-segment dstate)) + (sb-disassem::dstate-cur-offs dstate))) + (samples (loop with index = (samples-index *samples*) + for x from 0 below (- index 2) by 2 + for last-sample = nil then sample + for sample = (aref (samples-vector *samples*) x) + for pc-or-offset = (aref (samples-vector *samples*) + (1+ x)) + when (and sample (eq last-sample 'trace-start)) count (= location (sample-pc-from-pc-or-offset sample pc-or-offset))))) (unless (zerop samples) (sb-disassem::note (format nil "~A/~A samples" - samples (/ *samples-index* +sample-size+)) + samples (samples-trace-count *samples*)) dstate))))) (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*) + +;;;; Call counting + +;;; The following functions tell sb-sprof to do call count profiling +;;; for the named functions in addition to normal statistical +;;; profiling. The benefit of this over using SB-PROFILE is that this +;;; encapsulation is a lot more lightweight, due to not needing to +;;; track cpu usage / consing. (For example, compiling asdf 20 times +;;; took 13s normally, 15s with call counting for all functions in +;;; SB-C, and 94s with SB-PROFILE profiling SB-C). + +(defun profile-call-counts (&rest names) + "Mark the functions named by NAMES as being subject to call counting +during statistical profiling. If a string is used as a name, it will +be interpreted as a package name. In this case call counting will be +done for all functions with names like X or (SETF X), where X is a symbol +with the package as its home package." + (dolist (name names) + (if (stringp name) + (let ((package (find-package name))) + (do-symbols (symbol package) + (when (eql (symbol-package symbol) package) + (dolist (function-name (list symbol (list 'setf symbol))) + (profile-call-counts-for-function function-name))))) + (profile-call-counts-for-function name)))) + +(defun profile-call-counts-for-function (function-name) + (unless (gethash function-name *encapsulations*) + (setf (gethash function-name *encapsulations*) nil))) + +(defun unprofile-call-counts () + "Clear all call counting information. Call counting will be done for no +functions during statistical profiling." + (clrhash *encapsulations*)) + +;;; Called when profiling is started to enable the call counting +;;; encapsulation. Wrap all the call counted functions +(defun enable-call-counting () + (maphash (lambda (k v) + (declare (ignore v)) + (enable-call-counting-for-function k)) + *encapsulations*)) + +;;; Called when profiling is stopped to disable the encapsulation. Restore +;;; the original functions. +(defun disable-call-counting () + (maphash (lambda (k v) + (when v + (assert (cdr v)) + (without-package-locks + (setf (fdefinition k) (cdr v))) + (setf (cdr v) nil))) + *encapsulations*)) + +(defun enable-call-counting-for-function (function-name) + (let ((info (gethash function-name *encapsulations*))) + ;; We should never try to encapsulate an fdefn multiple times. + (assert (or (null info) + (null (cdr info)))) + (when (and (fboundp function-name) + (or (not (symbolp function-name)) + (and (not (special-operator-p function-name)) + (not (macro-function function-name))))) + (let* ((original-fun (fdefinition function-name)) + (info (cons 0 original-fun))) + (setf (gethash function-name *encapsulations*) info) + (without-package-locks + (setf (fdefinition function-name) + (sb-int:named-lambda call-counter (sb-int:&more more-context more-count) + (declare (optimize speed (safety 0))) + ;; 2^59 calls should be enough for anybody, and it + ;; allows using fixnum arithmetic on x86-64. 2^32 + ;; isn't enough, so we can't do that on 32 bit platforms. + (incf (the (unsigned-byte 59) + (car info))) + (multiple-value-call original-fun + (sb-c:%more-arg-values more-context + 0 + more-count))))))))) + + ;;; silly examples (defun test-0 (n &optional (depth 0))