external/lift.darcs/_darcs/pristine/dev/measuring.lisp

   1 (in-package #:lift)
   2
   3 (eval-when (:compile-toplevel)
   4   (declaim (optimize (speed 3) (safety 1))))
   5
   6 (defmacro with-measuring ((var measure-fn) &body body)
   7   (let ((initial (gensym)))
   8     `(let ((,initial (,measure-fn)))
   9        ,@body
  10        (setf ,var (- (,measure-fn) ,initial)))))
  11
  12 (defmacro measure-time ((var) &body body)
  13   `(prog1
  14        (with-measuring (,var get-internal-real-time)
  15          ,@body)
  16      (setf ,var (coerce (/ ,var internal-time-units-per-second)
  17                         'double-float))))
  18
  19 (defmacro measure-conses ((var) &body body)
  20   `(with-measuring (,var total-bytes-allocated)
  21      ,@body))
  22
  23 (defun measure-fn (fn &rest args)
  24   (declare (dynamic-extent args))
  25   (let ((bytes 0) (seconds 0) result)
  26     (measure-time (seconds)
  27       (measure-conses (bytes)
  28         (setf result (apply fn args))))
  29     (values seconds bytes result)))
  30
  31 (defmacro measure (seconds bytes &body body)
  32   (let ((result (gensym)))
  33     `(let (,result)
  34        (measure-time (,seconds)
  35          (measure-conses (,bytes)
  36            (setf ,result (progn ,@body))))
  37        (values ,result))))
  38
  39 (defmacro measure-time-and-conses (&body body)
  40   (let ((seconds (gensym))
  41         (conses (gensym))
  42         (results (gensym)))
  43     `(let ((,seconds 0) (,conses 0) ,results)
  44        (setf ,results (multiple-value-list
  45                             (measure ,seconds ,conses ,@body)))
  46        (values-list (nconc (list ,seconds ,conses)
  47                            ,results)))))
  48
  49 #+(or)
  50 ;; tries to handle multiple values (but fails since measure doesn't)
  51 (defmacro measure-time-and-conses (&body body)
  52   (let ((seconds (gensym))
  53         (conses (gensym)))
  54     `(let ((,seconds 0) (,conses 0))
  55        (values-list (nconc (multiple-value-list
  56                             (measure ,seconds ,conses ,@body))
  57                            (list ,seconds ,conses))))))
  58
  59 (defvar *profile-extra* nil)
  60
  61 (defparameter *benchmark-log-path*
  62   (asdf:system-relative-pathname
  63    'lift "benchmark-data/benchmarks.log"))
  64
  65 (defvar *count-calls-p* nil)
  66
  67 (defvar *additional-markers* nil)
  68
  69 (defvar *profiling-threshold* nil)
  70
  71 (defmacro with-profile-report
  72     ((name style &key (log-name *benchmark-log-path* ln-supplied?)
  73            (count-calls-p *count-calls-p* ccp-supplied?)
  74            (timeout nil timeout-supplied?))
  75      &body body)
  76   `(with-profile-report-fn
  77        ,name ,style
  78        (lambda ()
  79          (progn ,@body))
  80        ,@(when ccp-supplied?
  81                `(:count-calls-p ,count-calls-p))
  82        ,@(when ln-supplied?
  83                `(:log-name ,log-name))
  84        ,@(when timeout-supplied?
  85                `(:timeout ,timeout))))
  86
  87 #+allegro
  88 (defun cancel-current-profile (&key force?)
  89   (when (prof::current-profile-actual prof::*current-profile*)
  90     (unless force?
  91       (assert (member (prof:profiler-status) '(:inactive))))
  92     (prof:stop-profiler)
  93     (setf prof::*current-profile* (prof::make-current-profile))))
  94
  95 #+allegro
  96 (defun current-profile-sample-count ()
  97    (ecase (prof::profiler-status :verbose nil)
  98     ((:inactive :analyzed) 0)
  99     ((:suspended :saved)
 100      (slot-value (prof::current-profile-actual prof::*current-profile*)
 101                  'prof::samples))
 102     (:sampling (warn "Can't determine count while sampling"))))
 103
 104 #|
 105 (prof:with-profiling ...
 106 different reports
 107 |#
 108
 109 #+allegro
 110 (defun with-profile-report-fn
 111     (name style fn &key (log-name *benchmark-log-path*)
 112                                (count-calls-p *count-calls-p*)
 113                                (timeout nil))
 114   (assert (member style '(:time :space :count-only)))
 115   (cancel-current-profile :force? t)
 116   (let* ((seconds 0.0) (conses 0)
 117          results)
 118     (unwind-protect
 119          (handler-case
 120              (with-timeout (timeout)
 121                (setf results
 122                      (multiple-value-list
 123                       (prof:with-profiling (:type style :count count-calls-p)
 124                         (measure seconds conses (funcall fn))))))
 125            (timeout-error
 126                (c)
 127              (declare (ignore c))))
 128       ;; cleanup / ensure we get report
 129       (ensure-directories-exist log-name)
 130       ;;log
 131       (with-open-file (output log-name
 132                               :direction :output
 133                               :if-does-not-exist :create
 134                               :if-exists :append)
 135         (with-standard-io-syntax
 136           (let ((*print-readably* nil))
 137             (terpri output)
 138             (format output "\(~11,d ~20,s ~10,s ~10,s ~{~s~^ ~} ~s ~s\)"
 139                     (date-stamp :include-time? t) name
 140                     seconds conses *additional-markers*
 141                     results (current-profile-sample-count)))))
 142       (when (> (current-profile-sample-count) 0)
 143         (let ((pathname (unique-filename
 144                          (merge-pathnames
 145                           (make-pathname
 146                            :type "prof"
 147                            :name (format nil "~a-~a-" name style))
 148                           log-name))))
 149           (let ((prof:*significance-threshold*
 150                  (or *profiling-threshold* 0.01)))
 151             (format t "~&Profiling output being sent to ~a" pathname)
 152             (with-open-file (output pathname
 153                                     :direction :output
 154                                     :if-does-not-exist :create
 155                                     :if-exists :append)
 156               (format output "~&Profile data for ~a" name)
 157               (format output "~&Date: ~a"
 158                       (excl:locale-print-time (get-universal-time)
 159                                               :fmt "%B %d, %Y %T" :stream nil))
 160               (format output "~&  Total time: ~,2F; Total space: ~:d \(~:*~d\)"
 161                       seconds conses)
 162               (format output "~%~%")
 163               (when (or (eq :time style)
 164                         (eq :space style))
 165                 (prof:show-flat-profile :stream output)
 166                 (prof:show-call-graph :stream output)
 167                 (when count-calls-p
 168                   (format output "~%~%Call counts~%")
 169                   (let ((*standard-output* output))
 170                     (prof:show-call-counts))))
 171               (when *profile-extra*
 172                 (loop for thing in *profile-extra* do
 173                      (format output "~%~%")
 174                      (let ((*standard-output* output))
 175                        (prof:disassemble-profile thing)))))))))
 176     (values-list results)))
 177
 178 (defmacro while-counting-repetitions ((period) &body body)
 179   "Returns the count of the number of times `body` was executed during
 180 `period` seconds."
 181   (let ((gevent-count (gensym "count")))
 182     `(let ((,gevent-count 0))
 183        (declare (type fixnum ,gevent-count))
 184        (handler-case
 185            (with-timeout (,period)
 186              (loop
 187                 (progn ,@body)
 188                 (incf ,gevent-count)))
 189          (timeout-error (c)
 190            (declare (ignore c))
 191            ,gevent-count)))))
 192
 193 (defun count-repetitions (fn period &rest args)
 194   (declare (dynamic-extent args))
 195   (let ((event-count 0))
 196     (handler-case
 197         (with-timeout (period)
 198           (loop
 199              (apply #'funcall fn args)
 200              (incf event-count)))
 201       (timeout-error (c)
 202         (declare (ignore c))
 203         event-count))))