From d5027b53103e73cb392e5808a85dbd9f7464451b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 May 2020 20:57:38 +0200 Subject: Add profile! macro. --- module/util/time.scm | 36 +++++++++++++++++++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/module/util/time.scm b/module/util/time.scm index 004cb6dc..c97d3ee2 100644 --- a/module/util/time.scm +++ b/module/util/time.scm @@ -1,5 +1,6 @@ (define-module (util time) - :export (report-time!)) + :use-module (ice-9 match) + :export (report-time! profile!)) (define report-time! @@ -14,3 +15,36 @@ ;; (/ real internal-time-units-per-second) fmt args) (set! last run))))) + +(define-macro (profile! proc) + (let ((qualified-procedure + (match proc + [((or '@ '@@) (module ...) symb) + `(@@ ,module ,symb)] + [symb + `(@@ ,(module-name (current-module)) ,symb)])) + (og-procedure (gensym "proc"))) + `(let ((,og-procedure ,qualified-procedure)) + (set! ,qualified-procedure + (let ((accumulated-time 0) + (count 0)) + (lambda args + (set! count (1+ count)) + (let ((start-time (gettimeofday))) + (let ((return (apply ,og-procedure args))) + (let ((end-time (gettimeofday))) + (let ((runtime (+ (- (car end-time) (car start-time)) + (/ (- (cdr end-time) (cdr start-time)) + 1e6)))) + (set! accumulated-time (+ accumulated-time runtime)) + (when (> accumulated-time 1) + (display (format #f "~8,4fs │ ~a (~a)~%" + accumulated-time + (or (procedure-name ,qualified-procedure) + (quote ,qualified-procedure)) + count) + (current-error-port)) + (set! count 0) + (set! accumulated-time 0))) + return)))))) + ,og-procedure))) -- cgit v1.2.3