;;; benchmark-init.el --- Benchmarks for require and load calls -*- lexical-binding: t; -*-

;; Copyright (C) 2013 Steve Purcell
;; Copyright (C) 2013-2014 David Holm

;; Author: Steve Purcell
;; Maintainer: David Holm <dholmster@gmail.com>
;; Created: 25 Apr 2013
;; Keywords: convenience benchmark
;; Package-Version: 20260108.1447
;; Package-Revision: 54b9703389f2
;; URL: https://github.com/dholm/benchmark-init-el
;; Package-Requires: ((emacs "24.4"))

;; This file is not part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this file.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is a simple benchmark of calls to Emacs require and load functions.
;; It can be used to keep track of where time is being spent during Emacs
;; startup in order to optimize startup times.
;; The code is based on init-benchmarking.el by Steve Purcell.

;;; Installation:

;; Place this file in your load path and add the following code to the
;; beginning of your Emacs initialization script:

;; (require 'benchmark-init)

;; Data collection will begin as soon as benchmark-init has been loaded.

;;; Usage:

;; After Emacs has finished loading the following functions will bring up
;; the results:
;;
;;  - `benchmark-init/show-durations-tabulated'
;;  - `benchmark-init/show-durations-tree'
;;
;; Data collection can be controlled using the following two functions:
;;
;;  - `benchmark-init/activate'
;;  - `benchmark-init/deactivate'

;;; Code:

(require 'cl-lib)

;; Customization

(defgroup benchmark-init nil
  "Emacs init benchmarking."
  :group 'local)

(defvar benchmark-init/backtrace-node-types nil
  "Node types to generate backtraces for.")

;; Global variables

(cl-defstruct benchmark-init/node
  "Tree node structure.

Slots:
`name' Entry name.
`type' Entry type, such as 'require or 'load.
`duration' Duration in milliseconds.
`children' Nodes loaded by this one."
  name type duration gc-duration backtrace children)

(defvar benchmark-init/durations-tree (make-benchmark-init/node
                                       :name 'benchmark-init/root
                                       :type nil
                                       :duration 0
                                       :gc-duration 0
                                       :backtrace nil
                                       :children nil)
  "Recorded durations stored in a tree.")

(defvar benchmark-init/current-node benchmark-init/durations-tree
  "Current node in durations tree.")

;; Helpers

(defun benchmark-init/time-subtract-millis (b a)
  "Calculate the number of milliseconds that have elapsed between B and A."
  (* 1000.0 (float-time (time-subtract b a))))

(defun benchmark-init/flatten (node)
  "Flatten NODE into a property list."
  (let ((node-alist `((:name . ,(benchmark-init/node-name node))
                      (:type . ,(benchmark-init/node-type node))
                      (:duration . ,(benchmark-init/node-duration node))
                      (:gc-duration-adj . ,(benchmark-init/node-gc-duration-adjusted node))
                      (:duration-adj . ,(benchmark-init/node-duration-adjusted
                                         node))
                      (:backtrace . ,(benchmark-init/node-backtrace node))))
        (children (benchmark-init/node-children node))
        (node-list))
    (cons node-alist
          (dolist (child children node-list)
            (setq node-list
                  (append (benchmark-init/flatten child) node-list))))))

(defun benchmark-init/node-root-p (node)
  "True if NODE represents the tree root."
  (eq benchmark-init/durations-tree node))

(defun benchmark-init/node-duration-adjusted (node)
  "Duration of NODE with child durations removed."
  (let* ((children (benchmark-init/node-children node))
         (duration (benchmark-init/node-duration node))
         (child-durations (benchmark-init/sum-node-durations children)))
    (if (benchmark-init/node-root-p node)
        (- child-durations (benchmark-init/sum-node-gc-durations children))
      (- duration child-durations (benchmark-init/node-gc-duration node)))))

(defun benchmark-init/sum-node-durations (nodes)
  "Return the sum of NODES durations."
  (let ((accum 0))
    (dolist (node nodes accum)
      (setq accum (+ (benchmark-init/node-duration node) accum)))))

(defun benchmark-init/node-gc-duration-adjusted (node)
  "GC duration of NODE with child durations removed."
  (let ((gc-duration (benchmark-init/node-gc-duration node))
        (child-gc-durations (benchmark-init/sum-node-gc-durations
                             (benchmark-init/node-children node))))
    (if (benchmark-init/node-root-p node) child-gc-durations
      (- gc-duration child-gc-durations))))

(defun benchmark-init/sum-node-gc-durations (nodes)
  "Return the sum of NODES gc durations."
  (let ((accum 0))
    (dolist (node nodes accum)
      (setq accum (+ (benchmark-init/node-gc-duration node) accum)))))

;; Benchmark helpers

(defun benchmark-init/begin-measure (name type &optional backtrace)
  "Begin measuring NAME of TYPE."
  (let ((parent benchmark-init/current-node)
        (node (make-benchmark-init/node :name name :type type
                                        :duration (current-time)
                                        :gc-duration gc-elapsed
                                        :backtrace backtrace
                                        :children nil)))
    (setq benchmark-init/current-node node)
    parent))

(defun benchmark-init/end-measure (parent should-record-p)
  "Stop measuring and store to PARENT if SHOULD-RECORD-P."
  (let ((node benchmark-init/current-node)
        (duration (benchmark-init/time-subtract-millis
                   (current-time)
                   (benchmark-init/node-duration benchmark-init/current-node)))
        (gc-duration (* 1000
                        (- gc-elapsed
                           (benchmark-init/node-gc-duration
                            benchmark-init/current-node)))))
    (when (funcall should-record-p)
      (setf (benchmark-init/node-duration node) duration
            (benchmark-init/node-gc-duration node) gc-duration)
      (push node (benchmark-init/node-children parent)))
    (setq benchmark-init/current-node parent)))

(defmacro benchmark-init/measure-around (name type inner should-record-p &optional backtrace)
  "Save duration spent in NAME of TYPE around INNER if SHOULD-RECORD-P."
  `(let ((parent (benchmark-init/begin-measure ,name ,type ,backtrace)))
     (prog1
         ,inner
       (benchmark-init/end-measure parent ,should-record-p))))

(defun benchmark-init/relevant-backtrace (sym)
  (let (backtrace seen)
    (catch 'done
      (mapbacktrace (lambda (evald func args flags)
                      (cond
                       ;; Wait until we get to the stack under the
                       ;; load or require call.
                       ((not seen)
                        (when (eq func sym)
                          (setq seen t)))

                       ;; Above the second load or require call should
                       ;; be in that node.
                       ((memq func '(load require))
                        (throw 'done nil))

                       ;; Record relevant function calls.  Some
                       ;; internal functions are not good breadcrumbs.
                       ((and (symbolp func)
                             (functionp func)
                             (not (memq func '(;; Internally used by
                                               ;; evaluator.
                                               byte-code

                                               ;; Internally added by
                                               ;; advice.
                                               apply

                                               ;; Internally used by `load'.
                                               load-with-code-conversion

                                               ;; Advice functions.
                                               benchmark-init/load-times-wrapper
                                               benchmark-init/require-times-wrapper))))
                        (push func backtrace))))))
    backtrace))


;; Benchmark injection

(defun benchmark-init/require-times-wrapper (orig feature &rest args)
  "Record the time taken to require FEATURE."
  (let* ((name (symbol-name feature))
         (already-loaded (memq feature features))
         (should-record-p (lambda ()
                            (and (not already-loaded) (memq feature features)))))
    (benchmark-init/measure-around name
				   'require
				   (apply orig feature args)
				   should-record-p
                                   (and (not already-loaded)
                                        (memq 'require benchmark-init/backtrace-node-types)
                                        (benchmark-init/relevant-backtrace 'require)))))

(advice-add 'require :around 'benchmark-init/require-times-wrapper)

(defun benchmark-init/load-times-wrapper (orig file &rest args)
  "Record the time taken to load FILE."
  (let ((name (abbreviate-file-name file))
        (should-record-p (lambda () t)))
    (benchmark-init/measure-around name
				   'load
				   (apply orig file args)
				   should-record-p
                                   (and (memq 'load benchmark-init/backtrace-node-types)
                                        (benchmark-init/relevant-backtrace 'load)))))


(advice-add 'load :around 'benchmark-init/load-times-wrapper)

;; Benchmark control

(defun benchmark-init/deactivate ()
  "Deactivate benchmark-init."
  (interactive)
  (advice-remove 'require #'benchmark-init/require-times-wrapper)
  (advice-remove 'load #'benchmark-init/load-times-wrapper))

;;;###autoload
(defun benchmark-init/activate ()
  "Activate benchmark-init and start collecting data."
  (interactive)
  (advice-add 'require :around #'benchmark-init/require-times-wrapper)
  (advice-add 'load :around #'benchmark-init/load-times-wrapper))

;; Obsolete functions

(define-obsolete-function-alias 'benchmark-init/install
  'benchmark-init/activate "2014-03-17")

(provide 'benchmark-init)
;;; benchmark-init.el ends here
