+;;; Return something serving as debug info for address PC.
+(declaim (inline debug-info))
+(defun debug-info (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)))
+ (if name
+ (values (format nil "foreign function ~a" name)
+ (sap-int pc))
+ (values nil (sap-int pc)))))
+ (t
+ (let* ((code (sb-di::component-from-component-ptr ptr))
+ (code-header-len (* (sb-kernel:get-header-data code)
+ sb-vm:n-word-bytes))
+ (pc-offset (- (sap-int pc)
+ (- (sb-kernel:get-lisp-obj-address code)
+ sb-vm:other-pointer-lowtag)
+ code-header-len))
+ (df (sb-di::debug-fun-from-pc code pc-offset)))
+ (cond ((typep df 'sb-di::bogus-debug-fun)
+ (values code (sap-int pc)))
+ (df
+ ;; The code component might be moved by the GC. Store
+ ;; a PC offset, and reconstruct the data in
+ ;; SAMPLE-PC-FROM-PC-OR-OFFSET.
+ (values df pc-offset))
+ (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 (samples pc)
+ (declare (type system-area-pointer pc)
+ (muffle-conditions compiler-note))
+ (multiple-value-bind (info pc-or-offset)
+ (debug-info pc)
+ (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 T 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*))
+ (if (eq :all profiled-threads)
+ (remove *timer-thread* (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))))
+
+#+(or x86 x86-64)
+(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"))
+
+ (define-alien-routine pthread-kill int (signal int) (os-thread unsigned-long))
+
+ ;;; 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)))
+ ;; 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)
+ (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.
+#-(or x86 x86-64)