From d3afa54144748685d12c159407194e03538e98de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 24 Aug 2020 20:34:11 +0200 Subject: Move util modules into calp module.. --- module/util/time.scm | 50 -------------------------------------------------- 1 file changed, 50 deletions(-) delete mode 100644 module/util/time.scm (limited to 'module/util/time.scm') diff --git a/module/util/time.scm b/module/util/time.scm deleted file mode 100644 index c97d3ee2..00000000 --- a/module/util/time.scm +++ /dev/null @@ -1,50 +0,0 @@ -(define-module (util time) - :use-module (ice-9 match) - :export (report-time! profile!)) - - -(define report-time! - (let ((last 0)) - (lambda (fmt . args) - (let ((run (get-internal-run-time)) - ; (real (get-internal-real-time)) - ) - (format (current-error-port) "~7,4fs (+ ~,4fs) │ ~?~%" - (/ run internal-time-units-per-second) - (/ (- run last) internal-time-units-per-second) - ;; (/ 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