Add profiling framework with call counting and timing (#29)
ober
873d28f91bcf32ea429235ebb0af1f8c66233a31
new file mode 100644 --- /dev/null +++ b/lib/std/misc/profile.sls @@ -0,0 +1,154 @@ +#!chezscheme +;;; (std misc profile) — Lightweight profiling framework +;;; +;;; (define-profiled (fib n) +;;; (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) +;;; +;;; (profile-report) ; print stats sorted by total time +;;; (profile-data) ; get stats as alist +;;; (profile-reset!) ; clear all collected data +;;; (with-profiling body ...) ; profile and report +;;; (time-it expr) ; returns (values result elapsed-ms) + +(library (std misc profile) + (export define-profiled + profile-reset! + profile-report + profile-data + with-profiling + time-it + profiling-active?) + (import (chezscheme)) + + ;; Global switch — when #f, define-profiled functions run with zero + ;; overhead (no timing, no hashtable lookup). + (define profiling-active? (make-parameter #f)) + + ;; name → mutable vector #(call-count total-ns min-ns max-ns) + (define *profile-table* (make-hashtable symbol-hash symbol=?)) + + ;; Monotonic clock helpers + (define (now-ns) + (let ([t (current-time 'time-monotonic)]) + (+ (* (time-second t) 1000000000) + (time-nanosecond t)))) + + (define (ensure-entry! name) + (let ([v (hashtable-ref *profile-table* name #f)]) + (or v + (let ([new (vector 0 0 (greatest-fixnum) 0)]) + (hashtable-set! *profile-table* name new) + new)))) + + (define (record-call! name elapsed-ns) + (let ([v (ensure-entry! name)]) + (vector-set! v 0 (+ (vector-ref v 0) 1)) ; count + (vector-set! v 1 (+ (vector-ref v 1) elapsed-ns)) ; total + (vector-set! v 2 (min (vector-ref v 2) elapsed-ns)) ; min + (vector-set! v 3 (max (vector-ref v 3) elapsed-ns)))) ; max + + ;; ---- Public API ---- + + (define (profile-reset!) + (hashtable-clear! *profile-table*)) + + (define (profile-data) + ;; Returns: ((name . ((count . N) (total-ms . T) (min-ms . M) + ;; (max-ms . X) (avg-ms . A))) ...) + ;; Sorted by total-ms descending. + (let-values ([(keys vals) (hashtable-entries *profile-table*)]) + (let ([entries + (let loop ([i 0] [acc '()]) + (if (= i (vector-length keys)) + acc + (let* ([name (vector-ref keys i)] + [v (vector-ref vals i)] + [cnt (vector-ref v 0)] + [tot (vector-ref v 1)] + [mn (vector-ref v 2)] + [mx (vector-ref v 3)] + [ns->ms (lambda (ns) (/ ns 1000000.0))] + [avg (if (> cnt 0) (/ tot cnt) 0)]) + (loop (+ i 1) + (cons (cons name + (list (cons 'count cnt) + (cons 'total-ms (ns->ms tot)) + (cons 'min-ms (ns->ms mn)) + (cons 'max-ms (ns->ms mx)) + (cons 'avg-ms (ns->ms avg)))) + acc)))))]) + (list-sort (lambda (a b) + (> (cdr (assq 'total-ms (cdr a))) + (cdr (assq 'total-ms (cdr b))))) + entries)))) + + (define (profile-report) + (let ([data (profile-data)]) + (when (null? data) + (display "No profiling data collected.\n") + (return)) + (display (format "~a~%" + "----------------------------------------------------------------------")) + (display (format "~20a ~8a ~12a ~12a ~12a ~12a~%" + "Function" "Calls" "Total(ms)" "Avg(ms)" "Min(ms)" "Max(ms)")) + (display (format "~a~%" + "----------------------------------------------------------------------")) + (for-each + (lambda (entry) + (let ([name (car entry)] + [props (cdr entry)]) + (display (format "~20a ~8d ~12,3f ~12,3f ~12,3f ~12,3f~%" + name + (cdr (assq 'count props)) + (cdr (assq 'total-ms props)) + (cdr (assq 'avg-ms props)) + (cdr (assq 'min-ms props)) + (cdr (assq 'max-ms props)))))) + data) + (display (format "~a~%" + "----------------------------------------------------------------------")))) + + ;; return is used in profile-report for early exit + (define-syntax return + (syntax-rules () + [(_) (void)])) + + ;; ---- Macros ---- + + (define-syntax define-profiled + (syntax-rules () + [(_ (name args ...) body ...) + (define name + (let ([proc (lambda (args ...) body ...)]) + (lambda (args ...) + (if (profiling-active?) + (let ([start (now-ns)]) + (call-with-values + (lambda () (proc args ...)) + (lambda results + (let ([elapsed (- (now-ns) start)]) + (record-call! 'name elapsed) + (apply values results))))) + (proc args ...)))))])) + + (define-syntax time-it + (syntax-rules () + [(_ expr) + (let ([start (now-ns)]) + (call-with-values + (lambda () expr) + (lambda results + (let ([elapsed-ms (/ (- (now-ns) start) 1000000.0)]) + (apply values (append results (list elapsed-ms)))))))])) + + (define-syntax with-profiling + (syntax-rules () + [(_ body ...) + (begin + (profile-reset!) + (parameterize ([profiling-active? #t]) + (let ([result (begin body ...)]) + (profile-report) + result)))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-profile.ss @@ -0,0 +1,170 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc profile)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected true, got " (format "~s" val))))) + +(define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))])))) + +;; ---- define-profiled: basic call counting ---- +(define-profiled (square x) (* x x)) + +(test "define-profiled tracks call count" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (square 3) + (square 4) + (square 5)) + (let* ([data (profile-data)] + [entry (assq 'square data)] + [props (cdr entry)]) + (assert-equal (cdr (assq 'count props)) 3 "call count")))) + +;; ---- define-profiled returns correct values ---- +(test "define-profiled returns correct result" + (lambda () + (parameterize ([profiling-active? #t]) + (assert-equal (square 7) 49 "square 7")))) + +;; ---- zero overhead when profiling inactive ---- +(test "no overhead when profiling inactive" + (lambda () + (profile-reset!) + ;; profiling-active? defaults to #f + (square 10) + (square 20) + (let ([data (profile-data)]) + (assert-true (null? data) "no data collected when inactive")))) + +;; ---- nested profiled calls ---- +(define-profiled (double x) (* x 2)) +(define-profiled (quad x) (double (double x))) + +(test "nested profiled calls tracked independently" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (quad 5)) + (let* ([data (profile-data)] + [quad-entry (assq 'quad data)] + [double-entry (assq 'double data)]) + (assert-equal (cdr (assq 'count (cdr quad-entry))) 1 "quad called once") + (assert-equal (cdr (assq 'count (cdr double-entry))) 2 "double called twice")))) + +;; ---- profile-reset! clears data ---- +(test "profile-reset! clears all data" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (square 3)) + (let ([before (profile-data)]) + (assert-true (not (null? before)) "data exists before reset")) + (profile-reset!) + (let ([after (profile-data)]) + (assert-true (null? after) "data empty after reset")))) + +;; ---- time-it measures elapsed time ---- +(test "time-it returns result and elapsed ms" + (lambda () + (let-values ([(result elapsed-ms) (time-it (begin + (sleep (make-time 'time-duration 50000000 0)) + 42))]) + (assert-equal result 42 "time-it result") + (assert-true (>= elapsed-ms 40.0) + (format "elapsed ~a ms should be >= 40" elapsed-ms))))) + +;; ---- profile-data sorted by total time ---- +(define-profiled (slow-fn) + (sleep (make-time 'time-duration 30000000 0)) ;; 30ms + 'slow) + +(define-profiled (fast-fn) + 'fast) + +(test "profile-data sorted by total time descending" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (fast-fn) + (slow-fn)) + (let* ([data (profile-data)] + [names (map car data)]) + (assert-equal (car names) 'slow-fn "slow-fn should be first")))) + +;; ---- timing values are sensible ---- +(test "min/max/avg tracked correctly" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (square 1) + (square 2) + (square 3)) + (let* ([data (profile-data)] + [entry (assq 'square data)] + [props (cdr entry)] + [mn (cdr (assq 'min-ms props))] + [mx (cdr (assq 'max-ms props))] + [avg (cdr (assq 'avg-ms props))] + [tot (cdr (assq 'total-ms props))]) + (assert-true (<= mn avg) "min <= avg") + (assert-true (<= avg mx) "avg <= max") + (assert-true (<= mn mx) "min <= max") + (assert-true (>= tot 0.0) "total >= 0")))) + +;; ---- with-profiling macro ---- +(test "with-profiling resets, profiles, reports, returns result" + (lambda () + ;; Seed some data that should be cleared + (parameterize ([profiling-active? #t]) + (square 1)) + (let ([result (with-profiling + (square 10) + (square 20) + (+ (square 3) 1))]) + (assert-equal result 10 "with-profiling returns last body value") + ;; After with-profiling, profiling-active? should be back to #f + (assert-true (not (profiling-active?)) "profiling inactive after with-profiling")))) + +;; ---- profile-report outputs something ---- +(test "profile-report produces output" + (lambda () + (profile-reset!) + (parameterize ([profiling-active? #t]) + (square 5)) + (let ([output (with-output-to-string profile-report)]) + (assert-true (> (string-length output) 0) "report not empty") + (assert-true (string-contains output "square") "report mentions function name")))) + +;; ---- Summary ---- +(newline) +(display (format "~a/~a tests passed.~%" pass-count test-count)) +(unless (= pass-count test-count) + (exit 1))