Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
metering
Project overview
Project overview
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
3
Issues
3
List
Boards
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Daniel Kochmański
metering
Commits
8c74ad6c
Commit
8c74ad6c
authored
Feb 26, 2016
by
Daniel Kochmański
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
cosmetic: untabify, improve .gitignore
parent
17bf4145
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
337 additions
and
337 deletions
+337
-337
.gitignore
.gitignore
+2
-0
metering.cl
metering.cl
+335
-337
No files found.
.gitignore
View file @
8c74ad6c
*~
*.xcl
*.abcl
*.lib
*.o
...
...
metering.cl
View file @
8c74ad6c
...
...
@@ -319,13 +319,13 @@ Estimated total monitoring overhead: 0.88 seconds
(
provide
"monitor"
)
(
export
'
(
*monitored-functions*
monitor
monitor-all
unmonitor
monitor-form
with-monitoring
reset-monitoring-info
reset-all-monitoring
monitored
report-monitoring
display-monitoring-results
monitoring-encapsulate
monitoring-unencapsulate
))
monitor
monitor-all
unmonitor
monitor-form
with-monitoring
reset-monitoring-info
reset-all-monitoring
monitored
report-monitoring
display-monitoring-results
monitoring-encapsulate
monitoring-unencapsulate
))
;;; Warn user if they're loading the source instead of compiling it first.
...
...
@@ -396,10 +396,10 @@ Estimated total monitoring overhead: 0.88 seconds
#+
clisp
(
defmacro
get-cons
()
`
(
the
consing-type
(
multiple-value-bind
(
real1
real2
run1
run2
gc1
gc2
space1
space2
gccount
)
(
sys::%%time
)
(
declare
(
ignore
real1
real2
run1
run2
gc1
gc2
gccount
))
(
dpb
space1
(
byte
24
24
)
space2
))))
(
multiple-value-bind
(
real1
real2
run1
run2
gc1
gc2
space1
space2
gccount
)
(
sys::%%time
)
(
declare
(
ignore
real1
real2
run1
run2
gc1
gc2
gccount
))
(
dpb
space1
(
byte
24
24
)
space2
))))
#+
clozure
(
defmacro
get-cons
()
...
...
@@ -420,8 +420,8 @@ Estimated total monitoring overhead: 0.88 seconds
(
eval-when
(
compile
load
)
(
defmacro
get-cons
()
`
(
the
consing-type
(
ffi:c-inline
()
()
:object
"ecl_make_unsigned_integer(GC_get_total_bytes())"
:one-liner
t
))))
"ecl_make_unsigned_integer(GC_get_total_bytes())"
:one-liner
t
))))
#-
(
or
cmu
clisp
clozure
ecl
)
(
progn
...
...
@@ -447,23 +447,23 @@ Estimated total monitoring overhead: 0.88 seconds
(
defun
required-arguments
(
name
)
(
let
((
type
(
ext:info
function
type
name
)))
(
cond
((
not
(
kernel:function-type-p
type
))
(
warn
"No argument count information available for:~% ~S~@
Allow for &rest arg consing."
name
)
(
values
0
t
))
(
t
(
values
(
length
(
kernel:function-type-required
type
))
(
if
(
or
(
kernel:function-type-optional
type
)
(
kernel:function-type-keyp
type
)
(
kernel:function-type-rest
type
))
t
nil
))))))
(
warn
"No argument count information available for:~% ~S~@
Allow for &rest arg consing."
name
)
(
values
0
t
))
(
t
(
values
(
length
(
kernel:function-type-required
type
))
(
if
(
or
(
kernel:function-type-optional
type
)
(
kernel:function-type-keyp
type
)
(
kernel:function-type-rest
type
))
t
nil
))))))
;;; Allegro and Clozure Common Lisp
#+
(
or
allegro
clozure
)
(
defun
required-arguments
(
name
)
(
let*
((
function
(
fdefinition
name
))
(
args
#+
allegro
(
excl::arglist
function
)
#+
clozure
(
ccl:arglist
function
))
#+
clozure
(
ccl:arglist
function
))
(
pos
(
position-if
#'
(
lambda
(
x
)
(
and
(
symbolp
x
)
(
let
((
name
(
symbol-name
x
)))
...
...
@@ -481,25 +481,25 @@ Estimated total monitoring overhead: 0.88 seconds
(
case
(
type-of
function
)
(
FUNCTION
(
if
(
compiled-function-p
function
)
(
multiple-value-bind
(
req-anz
opt-anz
rest-p
key-p
keyword-list
allow-other-keys-p
)
(
sys::signature
function
)
(
declare
(
ignore
keyword-list
allow-other-keys-p
))
(
values
req-anz
(
or
(
plusp
opt-anz
)
rest-p
key-p
)))
(
let
((
lambdalist
(
car
(
sys::%record-ref
function
1
))))
(
values
(
or
(
position-if
#'
(
lambda
(
x
)
(
member
x
lambda-list-keywords
))
lambdalist
)
(
length
lambdalist
))
(
and
(
intersection
lambdalist
lambda-list-keywords
)
t
)))))
(
multiple-value-bind
(
req-anz
opt-anz
rest-p
key-p
keyword-list
allow-other-keys-p
)
(
sys::signature
function
)
(
declare
(
ignore
keyword-list
allow-other-keys-p
))
(
values
req-anz
(
or
(
plusp
opt-anz
)
rest-p
key-p
)))
(
let
((
lambdalist
(
car
(
sys::%record-ref
function
1
))))
(
values
(
or
(
position-if
#'
(
lambda
(
x
)
(
member
x
lambda-list-keywords
))
lambdalist
)
(
length
lambdalist
))
(
and
(
intersection
lambdalist
lambda-list-keywords
)
t
)))))
(
COMPILED-FUNCTION
(
multiple-value-bind
(
name
req-anz
opt-anz
rest-p
keywords
allow-other-keys
)
(
sys::subr-info
function
)
(
declare
(
ignore
allow-other-keys
))
(
if
name
(
values
req-anz
(
or
(
plusp
opt-anz
)
rest-p
keywords
))
(
values
0
t
))))
keywords
allow-other-keys
)
(
sys::subr-info
function
)
(
declare
(
ignore
allow-other-keys
))
(
if
name
(
values
req-anz
(
or
(
plusp
opt-anz
)
rest-p
keywords
))
(
values
0
t
))))
(
T
(
values
0
t
)))))
#-
(
or
cmu
clisp
clozure
allegro
)
...
...
@@ -594,13 +594,13 @@ variables/arrays/structures."
(
defstruct
metering-functions
(
name
nil
)
(
old-definition
(
error
"Missing required keyword argument :old-definition"
)
:type
function
)
:type
function
)
(
new-definition
(
error
"Missing required keyword argument :new-definition"
)
:type
function
)
:type
function
)
(
read-metering
(
error
"Missing required keyword argument :read-metering"
)
:type
function
)
:type
function
)
(
reset-metering
(
error
"Missing required keyword argument :reset-metering"
)
:type
function
))
:type
function
))
;;; In general using hash tables in time-critical programs is a bad idea,
;;; because when one has to grow the table and rehash everything, the
...
...
@@ -622,7 +622,7 @@ variables/arrays/structures."
(
defun
MONITORED
(
function-place
)
"Test to see if a FUNCTION-PLACE is monitored."
(
and
(
place-fboundp
function-place
)
; this line necessary?
(
and
(
place-fboundp
function-place
)
; this line necessary?
(
get-monitor-info
function-place
)))
(
defun
reset-monitoring-info
(
name
)
...
...
@@ -633,8 +633,8 @@ variables/arrays/structures."
(
defun
reset-all-monitoring
()
"Reset monitoring info for all functions."
(
setq
*total-time*
0
*total-cons*
0
*total-calls*
0
)
*total-cons*
0
*total-calls*
0
)
(
dolist
(
symbol
*monitored-functions*
)
(
when
(
monitored
symbol
)
(
reset-monitoring-info
symbol
))))
...
...
@@ -644,36 +644,36 @@ variables/arrays/structures."
adjusted for overhead."
(
let
((
finfo
(
get-monitor-info
name
)))
(
if
finfo
(
multiple-value-bind
(
inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls
)
(
funcall
(
metering-functions-read-metering
finfo
))
(
unless
(
or
(
null
warn
)
(
eq
(
place-function
name
)
(
metering-functions-new-definition
finfo
)))
(
warn
"Funtion ~S has been redefined, so times may be inaccurate.~@
(
multiple-value-bind
(
inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls
)
(
funcall
(
metering-functions-read-metering
finfo
))
(
unless
(
or
(
null
warn
)
(
eq
(
place-function
name
)
(
metering-functions-new-definition
finfo
)))
(
warn
"Funtion ~S has been redefined, so times may be inaccurate.~@
MONITOR it again to record calls to the new definition."
name
))
(
case
nested
(
:exclusive
(
values
calls
nested-calls
(
-
exclusive-time
(
*
calls
*monitor-time-overhead*
))
(
-
exclusive-cons
(
*
calls
*monitor-cons-overhead*
))))
;; In :inclusive mode, subtract overhead for all the
;; called functions as well. Nested-calls includes the
;; calls of the function as well. [Necessary 'cause of
;; functions which call themselves recursively.]
(
:inclusive
(
values
calls
nested-calls
(
-
inclusive-time
(
*
nested-calls
;(+ calls)
*monitor-time-overhead*
))
(
-
inclusive-cons
(
*
nested-calls
;(+ calls)
*monitor-cons-overhead*
))))))
(
values
0
0
0
0
))))
name
))
(
case
nested
(
:exclusive
(
values
calls
nested-calls
(
-
exclusive-time
(
*
calls
*monitor-time-overhead*
))
(
-
exclusive-cons
(
*
calls
*monitor-cons-overhead*
))))
;; In :inclusive mode, subtract overhead for all the
;; called functions as well. Nested-calls includes the
;; calls of the function as well. [Necessary 'cause of
;; functions which call themselves recursively.]
(
:inclusive
(
values
calls
nested-calls
(
-
inclusive-time
(
*
nested-calls
;(+ calls)
*monitor-time-overhead*
))
(
-
inclusive-cons
(
*
nested-calls
;(+ calls)
*monitor-cons-overhead*
))))))
(
values
0
0
0
0
))))
;;; ********************************
;;; Encapsulate ********************
...
...
@@ -692,100 +692,100 @@ adjusted for overhead."
(
dotimes
(
i
min-args
)
(
push
(
gensym
)
required-args
))
`
(
lambda
(
name
)
(
let
((
inclusive-time
0
)
(
inclusive-cons
0
)
(
exclusive-time
0
)
(
exclusive-cons
0
)
(
calls
0
)
(
nested-calls
0
)
(
old-definition
(
place-function
name
)))
(
declare
(
type
time-type
inclusive-time
)
(
type
time-type
exclusive-time
)
(
type
consing-type
inclusive-cons
)
(
type
consing-type
exclusive-cons
)
(
fixnum
calls
)
(
fixnum
nested-calls
))
(
pushnew
name
*monitored-functions*
)
(
setf
(
place-function
name
)
#'
(
lambda
(
,@
required-args
,@
(
when
optionals-p
`
(
&rest
optional-args
)))
,
(
when
optionals-p
;; &rest optional-args can be stack allocated
`
(
declare
(
dynamic-extent
optional-args
)))
(
let
((
prev-total-time
*total-time*
)
(
prev-total-cons
*total-cons*
)
(
prev-total-calls
*total-calls*
)
;
(old-time inclusive-time)
;
(old-cons inclusive-cons)
;
(old-nested-calls nested-calls)
(
start-time
(
get-time
))
(
start-cons
(
get-cons
)))
(
declare
(
type
time-type
prev-total-time
)
(
type
time-type
start-time
)
(
type
consing-type
prev-total-cons
)
(
type
consing-type
start-cons
)
(
fixnum
prev-total-calls
))
(
multiple-value-prog1
,
(
if
optionals-p
`
(
apply
old-definition
,@
required-args
optional-args
)
`
(
funcall
old-definition
,@
required-args
))
(
let
((
delta-time
(
-
(
get-time
)
start-time
))
(
delta-cons
(
-
(
get-cons
)
start-cons
)))
;; Calls
(
incf
calls
)
(
incf
*total-calls*
)
;;; nested-calls includes this call
(
incf
nested-calls
(
the
fixnum
(
-
*total-calls*
prev-total-calls
)))
;
(setf nested-calls (+ old-nested-calls
;
(- *total-calls*
;
prev-total-calls)))
;; Time
;;; Problem with inclusive time is that it
;;; currently doesn't add values from recursive
;;; calls to the same function. Change the
;;; setf to an incf to fix this?
(
incf
inclusive-time
(
the
time-type
delta-time
))
;
(setf inclusive-time (+ delta-time old-time))
(
incf
exclusive-time
(
the
time-type
(
+
delta-time
(
-
prev-total-time
*total-time*
))))
(
setf
*total-time*
(
the
time-type
(
+
delta-time
prev-total-time
)))
;; Consing
(
incf
inclusive-cons
(
the
consing-type
delta-cons
))
;
(setf inclusive-cons (+ delta-cons old-cons))
(
incf
exclusive-cons
(
the
consing-type
(
+
delta-cons
(
-
prev-total-cons
*total-cons*
))))
(
setf
*total-cons*
(
the
consing-type
(
+
delta-cons
prev-total-cons
))))))))
(
setf
(
get-monitor-info
name
)
(
make-metering-functions
:name
name
:old-definition
old-definition
:new-definition
(
place-function
name
)
:read-metering
#'
(
lambda
()
(
values
inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls
))
:reset-metering
#'
(
lambda
()
(
setq
inclusive-time
0
inclusive-cons
0
exclusive-time
0
exclusive-cons
0
calls
0
nested-calls
0
)
t
)))))))
(
inclusive-cons
0
)
(
exclusive-time
0
)
(
exclusive-cons
0
)
(
calls
0
)
(
nested-calls
0
)
(
old-definition
(
place-function
name
)))
(
declare
(
type
time-type
inclusive-time
)
(
type
time-type
exclusive-time
)
(
type
consing-type
inclusive-cons
)
(
type
consing-type
exclusive-cons
)
(
fixnum
calls
)
(
fixnum
nested-calls
))
(
pushnew
name
*monitored-functions*
)
(
setf
(
place-function
name
)
#'
(
lambda
(
,@
required-args
,@
(
when
optionals-p
`
(
&rest
optional-args
)))
,
(
when
optionals-p
;; &rest optional-args can be stack allocated
`
(
declare
(
dynamic-extent
optional-args
)))
(
let
((
prev-total-time
*total-time*
)
(
prev-total-cons
*total-cons*
)
(
prev-total-calls
*total-calls*
)
;
(old-time inclusive-time)
;
(old-cons inclusive-cons)
;
(old-nested-calls nested-calls)
(
start-time
(
get-time
))
(
start-cons
(
get-cons
)))
(
declare
(
type
time-type
prev-total-time
)
(
type
time-type
start-time
)
(
type
consing-type
prev-total-cons
)
(
type
consing-type
start-cons
)
(
fixnum
prev-total-calls
))
(
multiple-value-prog1
,
(
if
optionals-p
`
(
apply
old-definition
,@
required-args
optional-args
)
`
(
funcall
old-definition
,@
required-args
))
(
let
((
delta-time
(
-
(
get-time
)
start-time
))
(
delta-cons
(
-
(
get-cons
)
start-cons
)))
;; Calls
(
incf
calls
)
(
incf
*total-calls*
)
;;; nested-calls includes this call
(
incf
nested-calls
(
the
fixnum
(
-
*total-calls*
prev-total-calls
)))
;
(setf nested-calls (+ old-nested-calls
;
(- *total-calls*
;
prev-total-calls)))
;; Time
;;; Problem with inclusive time is that it
;;; currently doesn't add values from recursive
;;; calls to the same function. Change the
;;; setf to an incf to fix this?
(
incf
inclusive-time
(
the
time-type
delta-time
))
;
(setf inclusive-time (+ delta-time old-time))
(
incf
exclusive-time
(
the
time-type
(
+
delta-time
(
-
prev-total-time
*total-time*
))))
(
setf
*total-time*
(
the
time-type
(
+
delta-time
prev-total-time
)))
;; Consing
(
incf
inclusive-cons
(
the
consing-type
delta-cons
))
;
(setf inclusive-cons (+ delta-cons old-cons))
(
incf
exclusive-cons
(
the
consing-type
(
+
delta-cons
(
-
prev-total-cons
*total-cons*
))))
(
setf
*total-cons*
(
the
consing-type
(
+
delta-cons
prev-total-cons
))))))))
(
setf
(
get-monitor-info
name
)
(
make-metering-functions
:name
name
:old-definition
old-definition
:new-definition
(
place-function
name
)
:read-metering
#'
(
lambda
()
(
values
inclusive-time
inclusive-cons
exclusive-time
exclusive-cons
calls
nested-calls
))
:reset-metering
#'
(
lambda
()
(
setq
inclusive-time
0
inclusive-cons
0
exclusive-time
0
exclusive-cons
0
calls
0
nested-calls
0
)
t
)))))))
)
;; End of EVAL-WHEN
;;; For efficiency reasons, we precompute the encapsulation functions
...
...
@@ -801,54 +801,54 @@ adjusted for overhead."
(
defun
find-encapsulation
(
min-args
optionals-p
)
(
or
(
gethash
(
cons
min-args
optionals-p
)
*existing-encapsulations*
)
(
setf
(
gethash
(
cons
min-args
optionals-p
)
*existing-encapsulations*
)
(
compile
nil
(
make-monitoring-encapsulation
min-args
optionals-p
)))))
(
compile
nil
(
make-monitoring-encapsulation
min-args
optionals-p
)))))
(
macrolet
((
frob
()
(
let
((
res
()))
(
dotimes
(
i
precomputed-encapsulations
)
(
push
`
(
setf
(
gethash
'
(
,
i
.
nil
)
*existing-encapsulations*
)
#'
,
(
make-monitoring-encapsulation
i
nil
))
res
)
(
push
`
(
setf
(
gethash
'
(
,
i
.
t
)
*existing-encapsulations*
)
#'
,
(
make-monitoring-encapsulation
i
t
))
res
))
`
(
progn
,@
res
))))
(
let
((
res
()))
(
dotimes
(
i
precomputed-encapsulations
)
(
push
`
(
setf
(
gethash
'
(
,
i
.
nil
)
*existing-encapsulations*
)
#'
,
(
make-monitoring-encapsulation
i
nil
))
res
)
(
push
`
(
setf
(
gethash
'
(
,
i
.
t
)
*existing-encapsulations*
)
#'
,
(
make-monitoring-encapsulation
i
t
))
res
))
`
(
progn
,@
res
))))
(
frob
))
(
defun
monitoring-encapsulate
(
name
&optional
warn
)
"Monitor the function Name. If already monitored, unmonitor first."
;; Saves the current definition of name and inserts a new function which
;; returns the result of evaluating body.
(
cond
((
not
(
place-fboundp
name
))
; not a function
(
when
warn
(
warn
"Ignoring undefined function ~S."
name
)))
((
place-macrop
name
)
; a macro
(
when
warn
(
warn
"Ignoring macro ~S."
name
)))
(
t
; tis a function
(
when
(
get-monitor-info
name
)
; monitored
(
when
warn
(
warn
"~S already monitored, so unmonitoring it first."
name
))
(
monitoring-unencapsulate
name
))
(
multiple-value-bind
(
min-args
optionals-p
)
(
required-arguments
name
)
(
funcall
(
find-encapsulation
min-args
optionals-p
)
name
)))))
(
cond
((
not
(
place-fboundp
name
))
; not a function
(
when
warn
(
warn
"Ignoring undefined function ~S."
name
)))
((
place-macrop
name
)
; a macro
(
when
warn
(
warn
"Ignoring macro ~S."
name
)))
(
t
; tis a function
(
when
(
get-monitor-info
name
)
; monitored
(
when
warn
(
warn
"~S already monitored, so unmonitoring it first."
name
))
(
monitoring-unencapsulate
name
))
(
multiple-value-bind
(
min-args
optionals-p
)
(
required-arguments
name
)
(
funcall
(
find-encapsulation
min-args
optionals-p
)
name
)))))
(
defun
monitoring-unencapsulate
(
name
&optional
warn
)
"Removes monitoring encapsulation code from around Name."
(
let
((
finfo
(
get-monitor-info
name
)))
(
when
finfo
; monitored
(
when
finfo
; monitored
(
remprop
name
'metering-functions
)
(
setq
*monitored-functions*
(
remove
name
*monitored-functions*
:test
#'
equal
))
(
remove
name
*monitored-functions*
:test
#'
equal
))
(
if
(
eq
(
place-function
name
)
(
metering-functions-new-definition
finfo
))
(
setf
(
place-function
name
)
(
metering-functions-old-definition
finfo
))
(
when
warn
(
warn
"Preserving current definition of redefined function ~S."
name
))))))
(
metering-functions-new-definition
finfo
))
(
setf
(
place-function
name
)
(
metering-functions-old-definition
finfo
))
(
when
warn
(
warn
"Preserving current definition of redefined function ~S."
name
))))))
;;; ********************************
;;; Main Monitoring Functions ******
...
...
@@ -867,45 +867,45 @@ adjusted for overhead."
"Remove the monitoring on the named functions.
Names defaults to the list of all currently monitored functions."
`
(
dolist
(
name
,
(
if
names
`
',names
'*monitored-functions*
)
(
values
))
(
monitoring-unencapsulate
name
)))
(
monitoring-unencapsulate
name
)))
(
defun
MONITOR-ALL
(
&optional
(
package
*package*
))
"Monitor all functions in the specified package."
(
let
((
package
(
if
(
symbolp
package
)
(
find-package
package
)
package
)))
(
find-package
package
)
package
)))
(
do-symbols
(
symbol
package
)
(
when
(
eq
(
symbol-package
symbol
)
package
)
(
monitoring-encapsulate
symbol
)))))
(
monitoring-encapsulate
symbol
)))))
(
defmacro
MONITOR-FORM
(
form
&optional
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
))
&optional
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
))
"Monitor the execution of all functions in the current package
during the execution of FORM. All functions that are executed above
THRESHOLD % will be reported."
`
(
unwind-protect
(
progn
(
monitor-all
)
(
reset-all-monitoring
)
(
prog1
(
time
,
form
)
(
report-monitoring
:all
,
nested
,
threshold
,
key
:ignore-no-calls
)))
(
monitor-all
)
(
reset-all-monitoring
)
(
prog1
(
time
,
form
)
(
report-monitoring
:all
,
nested
,
threshold
,
key
:ignore-no-calls
)))
(
unmonitor
)))
(
defmacro
WITH-MONITORING
((
&rest
functions
)
(
&optional
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
))
&body
body
)
(
&optional
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
))
&body
body
)
"Monitor the specified functions during the execution of the body."
`
(
unwind-protect
(
progn
(
dolist
(
fun
',functions
)
(
monitoring-encapsulate
fun
))
(
reset-all-monitoring
)
,@
body
(
report-monitoring
:all
,
nested
,
threshold
,
key
))
(
dolist
(
fun
',functions
)
(
monitoring-encapsulate
fun
))
(
reset-all-monitoring
)
,@
body
(
report-monitoring
:all
,
nested
,
threshold
,
key
))
(
unmonitor
)))
;;; ********************************
...
...
@@ -924,7 +924,7 @@ THRESHOLD % will be reported."
"Determines the average overhead of monitoring by monitoring the execution
of an empty function many times."
(
setq
*monitor-time-overhead*
0
*monitor-cons-overhead*
0
)
*monitor-cons-overhead*
0
)
(
stub-function
nil
)
(
monitor
stub-function
)
(
reset-all-monitoring
)
...
...
@@ -935,10 +935,10 @@ of an empty function many times."
; (stub-function nil))
(
let
((
fiter
(
float
overhead-iterations
)))
(
multiple-value-bind
(
calls
nested-calls
time
cons
)
(
monitor-info-values
'stub-function
)
(
monitor-info-values
'stub-function
)
(
declare
(
ignore
calls
nested-calls
))
(
setq
*monitor-time-overhead*
(
truncate
(
/
time
fiter
))
*monitor-cons-overhead*
(
truncate
(
/
cons
fiter
)))))
*monitor-cons-overhead*
(
truncate
(
/
cons
fiter
)))))
(
unmonitor
stub-function
))
(
set-monitor-overhead
)
...
...
@@ -953,11 +953,11 @@ of an empty function many times."
(
proclaim
'
(
type
time-type
*estimated-total-overhead*
))
(
defstruct
(
monitoring-info
(
:conc-name
m-info-
)
(
:constructor
make-monitoring-info
(
name
calls
time
cons
percent-time
percent-cons
time-per-call
cons-per-call
)))
(
:conc-name
m-info-
)
(
:constructor
make-monitoring-info
(
name
calls
time
cons
percent-time
percent-cons
time-per-call
cons-per-call
)))
name
calls
time
...
...
@@ -968,10 +968,10 @@ of an empty function many times."
cons-per-call
)
(
defun
REPORT-MONITORING
(
&optional
names
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
)
ignore-no-calls
)
(
nested
:exclusive
)
(
threshold
0.01
)
(
key
:percent-time
)
ignore-no-calls
)
"Report the current monitoring state.
The percentage of the total time spent executing unmonitored code
in each function (:exclusive mode), or total time (:inclusive mode)
...
...
@@ -981,134 +981,132 @@ below THRESHOLD % of the time will not be reported."
(
when
(
or
(
null
names
)
(
eq
names
:all
))
(
setq
names
*monitored-functions*
))
(
let
((
total-time
0
)
(
total-cons
0
)
(
total-calls
0
))
(
total-cons
0
)
(
total-calls
0
))
;; Compute overall time and consing.
(
dolist
(
name
names
)
(
multiple-value-bind
(
calls
nested-calls
time
cons
)
(
monitor-info-values
name
nested
:warn
)
(
declare
(
ignore
nested-calls
))
(
incf
total-calls
calls
)
(
incf
total-time
time
)
(
incf
total-cons
cons
)))
(
monitor-info-values
name
nested
:warn
)
(
declare
(
ignore
nested-calls
))
(
incf
total-calls
calls
)
(
incf
total-time
time
)
(
incf
total-cons
cons
)))
;; Total overhead.
(
setq
*estimated-total-overhead*
(
/
(
*
*monitor-time-overhead*
total-calls
)
time-units-per-second
))
(
setq
*estimated-total-overhead*
(
/
(
*
*monitor-time-overhead*
total-calls
)
time-units-per-second
))
;; Assemble data for only the specified names (all monitored functions)
(
if
(
zerop
total-time
)
(
format
*trace-output*
"Not enough execution time to monitor."
)
(
progn
(
setq
*monitor-results*
nil
*no-calls*
nil
)
(
dolist
(
name
names
)
(
multiple-value-bind
(
calls
nested-calls
time
cons
)
(
monitor-info-values
name
nested
)
(
declare
(
ignore
nested-calls
))
(
when
(
minusp
time
)
(
setq
time
0.0
))
(
when
(
minusp
cons
)
(
setq
cons
0.0
))
(
if
(
zerop
calls
)
(
push
(
if
(
symbolp
name
)
(
symbol-name
name
)
(
format
nil
"~S"
name
))
*no-calls*
)
(
push
(
make-monitoring-info
(
format
nil
"~S"
name
)
; name
calls
; calls
(
/
time
(
float
time-units-per-second
))
; time in secs
(
round
cons
)
; consing
(
/
time
(
float
total-time
))
; percent-time
(
if
(
zerop
total-cons
)
0
(
/
cons
(
float
total-cons
)))
; percent-cons
(
/
(
/
time
(
float
calls
))
; time-per-call
time-units-per-second
)
; sec/call
(
round
(
/
cons
(
float
calls
))))
; cons-per-call
*monitor-results*
))))
(
display-monitoring-results
threshold
key
ignore-no-calls
)))))
(
format
*trace-output*
"Not enough execution time to monitor."
)
(
progn
(
setq
*monitor-results*
nil
*no-calls*
nil
)
(
dolist
(
name
names
)
(
multiple-value-bind
(
calls
nested-calls
time
cons
)
(
monitor-info-values
name
nested
)
(
declare
(
ignore
nested-calls
))
(
when
(
minusp
time
)
(
setq
time
0.0
))
(
when
(
minusp
cons
)
(
setq
cons
0.0
))
(
if
(
zerop
calls
)
(
push
(
if
(
symbolp
name
)
(
symbol-name
name
)
(
format
nil
"~S"
name
))
*no-calls*
)
(
push
(
make-monitoring-info
(
format
nil
"~S"
name
)
; name
calls
; calls
(
/
time
(
float
time-units-per-second
))
; time in secs
(
round
cons
)
; consing
(
/
time
(
float
total-time
))
; percent-time
(
if
(
zerop
total-cons
)
0
(
/
cons
(
float
total-cons
)))
; percent-cons
(
/
(
/
time
(
float
calls
))
; time-per-call
time-units-per-second
)
; sec/call
(
round
(
/
cons
(
float
calls
))))
; cons-per-call
*monitor-results*
))))
(
display-monitoring-results
threshold
key
ignore-no-calls
)))))
(
defun
display-monitoring-results
(
&optional
(
threshold
0.01
)
(
key
:percent-time
)
(
ignore-no-calls
t
))
(
let
((
max-length
8
)
; Function header size
(
total-time
0.0
)
(
total-consed
0
)
(
total-calls
0
)