├── .gitignore ├── src ├── clock │ ├── package.lisp │ ├── cffi.lisp │ ├── grovel.lisp │ └── main.lisp ├── logger.lisp └── main.lisp ├── .travis.yml ├── .github └── workflows │ └── ci.yml ├── supertrace.asd ├── tests ├── logger.lisp └── main.lisp └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | -------------------------------------------------------------------------------- /src/clock/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:supertrace/clock 2 | (:use #:cl 3 | #:cffi-grovel) 4 | (:export #:clock-gettime 5 | #:+clock-monotonic+ 6 | #:+clock-realtime+)) 7 | (in-package #:supertrace/clock) 8 | -------------------------------------------------------------------------------- /src/clock/cffi.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:supertrace/clock) 2 | 3 | (cffi:defcstruct timespec 4 | (tv-sec time-t) 5 | (tv-nsec :long)) 6 | 7 | (cffi:defcfun ("clock_gettime" %clock-gettime) :int 8 | (clk-id clockid-t) 9 | (tp :pointer)) 10 | -------------------------------------------------------------------------------- /src/clock/grovel.lisp: -------------------------------------------------------------------------------- 1 | (include "time.h") 2 | 3 | (in-package #:supertrace/clock) 4 | 5 | (ctype time-t "time_t") 6 | (ctype clockid-t "clockid_t") 7 | 8 | (constant (+clock-monotonic+ "CLOCK_MONOTONIC")) 9 | (constant (+clock-realtime+ "CLOCK_REALTIME")) 10 | -------------------------------------------------------------------------------- /src/clock/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:supertrace/clock) 2 | 3 | (defun clock-gettime (&optional (clock-id +clock-monotonic+)) 4 | (cffi:with-foreign-object (timespec '(:pointer (:struct timespec))) 5 | (%clock-gettime clock-id timespec) 6 | (values (cffi:foreign-slot-value timespec '(:struct timespec) 'tv-sec) 7 | (cffi:foreign-slot-value timespec '(:struct timespec) 'tv-nsec)))) 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | os: 5 | - linux 6 | - osx 7 | 8 | env: 9 | global: 10 | - PATH=~/.roswell/bin:$PATH 11 | - ROSWELL_BRANCH=release 12 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 13 | matrix: 14 | - LISP=sbcl-bin 15 | 16 | install: 17 | # Install Roswell 18 | - curl -L https://raw.githubusercontent.com/roswell/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 19 | - ros install rove 20 | 21 | script: 22 | - rove supertrace.asd 23 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | paths: ['*'] 6 | pull_request: 7 | paths: ['*'] 8 | schedule: 9 | - cron: '0 15 * * *' 10 | 11 | jobs: 12 | test: 13 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 14 | runs-on: ${{ matrix.os }} 15 | strategy: 16 | matrix: 17 | lisp: [sbcl-bin] 18 | os: [ubuntu-latest, macOS-latest] 19 | 20 | steps: 21 | - uses: actions/checkout@v1 22 | - name: Install Roswell 23 | env: 24 | LISP: ${{ matrix.lisp }} 25 | run: | 26 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 27 | - name: Install Ultralisp 28 | run: ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 29 | - name: Install Rove 30 | run: ros install fukamachi/rove 31 | - name: Run tests 32 | run: | 33 | PATH="~/.roswell/bin:$PATH" 34 | rove supertrace.asd 35 | -------------------------------------------------------------------------------- /src/logger.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:supertrace/logger 2 | (:use #:cl) 3 | (:export #:elapsed-logger 4 | #:ensure-function-name 5 | #:ensure-function-package)) 6 | (in-package #:supertrace/logger) 7 | 8 | (defun ensure-function-name (name) 9 | (etypecase name 10 | (string (string-downcase name)) 11 | (symbol (let ((*print-case* :downcase)) 12 | (princ-to-string name))))) 13 | 14 | (defun ensure-function-package (name) 15 | (etypecase name 16 | (string *package*) 17 | (symbol (symbol-package name)))) 18 | 19 | (defun elapsed-logger (name args &optional (retval nil retval-supplied-p) elapsed) 20 | (let ((*print-case* :downcase)) 21 | (format *trace-output* 22 | "~&~:[running~;~:*~,3Fms~] <~A> (~A~{ ~S~})~:[~*~; -> ~S~]~%" 23 | (and elapsed (/ elapsed 1000d0)) 24 | (package-name (ensure-function-package name)) 25 | (ensure-function-name name) 26 | args 27 | retval-supplied-p 28 | retval))) 29 | -------------------------------------------------------------------------------- /supertrace.asd: -------------------------------------------------------------------------------- 1 | (defsystem "supertrace" 2 | :version "0.1.0" 3 | :author "Eitaro Fukamachi" 4 | :license "BSD 2-Clause" 5 | :description "Superior Common Lisp trace functionality" 6 | :defsystem-depends-on ((:feature :unix "cffi-grovel")) 7 | :depends-on ((:feature :unix "cffi")) 8 | :pathname "src" 9 | :components 10 | ((:file "main" :depends-on ("logger" 11 | (:feature :unix "clock"))) 12 | (:file "logger") 13 | (:module "clock" 14 | :if-feature :unix 15 | :serial t 16 | :components 17 | ((:file "package") 18 | (:cffi-grovel-file "grovel") 19 | (:file "cffi") 20 | (:file "main")))) 21 | :in-order-to ((test-op (test-op "supertrace/tests")))) 22 | 23 | (defsystem "supertrace/tests" 24 | :depends-on ("supertrace" 25 | "rove" 26 | "cl-ppcre" 27 | "bordeaux-threads") 28 | :pathname "tests" 29 | :serial t 30 | :components 31 | ((:file "logger") 32 | (:file "main")) 33 | :perform (test-op (o c) (symbol-call :rove '#:run c))) 34 | -------------------------------------------------------------------------------- /tests/logger.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:supertrace/tests/logger 2 | (:use #:cl 3 | #:rove 4 | #:supertrace/logger)) 5 | (in-package #:supertrace/tests/logger) 6 | 7 | (defpackage #:supertrace/tests/logger/test-package 8 | (:export #:say-hello)) 9 | (defun supertrace/tests/logger/test-package:say-hello (to) 10 | (format t "~&Hello, ~A!~%" to)) 11 | 12 | (deftest ensure-function-name 13 | (ok (equal (ensure-function-name 'supertrace/tests/logger/test-package:say-hello) 14 | "say-hello") 15 | "symbol") 16 | (ok (equal (ensure-function-name "SAY-HELLO") "say-hello") 17 | "string")) 18 | 19 | (deftest ensure-function-package 20 | (ok (eq (ensure-function-package 'supertrace/tests/logger/test-package:say-hello) 21 | (find-package :supertrace/tests/logger/test-package)) 22 | "symbol") 23 | (ok (eq (ensure-function-package "say-hello") *package*) 24 | "string")) 25 | 26 | (deftest elapsed-logger 27 | (ok (outputs (funcall #'elapsed-logger 28 | 'supertrace/tests/logger/test-package:say-hello 29 | '("World")) 30 | (format nil "running (say-hello \"World\")~%") 31 | *trace-output*) 32 | "for before logger") 33 | (ok (outputs (funcall #'elapsed-logger 34 | 'supertrace/tests/logger/test-package:say-hello 35 | '("World") 36 | nil 37 | 120) 38 | (format nil "0.120ms (say-hello \"World\") -> nil~%") 39 | *trace-output*) 40 | "for after logger")) 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # supertrace 2 | 3 | [![Build Status](https://github.com/fukamachi/supertrace/workflows/CI/badge.svg)](https://github.com/fukamachi/supertrace/actions?query=workflow%3ACI) 4 | 5 | Superior Common Lisp `trace` functionality for debugging/profiling real world applications. 6 | 7 | ## Warning 8 | 9 | This software is still ALPHA quality. The APIs will be likely to change. 10 | 11 | ## Usage 12 | 13 | ``` 14 | ;; List a function names to trace 15 | (supertrace dbi:execute dbi:prepare) 16 | 17 | ;; Trace all exported functions from 'dbi' package and 'dex:request' 18 | (supertrace (package dbi) dex:request) 19 | 20 | ;; Custom before/after functions 21 | (supertrace (package dbi) dex:request 22 | :before #'before-logger ;; <- A function takes 2 arguments -- a function name and arguments 23 | :after #'after-logger) ;; <- A function takes 4 arguments -- a function name, arguments, returned value and elapsed time in microsecond. 24 | ``` 25 | 26 | Output is like as follows: 27 | 28 | ``` 29 | running (prepare # "SELECT COUNT(*) AS \"count\" FROM \"entry\" WHERE \"user_id\" = ?") 30 | 0.210ms (prepare # "SELECT COUNT(*) AS \"count\" FROM \"entry\" WHERE \"user_id\" = ?") -> # 31 | running (execute # "eb073a91-d098-4c38-805b-cede8e39d278") 32 | 0.565ms (execute # "eb073a91-d098-4c38-805b-cede8e39d278") -> # 33 | ``` 34 | 35 | ### Options 36 | 37 | - `:before`: A function to run _before_ the function call 38 | - `:after`: A function to run _after_ the function call 39 | - `:threshold`: Run `:after` function only when the elapsed time exceeded this value. (in microsecond) 40 | 41 | ## Supported implementations 42 | 43 | - [x] SBCL 44 | - [ ] Clozure CL 45 | - [ ] Others 46 | 47 | ## Author 48 | 49 | * Eitaro Fukamachi (e.arrows@gmail.com) 50 | 51 | ## Copyright 52 | 53 | Copyright (c) 2020 Eitaro Fukamachi (e.arrows@gmail.com) 54 | 55 | ## License 56 | 57 | Licensed under the BSD 2-Clause License. 58 | -------------------------------------------------------------------------------- /tests/main.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:supertrace/tests/main 2 | (:use #:cl 3 | #:rove 4 | #:supertrace/main) 5 | (:import-from #:supertrace/main 6 | #:parse-supertrace-options) 7 | (:import-from #:cl-ppcre 8 | #:scan)) 9 | 10 | (defpackage #:supertrace/tests/main/test-package 11 | (:use #:cl) 12 | (:export #:say-hello 13 | #:hello-world 14 | #:wait-a-while 15 | #:wait-a-while2)) 16 | (in-package #:supertrace/tests/main/test-package) 17 | (defun say-hello (to) 18 | (format t "Hello, ~A!" to)) 19 | (defun hello-world () 20 | (say-hello "World") 21 | t) 22 | (defun wait-a-while () 23 | (sleep 0.3)) 24 | (defun wait-a-while2 () 25 | (sleep 0.1) 26 | (wait-a-while) 27 | (sleep 0.2)) 28 | 29 | (in-package #:supertrace/tests/main) 30 | 31 | (setup 32 | (untrace supertrace/tests/main/test-package:say-hello 33 | supertrace/tests/main/test-package:hello-world 34 | supertrace/tests/main/test-package:wait-a-while 35 | supertrace/tests/main/test-package:wait-a-while2)) 36 | 37 | (deftest parse-supertrace-options 38 | (flet ((fut (args) 39 | (multiple-value-list (parse-supertrace-options args)))) 40 | (ok (equal (fut '()) '(() ()))) 41 | (ok (equal (fut '("PREPARE")) 42 | '(() ("PREPARE")))) 43 | (ok (equal (fut '("PREPARE" "EXECUTE")) 44 | '(() ("PREPARE" "EXECUTE")))) 45 | (ok (equal (fut '(:before #1=(lambda (&rest args) 46 | (warn "before ~S" args)) 47 | "PREPARE" "EXECUTE")) 48 | '((:before #1#) ("PREPARE" "EXECUTE")))) 49 | (ok (equal (fut '(:after #2=(lambda (&rest args) 50 | (warn "after ~S" args)) 51 | "PREPARE" "EXECUTE")) 52 | '((:after #2#) ("PREPARE" "EXECUTE")))) 53 | (ok (equal (fut '(:before #1# :after #2# 54 | "PREPARE" "EXECUTE")) 55 | '((:before #1# :after #2#) ("PREPARE" "EXECUTE")))) 56 | (ok (equal (fut '("PREPARE" "EXECUTE" 57 | :before #1# :after #2#)) 58 | '((:before #1# :after #2#) ("PREPARE" "EXECUTE")))))) 59 | 60 | (deftest supertrace 61 | (supertrace supertrace/tests/main/test-package:say-hello) 62 | (let* ((*standard-output* (make-broadcast-stream)) 63 | (outputs (with-output-to-string (*trace-output*) 64 | (supertrace/tests/main/test-package:say-hello "Eitaro")))) 65 | (ok (scan "^running \\(say-hello \"Eitaro\"\\) 66 | \\d+?\\.\\d{3}ms \\(say-hello \"Eitaro\"\\) -> nil\\n$" outputs))) 67 | 68 | (supertrace supertrace/tests/main/test-package:hello-world) 69 | (let ((outputs (let ((*standard-output* (make-broadcast-stream))) 70 | (with-output-to-string (*trace-output*) 71 | (supertrace/tests/main/test-package:hello-world))))) 72 | (ok (scan "^running \\(hello-world\\) 73 | running \\(say-hello \"World\"\\) 74 | \\d+?\\.\\d{3}ms \\(say-hello \"World\"\\) -> nil 75 | \\d+?\\.\\d{3}ms \\(hello-world\\) -> t 76 | $" outputs))) 77 | 78 | (supertrace supertrace/tests/main/test-package:wait-a-while) 79 | (let ((outputs (let ((*standard-output* (make-broadcast-stream))) 80 | (with-output-to-string (*trace-output*) 81 | (supertrace/tests/main/test-package:wait-a-while))))) 82 | (ok (scan "^running \\(wait-a-while\\) 83 | 3\\d{2}\\.\\d{3}ms \\(wait-a-while\\) -> nil 84 | $" outputs))) 85 | 86 | (testing "Nested case" 87 | (supertrace supertrace/tests/main/test-package:wait-a-while2) 88 | (let ((outputs (let ((*standard-output* (make-broadcast-stream))) 89 | (with-output-to-string (*trace-output*) 90 | (supertrace/tests/main/test-package:wait-a-while2))))) 91 | #-darwin 92 | (ok (scan "^running \\(wait-a-while2\\) 93 | running \\(wait-a-while\\) 94 | 30\\d\\.\\d{3}ms \\(wait-a-while\\) -> nil 95 | 60\\d\\.\\d{3}ms \\(wait-a-while2\\) -> nil 96 | $" outputs)) 97 | #+darwin 98 | (ok (scan "^running \\(wait-a-while2\\) 99 | running \\(wait-a-while\\) 100 | [34]\\d{2}\\.\\d{3}ms \\(wait-a-while\\) -> nil 101 | [67]\\d{2}\\.\\d{3}ms \\(wait-a-while2\\) -> nil 102 | $" outputs)))) 103 | 104 | (testing "Multiple threads" 105 | (let* ((output-stream (make-string-output-stream)) 106 | (bt:*default-special-bindings* `((*trace-output* . ,output-stream) 107 | (*standard-output* . ,(make-broadcast-stream)))) 108 | threads) 109 | (push 110 | (bt:make-thread 111 | (lambda () 112 | (supertrace/tests/main/test-package:wait-a-while)) 113 | :name "wait-a-while 1") 114 | threads) 115 | (sleep 0.1) 116 | (push 117 | (bt:make-thread 118 | (lambda () 119 | (supertrace/tests/main/test-package:wait-a-while)) 120 | :name "wait-a-while 2") 121 | threads) 122 | 123 | (mapc #'bt:join-thread threads) 124 | (let ((outputs (get-output-stream-string output-stream))) 125 | #-darwin 126 | (ok (scan "^running \\(wait-a-while\\) 127 | running \\(wait-a-while\\) 128 | 30\\d\\.\\d{3}ms \\(wait-a-while\\) -> nil 129 | 30\\d\\.\\d{3}ms \\(wait-a-while\\) -> nil 130 | $" outputs)) 131 | #+darwin 132 | (ok (scan "^running \\(wait-a-while\\) 133 | running \\(wait-a-while\\) 134 | [34]\\d{2}\\.\\d{3}ms \\(wait-a-while\\) -> nil 135 | [34]\\d{2}\\.\\d{3}ms \\(wait-a-while\\) -> nil 136 | $" outputs)))))) 137 | -------------------------------------------------------------------------------- /src/main.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:supertrace 2 | (:nicknames #:supertrace/main) 3 | (:use #:cl) 4 | (:import-from #:supertrace/logger 5 | #:elapsed-logger) 6 | #+unix 7 | (:import-from #:supertrace/clock 8 | #:clock-gettime) 9 | (:export #:supertrace 10 | #:elapsed-logger)) 11 | (in-package #:supertrace) 12 | 13 | (declaim (hash-table *before-unixtime* *before-usec*)) 14 | (defparameter *before-unixtime* 15 | (make-hash-table :test 'eq)) 16 | (defparameter *before-usec* 17 | (make-hash-table :test 'eq)) 18 | 19 | (eval-when (:compile-toplevel :load-toplevel :execute) 20 | (defun parse-supertrace-options (args) 21 | (loop while args 22 | for arg = (pop args) 23 | if (and args 24 | (member arg '(:before :after :threshold))) 25 | append (list arg (pop args)) into options 26 | else collect arg into names 27 | finally (return (values options names))))) 28 | 29 | (declaim (inline find-trace-call-frame)) 30 | (defun find-trace-call-frame () 31 | (declare (optimize (speed 3) (safety 0) (debug 0))) 32 | (do ((frame (sb-di:top-frame) (sb-di:frame-down frame))) 33 | ((or (null frame) 34 | (eq 'sb-debug::trace-call (sb-debug::frame-call frame))) frame) 35 | (declare (type (or sb-di:frame null) frame)))) 36 | 37 | (defun ensure-printable (args) 38 | (if (consp args) 39 | (mapcar #'sb-debug::ensure-printable-object args) 40 | args)) 41 | 42 | (defun expand-function-names (names) 43 | (loop for name in names 44 | if (and (consp name) 45 | (eq (first name) 'package)) 46 | append (let ((symbols '())) 47 | (destructuring-bind (package-name &key internal) 48 | (rest name) 49 | (do-external-symbols (symb package-name) 50 | (when (and (fboundp symb) 51 | (not (macro-function symb))) 52 | (push symb symbols))) 53 | (when internal 54 | (do-symbols (symb package-name) 55 | (when (and (eq (symbol-package symb) (find-package package-name)) 56 | (fboundp symb) 57 | (not (macro-function symb))) 58 | (push symb symbols))))) 59 | (nreverse symbols)) 60 | collect name)) 61 | 62 | (declaim (inline get-timings)) 63 | (defun get-timings () 64 | #+unix (multiple-value-bind (sec nsec) 65 | (clock-gettime) 66 | (declare (fixnum nsec) 67 | (optimize (speed 3) (safety 0) (debug 0))) 68 | (values sec (floor nsec 1000))) 69 | #-unix (sb-ext:get-time-of-day)) 70 | 71 | (defmacro supertrace (&rest names-and-options) 72 | (multiple-value-bind (options function-names) 73 | (parse-supertrace-options names-and-options) 74 | (let ((function-names (or function-names 75 | ;; If no function/package names are supplied, trace all functions in the current package. 76 | `((package ,(package-name *package*) :internal t)))) 77 | (frame (gensym "FRAME")) 78 | (info (gensym "INFO")) 79 | (form (gensym "FORM")) 80 | (unixtime (gensym "UNIXTIME")) 81 | (usec (gensym "USEC")) 82 | (elapsed (gensym "ELAPSED"))) 83 | (destructuring-bind (&key (before ''elapsed-logger) (after ''elapsed-logger) threshold) 84 | options 85 | `(trace :report ,(if (or before after) 86 | nil 87 | 'trace) 88 | :condition-all (progn 89 | ,(and before 90 | `(let ((,frame (find-trace-call-frame))) 91 | (when (null ,frame) 92 | (error "Failed to find sb-debug::trace-call in stacktraces")) 93 | (destructuring-bind (,info &rest ,form) 94 | (nth-value 1 (sb-debug::frame-call ,frame)) 95 | (funcall ,before 96 | (sb-debug::trace-info-what ,info) 97 | (ensure-printable (rest ,form)))))) 98 | ,(and after 99 | `(multiple-value-bind (,unixtime ,usec) 100 | (get-timings) 101 | (push ,unixtime 102 | (gethash sb-thread:*current-thread* *before-unixtime*)) 103 | (push ,usec 104 | (gethash sb-thread:*current-thread* *before-usec*)))) 105 | t) 106 | :break-after (progn 107 | ,(and after 108 | `(let ((,frame (find-trace-call-frame))) 109 | (when (null ,frame) 110 | (error "Failed to find sb-debug::trace-call in stacktraces")) 111 | (destructuring-bind (,info &rest ,form) 112 | (nth-value 1 (sb-debug::frame-call ,frame)) 113 | (multiple-value-bind (,unixtime ,usec) 114 | (get-timings) 115 | (declare (fixnum ,unixtime ,usec)) 116 | (let ((,elapsed 117 | (locally (declare (optimize (speed 3) (safety 0) (debug 0))) 118 | (+ (* 1000000 (- ,unixtime (the fixnum (pop (gethash sb-thread:*current-thread* *before-unixtime*))))) 119 | (- ,usec (the fixnum (pop (gethash sb-thread:*current-thread* *before-usec*)))))))) 120 | (when ,(if threshold 121 | `(< ,threshold ,elapsed) 122 | t) 123 | (funcall ,after 124 | (sb-debug::trace-info-what ,info) 125 | (ensure-printable (rest ,form)) 126 | (sb-debug:arg 0) 127 | ,elapsed))))))) 128 | nil) 129 | ,@(expand-function-names function-names)))))) 130 | --------------------------------------------------------------------------------