external/lift/dev/macros.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 &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 (defun benchmark (name fn &rest args)
  31   (declare (dynamic-extent args))
  32   (let ((seconds 0.0) (conses 0) result)
  33     (flet ((do-it ()
  34              (setf (values seconds conses result)
  35                    (apply 'measure fn args))))
  36       (cond ((or (eq :time *profiling*)
  37                  (eq :space *profiling*))
  38              (with-profiling (:type *profiling*) (do-it)))
  39             ((eq :count *profiling*)
  40              (with-profiling (:count t) (do-it)))
  41             (t
  42              (do-it)))
  43       (let ((date-stamp (get-universal-time)))
  44         (ensure-directories-exist *benchmark-file*)
  45         ;;log
  46         (with-open-file (output *benchmark-file*
  47                                 :direction :output
  48                                 :if-does-not-exist :create
  49                                 :if-exists :append)
  50           (with-standard-io-syntax
  51             (let ((*print-readably* nil))
  52               (terpri output)
  53               (format output "\(~11,d ~20,s ~10,s ~10,s ~{~s~^ ~}~30,s ~s ~s\)"
  54                       date-stamp name
  55                       seconds conses *additional-markers*
  56                       (if (symbolp fn) fn "<function>") args result))))
  57         (when *profiling*
  58           (let ((pathname (merge-pathnames
  59                            (make-pathname
  60                             :type "prof"
  61                             :name (format nil "~a-~a-~a"
  62                                           name *profiling* date-stamp))
  63                            *benchmark-file*)))
  64             (format t "~&Profiling output being sent to ~a" pathname)
  65             (with-open-file (output pathname
  66                                     :direction :output
  67                                     :if-does-not-exist :create
  68                                     :if-exists :append)
  69               (format output "~&Profile data for ~a" name)
  70               (format output "~&  Total time: ~,2F; Total space: ~:d \(~d\)"
  71                       seconds conses conses)
  72               (format output "~&  Arguments:~{~&    ~s,~^~}" args)
  73               (format output "~%~%")
  74               (when (or (eq :time *profiling*)
  75                         (eq :space *profiling*))
  76                 (prof:show-flat-profile :stream output)
  77                 (prof:show-call-graph :stream output))
  78               (when (eq :count *profiling*)
  79                 (let ((*standard-output* output)
  80                       (*print-readably* nil))
  81                   (prof:show-call-counts)))))))
  82       (list seconds conses result))))