version 1.3, 2004/09/06 13:44:56
|
version 1.4, 2004/09/06 18:15:05
|
Line 78 profile-points next-profile-point-p !
|
Line 78 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 \ list of calls to library colon defs |
|
variable in-compile,? in-compile,? off |
|
|
\ list stuff |
\ list stuff |
|
|
Line 205 variable library-calls \ list of calls t
|
Line 206 variable library-calls \ list of calls t
|
profile-count dup 2@ 1. d+ rot 2! ; |
profile-count dup 2@ 1. d+ rot 2! ; |
|
|
: profile-this ( -- ) |
: profile-this ( -- ) |
new-profile-point POSTPONE literal POSTPONE dinc ; |
in-compile,? @ in-compile,? on |
|
new-profile-point POSTPONE literal POSTPONE dinc |
|
in-compile,? ! ; |
|
|
\ Various words trigger PROFILE-THIS. In order to avoid getting |
\ Various words trigger PROFILE-THIS. In order to avoid getting |
\ several calls to PROFILE-THIS from a compiling word (like ?EXIT), we |
\ several calls to PROFILE-THIS from a compiling word (like ?EXIT), we |
Line 232 variable library-calls \ list of calls t
|
Line 235 variable library-calls \ list of calls t
|
\ 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 cock-profiler |
POSTPONE profile-this |
r@ @ compile, \ old hook behaviour |
r@ @ compile, \ old hook behaviour |
POSTPONE ; |
POSTPONE ; |
r> ! ; \ change hook behaviour |
r> ! ; \ change hook behaviour |
Line 269 Defer before-word-profile ( -- )
|
Line 272 Defer before-word-profile ( -- )
|
: 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 3 cells + @ ['] dinc >body = if ( addr ) |
|
profile-this |
current-profile-point @ new-call over cell+ @ profile-calls insert-list |
current-profile-point @ new-call over cell+ @ profile-calls insert-list |
endif |
endif |
drop ; |
drop ; |
|
|
: prof-compile, ( xt -- ) |
: prof-compile, ( xt -- ) |
|
in-compile,? @ if |
|
DEFERS compile, EXIT |
|
endif |
dup >does-code if |
dup >does-code if |
dup >does-code note-call |
dup >does-code note-call |
then |
then |
dup >code-address CASE |
dup >code-address CASE |
docol: OF dup >body note-call ENDOF |
docol: OF dup >body note-call ENDOF |
dodefer: OF note-execute ENDOF |
dodefer: OF note-execute ENDOF |
dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF |
|
\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF |
\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF |
\ code words and ;code-defined words (code words could be optimized): |
\ code words and ;code-defined words (code words could be optimized): |
dup in-dictionary? IF drop POSTPONE literal ['] execute peephole-compile, EXIT THEN |
|
ENDCASE |
ENDCASE |
DEFERS compile, ; |
DEFERS compile, ; |
|
|
\ 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 ( -- ) |
: :-hook-profile ( -- ) |
defers :-hook |
defers :-hook |
next-profile-point-p @ |
next-profile-point-p @ |
Line 302 Defer before-word-profile ( -- )
|
Line 299 Defer before-word-profile ( -- )
|
@ dup last-colondef-profile ! |
@ dup last-colondef-profile ! |
profile-colondef? on ; |
profile-colondef? on ; |
|
|
|
\ 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, |