1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(library (ikarus timers)
(export time-it verbose-timer)
(import (except (ikarus) time-it verbose-timer))
(define-struct stats
(user-secs user-usecs
sys-secs sys-usecs
real-secs real-usecs
collection-id
gc-user-secs gc-user-usecs
gc-sys-secs gc-sys-usecs
gc-real-secs gc-real-usecs
bytes-minor bytes-major
))
(define (mk-stats)
(make-stats #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))
(define verbose-timer (make-parameter #f))
(define (set-stats! t)
(foreign-call "ikrt_stats_now" t))
(define (print-stats message t1 t0)
(define (print-time msg msecs gc-msecs)
(fprintf
(console-error-port)
" ~a ms elapsed ~a time, including ~a ms collecting\n" msecs msg
gc-msecs))
(define (msecs s1 s0 u1 u0)
(+ (* (- s1 s0) 1000) (quotient (- u1 u0) 1000)))
(if message
(fprintf (console-error-port) "running stats for ~a:\n" message)
(fprintf (console-error-port) "running stats:\n"))
(let ([collections
(fx- (stats-collection-id t1) (stats-collection-id t0))])
(case collections
[(0) (display " no collections\n" (console-error-port))]
[(1) (display " 1 collection\n" (console-error-port))]
[else (fprintf (console-error-port) " ~a collections\n" collections)]))
(print-time "cpu"
(+ (msecs (stats-user-secs t1) (stats-user-secs t0)
(stats-user-usecs t1) (stats-user-usecs t0))
(msecs (stats-sys-secs t1) (stats-sys-secs t0)
(stats-sys-usecs t1) (stats-sys-usecs t0)))
(+ (msecs (stats-gc-user-secs t1) (stats-gc-user-secs t0)
(stats-gc-user-usecs t1) (stats-gc-user-usecs t0))
(msecs (stats-gc-sys-secs t1) (stats-gc-sys-secs t0)
(stats-gc-sys-usecs t1) (stats-gc-sys-usecs t0))))
(print-time "real"
(msecs (stats-real-secs t1) (stats-real-secs t0)
(stats-real-usecs t1) (stats-real-usecs t0))
(msecs (stats-gc-real-secs t1) (stats-gc-real-secs t0)
(stats-gc-real-usecs t1) (stats-gc-real-usecs t0)))
(when (verbose-timer)
(print-time "user"
(msecs (stats-user-secs t1) (stats-user-secs t0)
(stats-user-usecs t1) (stats-user-usecs t0))
(msecs (stats-gc-user-secs t1) (stats-gc-user-secs t0)
(stats-gc-user-usecs t1) (stats-gc-user-usecs t0)))
(print-time "sys"
(msecs (stats-sys-secs t1) (stats-sys-secs t0)
(stats-sys-usecs t1) (stats-sys-usecs t0))
(msecs (stats-gc-sys-secs t1) (stats-gc-sys-secs t0)
(stats-gc-sys-usecs t1) (stats-gc-sys-usecs t0))))
(fprintf (console-error-port) " ~a bytes allocated\n"
(diff-bytes
(stats-bytes-minor t0)
(stats-bytes-major t0)
(stats-bytes-minor t1)
(stats-bytes-major t1))))
(define time-it
(case-lambda
[(proc)
(time-it #f proc)]
[(message proc)
(unless (procedure? proc)
(die 'time-it "not a procedure" proc))
(let* ([t0 (mk-stats)]
[t1 (mk-stats)])
(define k
(case-lambda
[(v)
(set-stats! t1)
(print-stats message t1 t0)
v]
[v*
(set-stats! t1)
(print-stats message t1 t0)
(apply values v*)]))
(set-stats! t0)
(call-with-values proc k))]))
(define (diff-bytes mnr0 mjr0 mnr1 mjr1)
(+ (fx- mnr1 mnr0) (* (fx- mjr1 mjr0) #x10000000)))
)
|
