X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-sprof%2Fsb-sprof.lisp;h=0ce32097f6c6727f81fdab4f4dfc64c4a8c74b9b;hb=062283b901155792f65775491aea51481c56faaa;hp=dd1760c0d5164b8706208db6b6c9dbc73610c6ca;hpb=f7a78dd3554bd977b006e5da349a11d4e8463bb5;p=sbcl.git diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index dd1760c..0ce3209 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)))) @@ -354,7 +359,7 @@ on the depth of the call stack.") (defvar *sampling-mode* :cpu "Default sampling mode. :CPU for cpu profiling, :ALLOC for allocation -profiling") +profiling, and :TIME for wallclock profiling.") (declaim (type (member :cpu :alloc :time) *sampling-mode*)) (defvar *alloc-region-size* @@ -507,7 +512,9 @@ profiling") (defvar *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler")) (defvar *distribution-lock* (sb-thread:make-mutex :name "Wallclock profiling lock")) + #+sb-thread (declaim (inline pthread-kill)) + #+sb-thread (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, @@ -515,22 +522,21 @@ profiling") ;;; 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)) @@ -641,89 +647,103 @@ profiling") (max-samples '*max-samples*) (reset nil) (mode '*sampling-mode*) - (loop t) + (loop nil) (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. - 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. - :LOOP - If true (the default) repeatedly evaluate BODY. If false, evaluate - if only once." + 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 false (the default), evaluete BODY only once. If true repeatedly + evaluate BODY." (declare (type report-type report)) - `(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) - (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))) - (unless ,loop - (return)))) - (stop-profiling)) - ,@(when report-p `((report :type ,report))))) + (check-type loop boolean) + (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) @@ -792,7 +812,9 @@ The following keyword args are recognized: :mode mode)) (enable-call-counting) (setf *profiled-threads* threads) - (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler) + (sb-sys:enable-interrupt sb-unix:sigprof + #'sigprof-handler + :synchronous t) (ecase mode (:alloc (let ((alloc-signal (1- alloc-interval))) @@ -865,9 +887,7 @@ The following keyword args are recognized: (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) name))) @@ -1407,6 +1427,23 @@ functions during statistical profiling." (with-profiling (:reset t :max-samples 1000 :report :graph) (test-0 7))) +(defun consalot () + (let ((junk '())) + (loop repeat 10000 do + (push (make-array 10) junk)) + junk)) + +(defun consing-test () + ;; 0.0001 chosen so that it breaks rather reliably when sprof does not + ;; respect pseudo atomic. + (with-profiling (:reset t :sample-interval 0.0001 :report :graph :loop nil) + (let ((target (+ (get-universal-time) 15))) + (princ #\.) + (force-output) + (loop + while (< (get-universal-time) target) + do (consalot))))) + ;;; provision (provide 'sb-sprof)