| profile-points next-profile-point-p ! |
profile-points next-profile-point-p ! |
| variable last-colondef-profile \ pointer to the pp of last colon definition |
variable last-colondef-profile \ pointer to the pp of last colon definition |
| variable current-profile-point |
variable current-profile-point |
| variable library-calls \ list of calls to library colon defs |
variable library-calls 0 library-calls ! \ list of calls to library colon defs |
| variable in-compile,? in-compile,? off |
variable in-compile,? in-compile,? off |
| |
|
| \ list stuff |
\ list stuff |
| : call-count+ ( ud1 callp -- ud2 ) |
: call-count+ ( ud1 callp -- ud2 ) |
| calls-call @ profile-count 2@ d+ ; |
calls-call @ profile-count 2@ d+ ; |
| |
|
| : add-calls ( ud-dyn-callee1 ud-dyn-caller1 u-stat1 xt-test profpp -- |
: count-dyncalls ( calls -- ud ) |
| ud-dyn-callee2 ud-dyn-caller2 u-stat2 xt-test ) |
0. rot ['] call-count+ map-list ; |
| \ add the static and dynamic call counts to profpp up, if the |
|
| \ number of static calls to profpp satisfies xt-test ( u -- f ) |
: add-calls ( statistics1 xt-test profpp -- statistics2 xt-test ) |
| |
\ add statistics for callee profpp up, if the number of static |
| |
\ calls to profpp satisfies xt-test ( u -- f ); see below for what |
| |
\ statistics are computed. |
| { xt-test p } |
{ xt-test p } |
| p profile-colondef? @ if ( u-dyn1 u-stat1 ) |
p profile-colondef? @ if |
| p profile-calls @ { calls } |
p profile-calls @ { calls } |
| calls list-length { stat } |
calls list-length { stat } |
| stat xt-test execute if ( u-dyn u-stat ) |
stat xt-test execute if |
| stat + >r |
{ d: ud-dyn-callee d: ud-dyn-caller u-stat u-exec-callees u-callees } |
| 0. calls ['] call-count+ map-list d+ 2>r |
ud-dyn-callee p profile-count 2@ 2dup { d: de } d+ |
| p profile-count 2@ d+ |
ud-dyn-caller calls count-dyncalls 2dup { d: dr } d+ |
| 2r> r> |
u-stat stat + |
| |
u-exec-callees de dr d<> - |
| |
u-callees 1+ |
| endif |
endif |
| endif |
endif |
| xt-test ; |
xt-test ; |
| |
|
| : print-stat-line ( xt -- ) |
: print-stat-line ( xt -- ) |
| >r 0. 0. 0 r> profile-points @ ['] add-calls map-list drop |
>r 0. 0. 0 0 0 r> profile-points @ ['] add-calls map-list drop |
| ( ud-dyn-callee ud-dyn-caller u-stat ) |
( ud-dyn-callee ud-dyn-caller u-stat ) |
| 7 u.r 12 ud.r 12 ud.r space ; |
6 u.r 7 u.r 7 u.r 12 ud.r 12 ud.r space ; |
| |
|
| |
: print-library-stats ( -- ) |
| |
library-calls @ list-length 20 u.r \ static callers |
| |
library-calls @ count-dyncalls 12 ud.r \ dynamic callers |
| |
13 spaces ; |
| |
|
| : print-statistics ( -- ) |
: print-statistics ( -- ) |
| ." static dyn-caller dyn-callee condition" cr |
." callee exec'd static dyn-caller dyn-callee condition" cr |
| ['] 0= print-stat-line ." calls to coldefs with 0 callers" cr |
['] 0= print-stat-line ." calls to coldefs with 0 callers" cr |
| ['] 1= print-stat-line ." calls to coldefs with 1 callers" cr |
['] 1= print-stat-line ." calls to coldefs with 1 callers" cr |
| ['] 2= print-stat-line ." calls to coldefs with 2 callers" cr |
['] 2= print-stat-line ." calls to coldefs with 2 callers" cr |
| ['] 3= print-stat-line ." calls to coldefs with 3 callers" cr |
['] 3= print-stat-line ." calls to coldefs with 3 callers" cr |
| ['] 1u> print-stat-line ." calls to coldefs with >1 callers" cr |
['] 1u> print-stat-line ." calls to coldefs with >1 callers" cr |
| |
print-library-stats ." library calls" cr |
| ; |
; |
| |
|
| : dinc ( profilep -- ) |
: dinc ( profilep -- ) |
| |
|
| : note-call ( addr -- ) |
: note-call ( addr -- ) |
| \ addr is the body address of a called colon def or does handler |
\ addr is the body address of a called colon def or does handler |
| dup 3 cells + @ ['] dinc >body = if ( addr ) |
dup ['] (does>2) >body = if \ adjust does handler address |
| profile-this |
4 cells here 1 cells - +! |
| current-profile-point @ new-call over cell+ @ profile-calls insert-list |
|
| endif |
endif |
| drop ; |
profile-this current-profile-point @ new-call |
| |
over 3 cells + @ ['] dinc >body = if ( addr call-prof-point ) |
| |
\ non-library call |
| |
swap cell+ @ profile-calls insert-list |
| |
else ( addr call-prof-point ) |
| |
library-calls insert-list drop |
| |
endif ; |
| |
|
| : prof-compile, ( xt -- ) |
: prof-compile, ( xt -- ) |
| in-compile,? @ if |
in-compile,? @ if |
