weblocks-advanced-timing.lisp

(in-package :weblocks)

(setf *enable-timings* t)

(defvar *timings-data* nil)
(defvar *tree-path* nil)

(defun reverse-timings-data (data)
  "During collection of log data it appends in wrong order due to technical reasons. This function reverses data back"
  (unless data 
    (return-from reverse-timings-data))

  (let ((parts)
        (min-level (fifth (car data)))
        (current-part))
    
    (push (first data) current-part)

    (loop for i in (cdr data) do 
          (when (= (fifth i) min-level)
            (push (reverse current-part) parts)
            (setf current-part nil))
          (push i current-part))

    (push (reverse current-part) parts)

    (loop for (first . rest) in parts 
          append (cons first (reverse-timings-data rest)))))

(assert 
  (equal 
    '((("First node") "First node" 1/1000 1/250 1)
      (("First node" "First child") "First child" 0 0 2)
      (("First node" "First child" "First two-level child") "First two-level child"
                                                            0 0 3)
      (("First node" "First child" "Second two-level child")
       "Second two-level child" 0 0 3)
      (("First node" "First child" "Third two-level child") "Third two-level child"
                                                            0 0 3)
      (("First node" "Second child") "Second child" 1/1000 0 2)
      (("First node" "Second child" "fourth two-level child")
       "fourth two-level child" 0 0 3)
      (("First node" "Second child" "fifth two-level child") "fifth two-level child"
                                                             0 0 3))
    (reverse-timings-data '((("First node") "First node" 1/1000 1/250 1)
                            (("First node" "Second child") "Second child" 1/1000 0 2)
                            (("First node" "Second child" "fifth two-level child") "fifth two-level child"
                                                                                   0 0 3)
                            (("First node" "Second child" "fourth two-level child")
                             "fourth two-level child" 0 0 3)
                            (("First node" "First child") "First child" 0 0 2)
                            (("First node" "First child" "Third two-level child") "Third two-level child"
                                                                                  0 0 3)
                            (("First node" "First child" "Second two-level child")
                             "Second two-level child" 0 0 3)
                            (("First node" "First child" "First two-level child") "First two-level child"
                                                                                  0 0 3)))))

(defun print-timings-data (data &key (stream t))
  (loop for (path . rest) in data do 
        (loop for i from 1 to (fourth rest) do 
              (format stream "  "))
        (format stream "~A time (real/cpu): ~F/~F~%" (first rest)
                (second rest) (third rest))))

(assert 
  (string= 
"    First time (real/cpu): 0.0/0.0
      Second time (real/cpu): 0.0/0.0
        Third time (real/cpu): 0.0/0.0
        Fourth time (real/cpu): 0.0/0.0
"
  (with-output-to-string (s)
  (print-timings-data (reverse-timings-data '((("First") "First" 0 0 2) (("First" "Second") "Second" 0 0 3)
                                                                        (("First" "Second" "Fourth") "Fourth" 0 0 4)
                                                                        (("First" "Second" "Third") "Third" 0 0 4))) :stream s))))

; When not nil, timing log is outputed there
(defparameter *timings-output-log* "timing-debug.txt")

(defmethod weblocks::on-timing-start :around (level name)
  ;(format t "Starting timing level ~A~%" level)
  (when (= level 1)
    (setf *timings-data* nil)
    (setf *tree-path* nil)

    (when *timings-output-log* 
      (with-open-file (out *timings-output-log* :direction :output :if-does-not-exist :create :if-exists :append) 
        (format out "~%Call ~A to ~A~%" (metatilities:format-date "%Y-%m-%d %H:%M:%S" (get-universal-time)) (weblocks:request-uri-path))))
    (firephp:send-message 
      (format nil "~%Call ~A to ~A~%" (metatilities:format-date "%Y-%m-%d %H:%M:%S" (get-universal-time)) (weblocks:request-uri-path))
      :type :log))

  (push name *tree-path*)

  (setf weblocks::*timing-report-fn* 
        (lambda (name real cpu)
          (when *tree-path*
            (push (cons (reverse *tree-path*) (list name real cpu *timing-level*)) *timings-data*))

          (setf *tree-path* (cdr *tree-path*))

          (unless *tree-path* 
            (when *timings-output-log* 
              (with-open-file (out "timing-debug.txt" :direction :output :if-does-not-exist :create :if-exists :append)
                (print-timings-data (reverse-timings-data *timings-data*) :stream out)))

            (firephp:send-message
              (firephp::maybe-escape-html (with-output-to-string (s)
                                            (print-timings-data (reverse-timings-data *timings-data*) :stream s)))
              :type :log))
          nil)))