asdf system durations

system-durations.lisp

(defpackage #:snippets/system-durations
  (:documentation "Measure the duration it takes to load each system.
Note that this script is not referenced in snippets.asd because it is
intended to be loaded prior to it.")
  (:use #:cl)
  (:import-from #:asdf)
  (:import-from #:monotonic-clock
                #:monotonic-now/ms)
  (:import-from #:alexandria
                #:hash-table-alist)
  (:export
   #:list-system-durations))

(in-package #:snippets/system-durations)

(defvar *system-durations*
  (make-hash-table :test 'equal)
  "Mapping from system names to load durations in milliseconds.")

(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:component))
  "The hook to do the actual measurement.  It determines the duration
it took to load the supplied component and adds it to the proper
system entry in the system durations map."
  (let ((start-time (monotonic-now/ms)))
    (multiple-value-prog1 (call-next-method)
      (let ((duration (- (monotonic-now/ms) start-time)))
        (when (plusp duration)
          (let ((system (parent-system c)))
            (when system
              (incf (gethash (asdf:component-name system)
                             *system-durations*
                             0)
                    duration))))))))

(defun parent-system (component)
  "Return the parent system of a component, unless the component
itself is a system, in which case it is returned as-is."
  (if (typep component 'asdf:system)
      component
      (if (typep component 'asdf:child-component)
          (parent-system (asdf:component-parent component))
          nil)))

(defun list-system-durations ()
  "Return a list of system load durations.  Each element in the list
is a cons whose car is the system's name and cdr the duration it took
to load in milliseconds."
  (sort (hash-table-alist *system-durations*) #'< :key #'cdr))