external/lift.darcs/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 (defparameter *benchmark-file*
  60   (asdf:system-relative-pathname
  61    'lift "benchmark-data/benchmarks.log"))
  62
  63 (defvar *collect-call-counts* nil)
  64
  65 (defvar *additional-markers* nil)
  66
  67 (defvar *profiling-threshold* nil)
  68
  69 #+allegro
  70 (defun cancel-current-profile (&key force?)
  71   (when (prof::current-profile-actual prof::*current-profile*)
  72     (unless force?
  73       (assert (member (prof:profiler-status) '(:inactive))))
  74     (prof:stop-profiler)
  75     (setf prof::*current-profile* (prof::make-current-profile))))
  76
  77 #+allegro
  78 (defun current-profile-sample-count ()
  79    (ecase (prof::profiler-status :verbose nil)
  80     ((:inactive :analyzed) 0)
  81     ((:suspended :saved)
  82      (slot-value (prof::current-profile-actual prof::*current-profile*)
  83                  'prof::samples))
  84     (:sampling (warn "Can't determine count while sampling"))))
  85
  86 ;; FIXME -- functionify this!
  87 #+allegro
  88 (defmacro with-profile-report ((name style &key (log-name *benchmark-file*)
  89                                      (call-counts-p *collect-call-counts*))
  90                                &body body)
  91   (assert (member style '(:time :space)))
  92   `(let ((seconds 0.0) (conses 0) result)
  93      (cancel-current-profile :force? t)
  94      (multiple-value-prog1
  95          (prof:with-profiling (:type ,style :count ,call-counts-p)
  96            (measure seconds conses ,@body))
  97        (ensure-directories-exist ,log-name)
  98        ;;log
  99        (with-open-file (output ,log-name
 100                                :direction :output
 101                                :if-does-not-exist :create
 102                                :if-exists :append)
 103          (with-standard-io-syntax
 104            (let ((*print-readably* nil))
 105              (terpri output)
 106              (format output "\(~11,d ~20,s ~10,s ~10,s ~{~s~^ ~} ~s\)"
 107                      (date-stamp :include-time? t) ,name
 108                      seconds conses *additional-markers*
 109                      result))))
 110        (when (> (current-profile-sample-count) 0)
 111          (let ((pathname (unique-filename
 112                           (merge-pathnames
 113                            (make-pathname
 114                             :type "prof"
 115                             :name (format nil "~a-~a-" ,name ,style))
 116                            ,log-name))))
 117            (let ((prof:*significance-threshold*
 118                   (or *profiling-threshold* 0.01)))
 119              (format t "~&Profiling output being sent to ~a" pathname)
 120              (with-open-file (output pathname
 121                                      :direction :output
 122                                      :if-does-not-exist :create
 123                                      :if-exists :append)
 124                (format output "~&Profile data for ~a" ,name)
 125                (format output "~&Date: ~a"
 126                        (excl:locale-print-time (get-universal-time)
 127                                                :fmt "%B %d, %Y %T" :stream nil))
 128                (format output "~&  Total time: ~,2F; Total space: ~:d \(~:*~d\)"
 129                        seconds conses)
 130                (format output "~%~%")
 131                (when (or (eq :time ,style)
 132                          (eq :space ,style))
 133                  (prof:show-flat-profile :stream output)
 134                  (prof:show-call-graph :stream output)
 135                  (when ,call-counts-p
 136                    (format output "~%~%Call counts~%")
 137                    (let ((*standard-output* output))
 138                      (prof:show-call-counts)))))))))))
 139
 140 #| OLD
 141 ;; integrate with LIFT
 142
 143 (pushnew :measure *deftest-clauses*)
 144
 145 (add-code-block
 146  :measure 1 :class-def
 147  (lambda () (def :measure))
 148  '((setf (def :measure) (cleanup-parsed-parameter value)))
 149  (lambda ()
 150    (pushnew 'measured-test-mixin (def :superclasses))
 151    nil))
 152
 153 (defclass measured-test-mixin ()
 154   ((total-conses :initform 0
 155                  :accessor total-conses)
 156    (total-seconds :initform 0
 157                   :accessor total-seconds)))
 158 |#
 159
 160
 161 #|
 162 (defun test-sleep (period)
 163   (print (get-universal-time))
 164   (print
 165    (mp:process-wait-with-timeout
 166     "wait-for-delay" period
 167     (lambda ()
 168       (sleep (1+ period)))))
 169   (print (get-universal-time)))
 170
 171 #+(or)
 172 (test-sleep 2)
 173 3392550276
 174 nil
 175 3392550281
 176
 177 (defun test-gates (period)
 178   (print (get-universal-time))
 179   (let ((g (mp:make-gate nil)))
 180     (print
 181      (mp:process-wait-with-timeout
 182       "wait-for-delay" period
 183       (lambda (gate)
 184         (mp:gate-open-p gate))
 185       g)))
 186   (print (get-universal-time)))
 187
 188 #+(or)
 189 (test-gates 2)
 190 3392550287
 191 nil
 192 3392550289
 193
 194
 195 |#
 196
 197 #|
 198
 199 (princ "ls" (shell-session-input-stream *ss*))
 200 (terpri (shell-session-input-stream *ss*))
 201 (force-output (shell-session-input-stream *ss*))
 202
 203 (read-shell-session-stream *ss* :output)
 204
 205 (shell-session-command *ss* "ls")
 206
 207 (shell-session-command *ss* "ps u")
 208
 209 (end-shell-session *ss*)
 210
 211 (compile 'read-from-stream-no-hang)
 212
 213 (with-input-from-string (s "hello there")
 214   (read-from-stream-no-hang s))
 215
 216 (read-shell-session-stream *ss* :output)
 217
 218 (setf *ss* (make-shell-session))
 219
 220 (count-repetitions-in-period
 221  (lambda ()
 222    (shell-session-command *ss* "ps u"))
 223  2.0)
 224
 225 (count-repetitions-in-period
 226  (lambda ()
 227    (selected-metatilities::os-processes))
 228  2.0)
 229
 230 |#
 231
 232 #+(or)
 233 (test-sleep-b 2)