profiling

profiling.clj

;;;;
;; profiling.clj -- simple profiling macros for Clojure CLR

;; by Jona Ekenberg, https://github.com/saikyun
;; February 6th, 2019

;;  Copyright (c) Jona Ekenberg, 2019. All rights reserved. The use
;;  and distribution terms for this software are covered by the Eclipse
;;  Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
;;  which can be found in the file epl-v10.html at the root of this
;;  distribution. By using this software in any fashion, you are
;;  agreeing to be bound by the terms of this license. You must not
;;  remove this notice, or any other, from this software.

;;* Usage

;; Track a whole namespace using `(time-ns* 'namespace.name)`
;; Can be undone with `(untime-ns* 'namespace.name)`
;;
;; Change function definitions from `defn` to `defn-profile`
;;
;; Track individual expressions by wrapping them in `(trace-time :id <expression>)`
;; Where :id is the name of that specific measurement
;;
;; Run the function `(start-processing!)` in order to start the thread that processes the data
;;
;; Call `(print-times)` in to display all the processed data.
;;

;;* Example of `(print-times)`

;; |                                   :id | :nof-calls | :avg-total | :time-taken |  :total |
;; |---------------------------------------+------------+------------+-------------+---------|
;; |                refresh-affordable-ui  |       1767 |       1.19 |     1188.18 | 2097.19 |
;; |                       owner-of-card - |      14061 |       0.02 |      248.86 |  316.46 |
;; |                            any->id -- |      14061 |          0 |          -> |   67.59 |
;; |                         can-afford? - |      14061 |       0.02 |          -> |  300.15 |
;; |                             get-mat - |      14061 |       0.02 |          -> |  292.41 |
;; |                        update-state2  |      42507 |       0.02 |          -> |  838.89 |

;; The numbers are milliseconds
;;
;; The -s to the right of the id's implies that it's a measurement called
;; inside another measurement (e.g. `(trace-time :a (+ 2 (trace-time :b (+ 1 1))))`)
;; These nested calls are referred to as children measurements
;;
;; :nof-calls are the number of calls of a specific measurement
;;
;; :avg-total is the average time the function took, it's just :total / :nof-calls
;;
;; :time-taken shows how much time the function took excluding children
;; -> implies that :time-taken = :total
;;
;; :total shows how much time the function took including children
;;
;; The table is ordered by :total -> depth of children -> :total
;; so at the top you see the slowest function, then its
;; slowest child, then that functions slowest child e.t.c.
;;

(ns miracle.tools.profiling
  (:require [clojure.pprint :refer [print-table]])
  (:import System.Diagnostics.Stopwatch
           [System.Threading Timer TimerCallback
            Thread ThreadStart]))

(defonce times-atom (atom []))
(defonce processed-times (atom {}))
(defonce current-path (atom []))

(defn update-time
  [stored time]
  (if (nil? stored) {:nof 1 :avg time}
      (let [stored (update stored :nof inc)
            new-avg (/ (+ (* (:avg stored)
                             (dec (:nof stored)))
                          time)
                       (:nof stored))]
        (assoc stored :avg new-avg))))

(defn update-time
  [stored time]
  (if (nil? stored) {:nof 1 :total time}
      (-> stored
          (update :nof inc)
          (update :total + time))))

(defrecord TimeData
    [path
     time])

(defn save-time!
  [times time-data]
  (swap! times conj time-data))

(defn process-time
  [times {:keys [path time]}]
  (update-in times
             (conj (into [] (interpose :children path)) :vals)
             update-time time))

