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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
; A simple call-counting profiler.
; https://bitbucket.org/fallintothis/profiler
(= profiles* (table) originals* (table))
; avoid infinite loops & other badness in profiled fn, e.g. (profile +)
(with (orig-+ +
orig-is is
orig-err err
orig-type type
orig-sref sref
orig-apply apply
orig-atomic-invoke atomic-invoke)
(mac profiled (f)
; (= (profiles* f) 0)
`(profiled-as ',f ,f))
; Not sure I like the order of the arguments, but probably rarely use this.
(def profiled-as (name f (o profile-data profiles*))
(if (orig-is (orig-is (orig-type f) 'fn) nil)
(orig-err "Can only profile functions:" f))
(fn args
(orig-atomic-invoke
(fn () (orig-sref profile-data
(orig-+ (profile-data name 0) 1)
name)))
(orig-apply f args)))
; Have to be careful here. (= profiles* (table)) won't work, since profiled-as
; has the table passed in as an arg: after a (= ...), old closed-over
; references from profiled-as will fail to update the profiles* table.
; (= glob* (table))
; (def foo ((o y glob*)) (fn (x) (= (y x) t)))
; (= bar (foo))
; (bar 5) ; glob* = #hash((5 . t))
; (= glob* (table)) ; glob* = #hash()
; (bar 5) ; glob* = #hash(), still
(def reset-profiles ((o fns))
(each f (or fns (keys profiles*))
(orig-atomic-invoke
(fn () (orig-sref profiles*
nil
f))))
'ok)
)
(mac profile (f)
`(do
(= (originals* ',f) ,f)
(= ,f (profiled ,f))
(warn (+ ,(string f)
" is being profiled; "
"do not redefine it until you (unprofile " ,(string f) ")"))
t))
(mac unprofile (f)
`(= ,f (originals* ',f ,f)
(originals* ',f) nil
(profiles* ',f) nil))
(def profiles ((o profiler-data profiles*))
(withs (data ; avoid counting stuff from the current call to (profiles)
(with (atomic-invokes (profiler-data 'atomic-invoke)
tables (profiler-data 'table)
srefs (profiler-data 'sref)
new (table))
(maptable (fn (k v) (= (new k) v)) profiler-data)
(= (new 'atomic-invoke) atomic-invokes
(new 'table) tables
(new 'sref) srefs)
new)
lhead "Function"
rhead "Call Count"
lwidth (apply max (map len:tostring:disp (cons lhead (keys data))))
prnrow (fn (l r)
(w/bars
(do (pr l) (sp (- lwidth (len l))))
(prn r))))
(prn)
(prnrow lhead rhead)
(each (f call-count) (sortable data)
(prnrow (tostring:disp f) call-count))
(prn)))
(mac profiling-just (fns . bod)
(unless (acons fns)
(zap list fns))
(w/uniq (profiles profiled)
(let originals (map [uniq] fns)
`(with (,profiles (table)
,profiled profiled-as
,@(mappend list originals fns))
; ,@(map (fn (f) `(= (,profiles ',f) 0)) fns)
,@(map (fn (f o) `(= ,f (,profiled ',f ,o ,profiles)))
fns
originals)
(after (do ,@bod)
(= ,@(apply + nil (map list fns originals)))
(if (> (,profiles 'protect 0) 1) ; from (after ...)
(-- (,profiles 'protect))
(wipe (,profiles 'protect)))
(profiles ,profiles))))))
(def all-fns ()
(let xdefs '(apply cons car cdr is err + - * / mod expt sqrt > < len annotate
type rep uniq ccc infile outfile instring outstring inside
stdout stdin stderr call-w/stdout call-w/stdin readc readb peekc
writec writeb write disp sread coerce open-socket socket-accept
setuid new-thread kill-thread break-thread current-thread sleep
system pipe-from table protect rand dir file-exists dir-exists
rmfile mvfile macex macex1 eval on-err details scar scdr sref
bound newstring trunc exact msec current-process-milliseconds
current-gc-milliseconds seconds client-ip atomic-invoke dead
flushout ssyntax ssexpand quit close force-close memory declare
timedate sin cos tan asin acos atan log)
(+ xdefs (keep [isa (eval _) 'fn] (keys sig*)))))
(mac profile-all ()
(with (fns (all-fns) orig-atomic-invoke (uniq) orig-sref (uniq))
`(with (,orig-sref sref
,orig-atomic-invoke atomic-invoke)
(do ,@(map (fn (f) `(profile ,f)) fns)
,@(map (fn (f) `(,orig-atomic-invoke
(fn () (,orig-sref profiles* nil ',f))))
fns)
t))))
(mac unprofile-all ()
`(do ,@(map (fn (f) `(unprofile ,f)) (keys originals*))))
(mac profiling code
`(profiling-just ,(all-fns) ,@code))
(mac profile-here (marker . code)
; (= (profiles* marker) 0)
`(do1 (do ,@code)
(++ (profiles* ',marker 0))))
|