dev/periodic-profiling.lisp

   1 (in-package #:lift)
   2
   3 (defvar *periodic-profilers* (make-hash-table))
   4
   5 (defstruct (periodic-profiler (:conc-name periodic-profiler-)
   6                               (:print-object print-periodic-profiler))
   7   function
   8   period
   9   (profile-style :time)
  10   (report-name nil)
  11   (last-active 0)
  12   (last-profile-style nil))
  13
  14 (defun print-periodic-profiler (object stream)
  15   (print-unreadable-object (object stream :type t :identity t)
  16     (format stream "~a every ~a"
  17             (periodic-profiler-function object)
  18             (periodic-profiler-period object))))
  19
  20 (excl:def-fwrapper profile-this-periodically (&rest args)
  21   (declare (ignorable args)
  22            (dynamic-extent args))
  23   (let* ((spot (%find-periodic-profile-spot excl::primary-function))
  24          (pp (first spot)))
  25     (if (> (- (get-universal-time) (periodic-profiler-last-active pp))
  26            (periodic-profiler-period pp))
  27         (let* ((style (periodic-profiler-profile-style pp)))
  28           (setf (periodic-profiler-last-profile-style pp)
  29                 (if (eq style :alternating)
  30                     (case (periodic-profiler-last-profile-style pp)
  31                       (:time :space)
  32                       ((:space nil) :time))
  33                     style))
  34           (with-profile-report
  35               ((periodic-profiler-report-name pp)
  36                (periodic-profiler-last-profile-style pp))
  37             (excl:call-next-fwrapper))
  38           (setf (periodic-profiler-last-active pp) (get-universal-time)))
  39         (excl:call-next-fwrapper))))
  40
  41 (defun start-periodic-profiling (report-name function &key (period 10)
  42                                  (profile-style :time))
  43   (assert (find profile-style '(:time :space :alternating)))
  44   (let ((spot (%find-periodic-profile-spot function)))
  45     (setf (first spot) (make-periodic-profiler
  46                         :report-name report-name
  47                         :function function
  48                         :period period
  49                         :profile-style profile-style)
  50           (second spot) t)
  51     (excl:fwrap function
  52                 :periodic-profiler 'profile-this-periodically)))
  53
  54 (defun stop-periodic-profiling (function)
  55   (setf (second (%find-periodic-profile-spot function)) nil)
  56   (excl:funwrap function :periodic-profiler))
  57
  58 (defun %find-periodic-profile-spot (function)
  59   (setf function (coerce function 'function))
  60   (multiple-value-bind (spot found?)
  61       (gethash function *periodic-profilers*)
  62     (if found?
  63         spot
  64         (setf (gethash function *periodic-profilers*)
  65               (list 0 nil)))))
  66
  67 (defun periodic-profilers ()
  68   (let ((result nil))
  69     (maphash (lambda (k v)
  70                (declare (ignore k))
  71                (when (and (consp v) (second v))
  72                  (let ((pp (first v)))
  73                    (push (list (periodic-profiler-function pp)
  74                                (periodic-profiler-period pp)
  75                                (periodic-profiler-profile-style pp))
  76                          result))))
  77              *periodic-profilers*)
  78     result))
  79
  80 #|
  81
  82 (periodic-profilers)
  83
  84 (defun test-pp ()
  85   (let ((x nil))
  86     (while-counting-events (0.5)
  87       (loop for i from 0 do (setf x i)))
  88     x))
  89
  90 (test-pp)
  91
  92 (with-profile-report ('test-pp :time) (test-pp))
  93
  94
  95 (start-periodic-profiling
  96  'test-pp 'test-pp :period 1.5 :profile-style :alternating)
  97
  98 (stop-periodic-profiling
  99  'test-pp)
 100
 101 (loop repeat 20
 102      for i from 0 do
 103      (print i)
 104      (test-pp))
 105
 106 |#