external/lift/dev/measuring.lisp

   1 (in-package #:lift)
   2
   3 (declaim (optimize (speed 3) (safety 1)))
   4
   5 (defmacro with-measuring ((var measure-fn) &body body)
   6   (let ((initial (gensym)))
   7     `(let ((,initial (,measure-fn)))
   8        ,@body
   9        (setf ,var (- (,measure-fn) ,initial)))))
  10
  11 (defmacro measure-time ((var) &body body)
  12   `(prog1
  13        (with-measuring (,var get-internal-real-time)
  14          ,@body)
  15      (setf ,var (coerce (/ ,var internal-time-units-per-second)
  16                         'double-float))))
  17
  18 (defmacro measure-conses ((var) &body body)
  19   `(with-measuring (,var total-bytes-allocated)
  20      ,@body))
  21
  22 (defun measure-fn (fn &rest args)
  23   (declare (dynamic-extent args))
  24   (let ((bytes 0) (seconds 0) result)
  25     (measure-time (seconds)
  26       (measure-conses (bytes)
  27         (setf result (apply fn args))))
  28     (values seconds bytes result)))
  29
  30 (defmacro measure (seconds bytes &body body)
  31   (let ((result (gensym)))
  32     `(let (,result)
  33        (measure-time (,seconds)
  34          (measure-conses (,bytes)
  35            (setf ,result (progn ,@body))))
  36        (values ,result))))
  37
  38 (defparameter *benchmark-file*
  39   (asdf:system-relative-pathname
  40    'lift "benchmark-data/benchmarks.log"))
  41
  42 (defvar *collect-call-counts* nil)
  43
  44 (defvar *additional-markers* nil)
  45
  46 (defvar *profiling-threshold* nil)
  47
  48 #+allegro
  49 (defun cancel-current-profile (&key force?)
  50   (when (prof::current-profile-actual prof::*current-profile*)
  51     (unless force?
  52       (assert (member (prof:profiler-status) '(:inactive))))
  53     (prof:stop-profiler)
  54     (setf prof::*current-profile* (prof::make-current-profile))))
  55
  56 #+allegro
  57 (defun current-profile-sample-count ()
  58    (ecase (prof::profiler-status :verbose nil)
  59     ((:inactive :analyzed) 0)
  60     ((:suspended :saved)
  61      (slot-value (prof::current-profile-actual prof::*current-profile*)
  62                  'prof::samples))
  63     (:sampling (warn "Can't determine count while sampling"))))
  64
  65 ;; FIXME -- functionify this!
  66 #+allegro
  67 (defmacro with-profile-report ((name style &key (log-name *benchmark-file*)
  68                                      (call-counts-p *collect-call-counts*))
  69                                &body body)
  70   (assert (member style '(:time :space)))
  71   `(let ((seconds 0.0) (conses 0) result)
  72      (cancel-current-profile :force? t)
  73      (multiple-value-prog1
  74          (prof:with-profiling (:type ,style :count ,call-counts-p)
  75            (measure seconds conses ,@body))
  76        (ensure-directories-exist ,log-name)
  77        ;;log
  78        (with-open-file (output ,log-name
  79                                :direction :output
  80                                :if-does-not-exist :create
  81                                :if-exists :append)
  82          (with-standard-io-syntax
  83            (let ((*print-readably* nil))
  84              (terpri output)
  85              (format output "\(~11,d ~20,s ~10,s ~10,s ~{~s~^ ~} ~s\)"
  86                      (date-stamp :include-time? t) ,name
  87                      seconds conses *additional-markers*
  88                      result))))
  89        (when (> (current-profile-sample-count) 0)
  90          (let ((pathname (unique-filename
  91                           (merge-pathnames
  92                            (make-pathname
  93                             :type "prof"
  94                             :name (format nil "~a-~a-" ,name ,style))
  95                            ,log-name))))
  96            (let ((prof:*significance-threshold*
  97                   (or *profiling-threshold* 0.01)))
  98              (format t "~&Profiling output being sent to ~a" pathname)
  99              (with-open-file (output pathname
 100                                      :direction :output
 101                                      :if-does-not-exist :create
 102                                      :if-exists :append)
 103                (format output "~&Profile data for ~a" ,name)
 104                (format output "~&Date: ~a"
 105                        (excl:locale-print-time (get-universal-time)
 106                                                :fmt "%B %d, %Y %T" :stream nil))
 107                (format output "~&  Total time: ~,2F; Total space: ~:d \(~:*~d\)"
 108                        seconds conses)
 109                (format output "~%~%")
 110                (when (or (eq :time ,style)
 111                          (eq :space ,style))
 112                  (prof:show-flat-profile :stream output)
 113                  (prof:show-call-graph :stream output)
 114                  (when ,call-counts-p
 115                    (format output "~%~%Call counts~%")
 116                    (let ((*standard-output* output))
 117                      (prof:show-call-counts)))))))))))
 118
 119 #| OLD
 120 ;; integrate with LIFT
 121
 122 (pushnew :measure *deftest-clauses*)
 123
 124 (add-code-block
 125  :measure 1 :class-def
 126  (lambda () (def :measure))
 127  '((setf (def :measure) (cleanup-parsed-parameter value)))
 128  (lambda ()
 129    (pushnew 'measured-test-mixin (def :superclasses))
 130    nil))
 131
 132 (defclass measured-test-mixin ()
 133   ((total-conses :initform 0
 134                  :accessor total-conses)
 135    (total-seconds :initform 0
 136                   :accessor total-seconds)))
 137 |#