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
115
116
117
118
119
|
(provide 'profile.scm)
(let-temporarily (((*s7* 'profile) 0))
(define show-profile
(let ((*profile-port* *stderr*))
(set! (setter '*profile-port*)
(lambda (s v)
(if (or (output-port? v) (not v))
v
(error 'wrong-type-arg "~S can't be set! to ~S" s v))))
(lambda* ((n 100))
(let ((info (*s7* 'profile-info)))
;; a list: '(vector-of-function-names int-vector-of-profile-data ticks-per-second let-names file-names line-numbers ambiguous-names)
(if (not info)
(format *profile-port* "no profiling data!~%")
(let* ((funcs (car info))
;; function names (symbols)
(data (cadr info))
;; each entry in the data vector is a block of 5 integers:
;; calls <ignore> <ignore> inclusive-time exclusive-time
(ticks/sec (* 1.0 (caddr info)))
;; divide by ticks/sec to turn the times into seconds
(let-names (list-ref info 3))
;; symbols, the value of (*s7* 'profile-prefix) at the function, #f if none
(file-names (list-ref info 4))
;; strings, #f if none (includes line-numbers)
(line-numbers (list-ref info 5))
(ambiguous-names (list-ref info 6)) ; function names that occur more than once
(entries (length funcs))
(vect (make-vector entries)))
(do ((i 0 (+ i 1)))
((= i entries))
(vector-set! vect i (list (/ (data (+ (* i 5) 3)) ticks/sec) ; inclusive timing
(funcs i) ; function name
(data (* i 5)) ; calls
(/ (data (+ (* i 5) 4)) ticks/sec) ; exclusive timing
(let-names i)
(file-names i)
(line-numbers i))))
(set! vect (sort! vect (lambda (a b) ; sort by inclusive time, to sort by calls use caddr
(> (car a) (car b)))))
;(> (caddr a) (caddr b)))))
(let ((name-len 0) ; decide the data column
(name-max 0)
(end (min n entries))
(call-max 0))
(do ((i 0 (+ i 1)))
((= i end))
(let ((entry (vector-ref vect i)))
(when (symbol? (cadr entry))
(let ((len (if (list-ref entry 4) ; there is a let-name
(+ 1 (length (symbol->string (cadr entry))) (length (symbol->string (list-ref entry 4))))
(length (symbol->string (cadr entry))))))
(set! name-len (+ name-len len))
(set! name-max (max name-max len)))))
(set! call-max (max call-max (caddr (vector-ref vect i)))))
(set! name-max (max (round (/ name-len entries)) (floor (* .9 name-max))))
(set! call-max (+ 1 (ceiling (log call-max 10))))
(format *profile-port* "info:\n")
(do ((i 0 (+ i 1))
(fs 0)
(excl 0.0))
((= i end)
(format *profile-port* " ")
(when (< end fs)
(format *profile-port* "the rest (~D entries): ~,4F, "
(- fs end)
(max 0.0 (- (car (vector-ref vect 0)) excl))))
(let ((gc-info (*s7* 'gc-info)))
(format *profile-port* "cell allocations: ~A, GC calls: ~D, GC time: ~,3F seconds~%"
(let ((num (with-let *s7*
(+ (- heap-size free-heap-size) gc-total-freed))))
(cond ((< num 1000) (format #f "~D" num))
((< num 1000000) (format #f "~,1Fk" (/ num 1000.0)))
((< num 1000000000) (format #f "~,1FM" (/ num 1000000.0)))
(else (format #f "~,1FG" (/ num 1000000000.0)))))
(car gc-info)
(* 1.0 (/ (cadr gc-info) (caddr gc-info))))))
(let ((entry (vector-ref vect i)))
(when (symbol? (cadr entry))
(format *profile-port* " ~A:~NTcalls ~S, ~NTtime ~,4F ~NT~,4F"
(if (list-ref entry 4)
(string-append (symbol->string (list-ref entry 4)) "/" (symbol->string (cadr entry)))
(cadr entry))
(+ name-max 5)
(caddr entry)
(+ name-max 5 6 call-max)
(car entry)
(+ name-max 5 6 call-max 8 6)
(max 0.0 (cadddr entry)))
(when (and (memq (cadr entry) ambiguous-names)
(string? (list-ref entry 5)))
(format *profile-port* ", ~A[~D]" (list-ref entry 5) (list-ref entry 6)))
(newline *profile-port*)
(set! fs (+ fs 1))
(set! excl (+ excl (cadddr entry)))))))))))))
(define (clear-profile)
(set! (*s7* 'profile-info) #f))
(define profile-port (dilambda
(lambda ()
((funclet show-profile) '*profile-port*))
(lambda (new-port)
(set! ((funclet show-profile) '*profile-port*) new-port)))))
|
