version 1.4, 2004/09/06 18:15:05
|
version 1.7, 2004/09/13 07:32:37
|
Line 56 struct
|
Line 56 struct
|
end-struct list% |
end-struct list% |
|
|
list% |
list% |
cell% 2* field profile-count |
cell% 2* field profile-count \ how often this profile point is performed |
cell% 2* field profile-sourcepos |
cell% 2* field profile-sourcepos |
cell% field profile-char \ character position in line |
cell% field profile-char \ character position in line |
count-calls? [if] |
cell% field profile-bblen \ number of primitives in BB |
cell% field profile-colondef? \ is this a colon definition start |
cell% field profile-bblenpi \ bblen after partial inlining |
cell% field profile-calls \ static calls to the colon def (calls%) |
cell% field profile-callee-postlude \ 0 or (for calls) callee postlude len |
cell% field profile-straight-line \ may contain calls, but no other CF |
cell% field profile-tailof \ 0 or (for tail bbs) pointer to coldef bb |
cell% field profile-calls-from \ static calls in the colon def |
cell% field profile-colondef? \ is this a colon definition start |
[endif] |
cell% field profile-calls \ static calls to the colon def (calls%) |
end-struct profile% \ profile point |
cell% field profile-straight-line \ may contain calls, but no other CF |
|
cell% field profile-calls-from \ static calls in the colon def |
|
cell% field profile-exits \ number of exits in this colon def |
|
cell% 2* field profile-execs \ number of EXECUTEs etc. of this colon def |
|
cell% field profile-prelude \ first BB-len of colon def (incl. callee) |
|
cell% field profile-postlude \ last BB-len of colon def (incl. callee) |
|
end-struct profile% \ profile point |
|
|
list% |
list% |
cell% field calls-call \ ptr to profile point of bb containing the call |
cell% field calls-call \ ptr to profile point of bb containing the call |
Line 77 variable next-profile-point-p \ the addr
|
Line 83 variable next-profile-point-p \ the addr
|
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 |
|
variable all-bbs 0 all-bbs ! \ list of all basic blocks |
|
|
\ list stuff |
\ list stuff |
|
|
Line 118 variable in-compile,? in-compile,? off
|
Line 125 variable in-compile,? in-compile,? off
|
0. r@ profile-count 2! |
0. r@ profile-count 2! |
current-sourcepos r@ profile-sourcepos 2! |
current-sourcepos r@ profile-sourcepos 2! |
>in @ r@ profile-char ! |
>in @ r@ profile-char ! |
[ count-calls? ] [if] |
0 r@ profile-callee-postlude ! |
r@ profile-colondef? off |
0 r@ profile-tailof ! |
0 r@ profile-calls ! |
r@ profile-colondef? off |
r@ profile-straight-line on |
0 r@ profile-bblen ! |
0 r@ profile-calls-from ! |
-100000000 r@ profile-bblenpi ! |
[endif] |
current-profile-point @ profile-bblenpi @ -100000000 = if |
|
current-profile-point @ dup profile-bblen @ swap profile-bblenpi ! |
|
endif |
|
0 r@ profile-calls ! |
|
r@ profile-straight-line on |
|
0 r@ profile-calls-from ! |
|
0 r@ profile-exits ! |
|
0. r@ profile-execs 2! |
|
0 r@ profile-prelude ! |
|
0 r@ profile-postlude ! |
r@ next-profile-point-p insert-list-end |
r@ next-profile-point-p insert-list-end |
r@ current-profile-point ! |
r@ current-profile-point ! |
|
r@ new-call all-bbs insert-list |
r> ; |
r> ; |
|
|
: print-profile ( -- ) |
: print-profile ( -- ) |
Line 170 variable in-compile,? in-compile,? off
|
Line 187 variable in-compile,? in-compile,? off
|
: 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 ; |
|
|
|
: bblen+ ( u1 callp -- u2 ) |
|
calls-call @ profile-bblen @ + ; |
|
|
|
: dyn-bblen+ ( ud1 callp -- ud2 ) |
|
calls-call @ dup profile-count 2@ rot profile-bblen @ 1 m*/ d+ ; |
|
|
|
: print-bb-statistics ( -- ) |
|
." static dynamic" cr |
|
all-bbs @ list-length 6 u.r all-bbs @ count-dyncalls 12 ud.r ." basic blocks" cr |
|
0 all-bbs @ ['] bblen+ map-list 6 u.r |
|
0. all-bbs @ ['] dyn-bblen+ map-list 12 ud.r ." primitives" cr |
|
; |
|
|
: 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 |
|
print-bb-statistics |
; |
; |
|
|
: dinc ( profilep -- ) |
: dinc ( profilep -- ) |
Line 235 variable in-compile,? in-compile,? off
|
Line 277 variable in-compile,? in-compile,? off
|
\ better if we had a way of knowing whether we are in a colon def or |
\ better if we had a way of knowing whether we are in a colon def or |
\ not (and used that knowledge instead of STATE). |
\ not (and used that knowledge instead of STATE). |
|
|
\ Defer before-word-profile ( -- ) |
Defer before-word-profile ( -- ) |
\ ' noop IS before-word-profile |
' noop IS before-word-profile |
|
|
\ : before-word1 ( -- ) |
: before-word1 ( -- ) |
\ before-word-profile defers before-word ; |
before-word-profile defers before-word ; |
|
|
\ ' before-word1 IS before-word |
' before-word1 IS before-word |
|
|
\ : profile-this-compiling ( -- ) |
: profile-this-compiling ( -- ) |
\ state @ if |
state @ if |
\ profile-this |
profile-this |
\ ['] noop IS before-word-profile |
['] noop IS before-word-profile |
\ endif ; |
endif ; |
|
|
\ : cock-profiler ( -- ) |
: cock-profiler ( -- ) |
\ \ as in cock the gun - pull the trigger |
\ as in cock the gun - pull the trigger |
\ ['] profile-this-compiling IS before-word-profile |
['] profile-this-compiling IS before-word-profile |
\ [ count-calls? ] [if] \ we are at a non-colondef profile point |
[ count-calls? ] [if] \ we are at a non-colondef profile point |
\ last-colondef-profile @ profile-straight-line off |
last-colondef-profile @ profile-straight-line off |
\ [endif] |
[endif] |
\ ; |
; |
|
|
: hook-profiling-into ( "name" -- ) |
: hook-profiling-into ( "name" -- ) |
\ make (deferred word) "name" call cock-profiler, too |
\ make (deferred word) "name" call cock-profiler, too |
' >body >r :noname |
' >body >r :noname |
POSTPONE profile-this |
POSTPONE cock-profiler |
r@ @ compile, \ old hook behaviour |
r@ @ compile, \ old hook behaviour |
POSTPONE ; |
POSTPONE ; |
r> ! ; \ change hook behaviour |
r> ! ; \ change hook behaviour |
|
|
: note-execute ( -- ) |
: note-execute ( -- ) |
\ end of BB due to execute |
\ end of BB due to execute, dodefer, perform |
|
profile-this \ should actually happen after the word, but the |
|
\ error is probably small |
; |
; |
|
|
: 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 ; |
{ addr } |
|
current-profile-point @ { lastbb } |
|
profile-this |
|
current-profile-point @ { thisbb } |
|
thisbb new-call { call-node } |
|
over 3 cells + @ ['] dinc >body = if |
|
\ non-library call |
|
!! update profile-bblenpi of last and current pp |
|
addr cell+ @ { callee-pp } |
|
callee-pp profile-postlude @ thisbb profile-callee-postlude ! |
|
call-node callee-pp profile-calls insert-list |
|
else ( addr call-prof-point ) |
|
call-node library-calls insert-list |
|
endif ; |
|
|
: prof-compile, ( xt -- ) |
: prof-compile, ( xt -- ) |
in-compile,? @ if |
in-compile,? @ if |
DEFERS compile, EXIT |
DEFERS compile, EXIT |
endif |
endif |
dup >does-code if |
1 current-profile-point @ profile-bblen +! |
dup >does-code note-call |
dup CASE |
then |
['] execute of note-execute endof |
dup >code-address CASE |
['] perform of note-execute endof |
docol: OF dup >body note-call ENDOF |
dup >does-code if |
dodefer: OF note-execute ENDOF |
dup >does-code note-call |
\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF |
then |
\ code words and ;code-defined words (code words could be optimized): |
dup >code-address CASE |
|
docol: OF dup >body note-call ENDOF |
|
dodefer: OF note-execute ENDOF |
|
\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF |
|
\ code words and ;code-defined words (code words could be optimized): |
|
ENDCASE |
ENDCASE |
ENDCASE |
DEFERS compile, ; |
DEFERS compile, ; |
|
|
Line 296 variable in-compile,? in-compile,? off
|
Line 357 variable in-compile,? in-compile,? off
|
defers :-hook |
defers :-hook |
next-profile-point-p @ |
next-profile-point-p @ |
profile-this |
profile-this |
@ dup last-colondef-profile ! |
@ dup last-colondef-profile ! ( current-profile-point ) |
|
1 over profile-bblenpi ! |
profile-colondef? on ; |
profile-colondef? on ; |
|
|
\ hook-profiling-into then-like |
: exit-hook-profile ( -- ) |
\ \ hook-profiling-into if-like \ subsumed by other-control-flow |
defers exit-hook |
\ \ hook-profiling-into ahead-like \ subsumed by other-control-flow |
1 last-colondef-profile @ profile-exits +! ; |
\ hook-profiling-into other-control-flow |
|
\ hook-profiling-into begin-like |
: ;-hook-profile ( -- ) |
\ hook-profiling-into again-like |
\ ;-hook is called before the POSTPONE EXIT |
\ hook-profiling-into until-like |
defers ;-hook |
|
last-colondef-profile @ { col } |
|
current-profile-point @ { bb } |
|
col profile-bblen @ col profile-prelude +! |
|
col profile-exits @ 0= if |
|
col bb profile-tailof ! |
|
bb profile-bblen @ bb profile-callee-postlude @ + |
|
col profile-postlude ! |
|
1 bb profile-bblenpi ! |
|
\ not counting the EXIT |
|
endif ; |
|
|
|
hook-profiling-into then-like |
|
\ hook-profiling-into if-like \ subsumed by other-control-flow |
|
\ hook-profiling-into ahead-like \ subsumed by other-control-flow |
|
hook-profiling-into other-control-flow |
|
hook-profiling-into begin-like |
|
hook-profiling-into again-like |
|
hook-profiling-into until-like |
' :-hook-profile IS :-hook |
' :-hook-profile IS :-hook |
' prof-compile, IS compile, |
' prof-compile, IS compile, |
|
' exit-hook-profile IS exit-hook |
|
' ;-hook-profile IS ;-hook |