(defn process-times!
  []
  (let [[old-times _] (swap-vals! times-atom (constantly []))]
    (swap! processed-times #(reduce process-time % old-times))))

(defn leaves-with-key
  [data which]
  (flatten
   (filter identity 
           (map (fn [[k v]]
                  (if (coll? v)
                    (leaves-with-key v which)
                    (when (= k which) v))) data))))

(defn time-taken-exclude-children
  [[k {:keys [vals children]}]]
  (let [{:keys [total nof]} vals]
    (- total (reduce (fn [a b] (+ a (-> b val :vals :total))) 0 children))))

(defn time-taken-per-node
  [v]
  (let [data {:id (first v)
              :nof (-> (second v) :vals :nof)
              :time-taken (time-taken-exclude-children v)
              :total (-> (second v) :vals :total)
              }]
    (if (:children (second v))
      (assoc data :children (into [] (sort-by :total #(compare %2 %1) (map time-taken-per-node (:children (second v))))))
      data)))

(defn for-print
  ([node]
   (for-print node 0))
  ([{:keys [id nof time-taken total children]} indent]
   (let [total-rounded (Math/Round total 2)
         time-taken-rounded (Math/Round time-taken 2)]
     [{:id (str id " " (apply str (repeat indent "-")))
       :nof-calls nof
       :avg-total (Math/Round (/ total nof) 2)
       :time-taken (if (= time-taken-rounded
                          total-rounded)
                     "->"
                     time-taken-rounded)
       :total total-rounded}
      (if children
        (into [] (map #(for-print % (inc indent)) children)))])))

(defn all-times-without-children
  "The time the measurement took, excluding children."
  [data]
  (reduce
   (fn [acc {:keys [id time-taken]}]
     (update acc id #(+ time-taken (or % 0))))
   {}
   (filter identity (flatten (map time-taken-per-node data)))))

(defn total-ms-per-node
  "The total ms for each top level measurement."
  [data]
  (into {} (map #(vector (key %) (-> % val :vals :total)) data)))

(defn total-ms
  "The total measured milliseconds."
  [data]
  (reduce #(+ %1 (-> %2 val :vals :total)) 0 data))

(defn print-times
  "Prints all processed times in a table.
  If you call it with a parameter, it only shows measurement with
  a total time of over `min-total`."
  ([]
   (print-table (filter identity (flatten (map for-print (sort-by :total #(compare %2 %1) (flatten (map time-taken-per-node @processed-times))))))))
  ([min-total]
   (print-table (filter #(> (:total %) min-total) (filter identity (flatten (map for-print (sort-by :total #(compare %2 %1) (flatten (map time-taken-per-node @processed-times))))))))))

(defn thread-func
  []
  (process-times!)
  (Thread/Sleep 1000))

(defn start-processing!
  []
  (arcadia.core/log "Starting thread...")
  (defonce th (Thread.
               (gen-delegate ThreadStart []
                             (while true (thread-func)))))
  (when (not (.-IsAlive th)) (.Start th)))

(defn reset-times! []
  (reset! processed-times {})
  (reset! times-atom []))

(defn start-timer!
  [id]
  (let [^Stopwatch timer (Stopwatch.)]
    (swap! current-path conj id)
    (.Start timer)
    timer))

(defn stop-timer!
  [^Stopwatch timer]
  (.Stop timer)
  (let [path @current-path]
    (swap! current-path pop)
    (->TimeData
     path
     (.. timer -Elapsed -TotalMilliseconds))))

(defmacro trace-time
  "Evaluates expr and stores the time it took,
  using the `id` to specify this parcticular measurement.
  Returns the value of expr."
  {:added "1.0"}
  [expr id]
  `(let [timer# (miracle.tools.profiling/start-timer! ~id)
         ret# ~expr
         time-data# (miracle.tools.profiling/stop-timer! timer#)]
     (miracle.tools.profiling/save-time! miracle.tools.profiling/times-atom time-data#)
     ret#))

(defn ^{:skip-wiki true} time-fn-call
  [name f args]
  (trace-time (apply f args)
              name))

(defmacro defn-profile
  "Use in place of defn; profiles each call/return of this fn, including
   arguments. Nested calls to deftime'd functions are stored in a tree structure.
   The first argument of the form definition can be a doc string."
  [name & definition]
  (let [doc-string (if (string? (first definition)) (first definition) "")
        fn-form  (if (string? (first definition)) (rest definition) definition)]
    `(do
       (declare ~name)
       (let [f# (fn ~@fn-form)]
         (defn ~name ~doc-string [& args#]
           (time-fn-call '~name f# args#))))))

(defn ^{:skip-wiki true} time-var*
  "If the specified Var holds an IFn and is not marked as a macro, its
  contents is replaced with a version wrapped in a timing call;
  otherwise nothing happens. Can be undone with untrace-var.
  
  In the unary case, v should be a Var object or a symbol to be
  resolved in the current namespace.
  
  In the binary case, ns should be a namespace object or a symbol
  naming a namespace and s a symbol to be resolved in that namespace."
  ([ns s]
   (time-var* (ns-resolve ns s)))
  ([v]
   (let [^clojure.lang.Var v (if (var? v) v (resolve v))
         ns (.ns v)
         s  (.sym v)]
     (if (and (ifn? @v) (-> v meta :macro not) (-> v meta ::timed not))
       (let [f @v
             vname (symbol (str ns "/" s))]
         (doto v
           (alter-var-root #(fn tracing-wrapper [& args]
                              (time-fn-call vname % args)))
           (alter-meta! assoc ::timed f)))))))

(defn ^{:skip-wiki true} untime-var*
  "Reverses the effect of trace-var / trace-vars / trace-ns for the
  given Var, replacing the timed function with the original, untimed
  version. No-op for non-timed Vars.
  
  Argument types are the same as those for trace-var."
  ([ns s]
   (untime-var* (ns-resolve ns s)))
  ([v]
   (let [^clojure.lang.Var v (if (var? v) v (resolve v))
         ns (.ns v)
         s  (.sym v)
         f  ((meta v) ::timed)]
     (when f
       (doto v
         (alter-var-root (constantly ((meta v) ::timed)))
         (alter-meta! dissoc ::timed))))))

(defn ^{:skip-wiki true} time-ns*
  "Replaces each function from the given namespace with a version wrapped
  in a tracing call. Can be undone with untime-ns. ns should be a namespace
  object or a symbol.
  
  No-op for clojure.core and clojure.tools.time."
  [ns]
  (let [ns (the-ns ns)]
    (when-not ('#{clojure.core clojure.tools.time} (.getName ns))
      (let [ns-fns (->> ns ns-interns vals (filter (comp fn? var-get)))]
        (doseq [f ns-fns]
          (time-var* f))))))

(defn ^{:skip-wiki true} untime-ns*
  "Reverses the effect of time-var / time-vars / time-ns for the
  Vars in the given namespace, replacing each timed function from the
  given namespace with the original, untimed version."
  [ns]
  (let [ns-fns (->> ns the-ns ns-interns vals)]
    (doseq [f ns-fns]
      (untime-var* f))))