src/debugging.lisp @ 322aefbbcb9f

(in-package :losh.debugging)

(defun pr (&rest args)
  "Print `args` readably, separated by spaces and followed by a newline.

  Returns the first argument, so you can just wrap it around a form without
  interfering with the rest of the program.

  This is what `print` should have been.

  "
  (format t "~{~S~^ ~}~%" args)
  (finish-output)
  (first args))

(defmacro prl (&rest args)
  "Print `args` labeled and readably.

  Each argument form will be printed, then evaluated and the result printed.
  One final newline will be printed after everything.

  Returns the last result.

  Examples:

    (let ((i 1)
          (l (list 1 2 3)))
      (prl i (second l)))
    ; =>
    i 1
    (second l) 2

  "
  `(prog1
    (progn ,@(mapcar (lambda (arg)
                       (with-gensyms (a)
                         `(let ((,a ,arg))
                            (pr ',arg ,a)
                            ,a)))
                     args))
    (terpri)
    (finish-output)))

(defun phr ()
  "Print a horizontal rule to aid in visual debugging."
  (pr "-----------------------------------------------------------------------"))


(defun bits (&optional (n *) (size 8) (stream t))
  "Print the bits of the `size`-bit two's complement integer `n` to `stream`.

  Examples:

    (bits 5 10)
    => 0000000101

    (bits -5 10)
    => 1111111011

  "
  ;; http://blog.chaitanyagupta.com/2013/10/print-bit-representation-of-signed.html
  (format stream (format nil "~~~D,'0B" size) (ldb (byte size 0) n)))

(defun hex (&optional (thing *) (stream t))
  "Print the `thing` to `stream` with numbers in base 16.

  Examples:

    (hex 255)
    => FF

    (hex #(0 128))
    => #(0 80)

  "
  (let ((*print-base* 16))
    (case stream
      ((nil) (prin1-to-string thing))
      ((t) (prin1 thing stream) (terpri stream) nil)
      (otherwise (prin1 thing stream) (terpri stream) nil))))

(defmacro shut-up (&body body)
  "Run `body` with stdout and stderr redirected to the void."
  `(let ((*standard-output* (make-broadcast-stream))
         (*error-output* (make-broadcast-stream)))
    ,@body))

(defmacro dis (&body body)
  "Disassemble the code generated for a `lambda` with `arglist` and `body`.

  It will also spew compiler notes so you can see why the garbage box isn't
  doing what you think it should be doing.

  "
  (let ((%disassemble #+sbcl 'sb-disassem:disassemble-code-component
                      #-sbcl 'disassemble))
    (destructuring-bind (arglist &body body)
        (iterate (for b :first body :then (cdr b))
                 (while (not (listp (car b))))
                 (finally (return b)))
      `(,%disassemble (compile nil '(lambda ,arglist
                                     (declare (optimize speed))
                                     ,@body))))))

(defmacro comment (&body body)
  "Do nothing with a bunch of forms.

  Handy for block-commenting multiple expressions.

  "
  (declare (ignore body))
  nil)


(defun aesthetic-string (thing)
  "Return the string used to represent `thing` when printing aesthetically."
  (format nil "~A" thing))

(defun structural-string (thing)
  "Return the string used to represent `thing` when printing structurally."
  (format nil "~S" thing))

(defun print-table (rows)
  "Print `rows` as a nicely-formatted table.

  Each row should have the same number of colums.

  Columns will be justified properly to fit the longest item in each one.

  Example:

    (print-table '((1 :red something)
                   (2 :green more)))
    =>
    1 | RED   | SOMETHING
    2 | GREEN | MORE

  "
  (when rows
    (iterate
      (with column-sizes =
            (reduce (curry #'mapcar #'max)
                    (mapcar (curry #'mapcar (compose #'length #'aesthetic-string))
                            rows))) ; lol
      (for row :in rows)
      (format t "~{~vA~^ | ~}~%" (mapcan #'list column-sizes row))))
  (values))


(defun pretty-print-hash-table (*standard-output* ht)
  (pprint-logical-block
      (*standard-output* (hash-table-contents ht) :prefix "{" :suffix "}")
    (pprint-exit-if-list-exhausted)
    (loop (destructuring-bind (k v) (pprint-pop)
            (write k)
            (write-string ": ")
            (write v)
            (pprint-exit-if-list-exhausted)
            (write-string ", ")
            (pprint-newline :linear)))))


(set-pprint-dispatch 'hash-table 'pretty-print-hash-table)


#+sbcl
(defun dump-profile (filename)
  (with-open-file (*standard-output* filename
                                     :direction :output
                                     :if-exists :supersede)
    (sb-sprof:report :type :graph
                     :sort-by :cumulative-samples
                     :sort-order :ascending)
    (sb-sprof:report :type :flat
                     :min-percent 0.5)))

#+sbcl
(defun start-profiling (&key call-count-packages (mode :cpu))
  "Start profiling performance.  SBCL only.

  `call-count-packages` should be a list of package designators.  Functions in
  these packages will have their call counts recorded via
  `sb-sprof::profile-call-counts`.

  "
  (sb-sprof::reset)
  (_ call-count-packages
    (mapcar #'mkstr _)
    (mapcar #'string-upcase _)
    (mapc #'sb-sprof::profile-call-counts _))
  (sb-sprof::start-profiling :max-samples 50000
                             :mode mode
                             ; :mode :time
                             :sample-interval 0.01
                             :threads :all))

#+sbcl
(defun stop-profiling (&optional (filename "lisp.prof"))
  "Stop profiling performance and dump a report to `filename`.  SBCL only."
  (sb-sprof::stop-profiling)
  (dump-profile filename))

#+sbcl
(defmacro profile (form &key (mode :cpu))
  "Profile `form` and dump the report to `lisp.prof`."
  `(progn
     (start-profiling :mode ,mode)
     (unwind-protect
         (time ,form)
       (stop-profiling))))

(defmacro profile-when (condition &body body)
  "Evaluate and return `body`, profiling when `condition` is true."
  (with-gensyms (thunk)
    `(flet ((,thunk () ,@body))
       (if ,condition
         (profile (,thunk))
         (,thunk)))))


(defmacro timing ((&key (time :run) (result-type 'integer)) &body body)
  "Execute `body`, discard its result, and return the time taken.

  `time` must be one of `:run` or `:real`.

  `result-type` must be `integer` (which will return internal time units) or
  `rational`/`single-float`/`double-float` (which will return seconds).

  "
  (with-gensyms (start end result)
    `(let ((,start ,(ecase time
                      (:run '(get-internal-run-time))
                      (:real '(get-internal-real-time)))))
       (progn ,@body)
       (let* ((,end ,(ecase time
                       (:run '(get-internal-run-time))
                       (:real '(get-internal-real-time))))
              (,result (- ,end ,start)))
         ,(ecase result-type
            (integer `,result)
            (rational `(/ ,result internal-time-units-per-second))
            (single-float `(coerce (/ ,result internal-time-units-per-second) 'single-float))
            (double-float `(coerce (/ ,result internal-time-units-per-second) 'double-float)))))))


(defmacro gimme (n &body body)
  `(iterate (repeat ,n)
     (collect (progn ,@body))))