diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-05 20:57:38 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-05 20:57:38 +0200 |
| commit | d5027b53103e73cb392e5808a85dbd9f7464451b (patch) | |
| tree | 0cae78c2911e97016ec6853a6bf1117a9a1a8eca | |
| parent | html --help s/month/table/ (diff) | |
| download | calp-d5027b53103e73cb392e5808a85dbd9f7464451b.tar.gz calp-d5027b53103e73cb392e5808a85dbd9f7464451b.tar.xz | |
Add profile! macro.
| -rw-r--r-- | module/util/time.scm | 36 |
1 files changed, 35 insertions, 1 deletions
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))) |