439 lines
11 KiB
Forth
439 lines
11 KiB
Forth
\ @(#) trace.fth 98/01/08 1.1
|
|
\ TRACE ( <name> -- , trace pForth word )
|
|
\
|
|
\ Single step debugger.
|
|
\ TRACE ( i*x <name> -- , setup trace for Forth word )
|
|
\ S ( -- , step over )
|
|
\ SM ( many -- , step over many times )
|
|
\ SD ( -- , step down )
|
|
\ G ( -- , go to end of word )
|
|
\ GD ( n -- , go down N levels from current level, stop at end of this level )
|
|
\
|
|
\ This debugger works by emulating the inner interpreter of pForth.
|
|
\ It executes code and maintains a separate return stack for the
|
|
\ program under test. Thus all primitives that operate on the return
|
|
\ stack, such as DO and R> must be trapped. Local variables must
|
|
\ also be handled specially. Several state variables are also
|
|
\ saved and restored to establish the context for the program being
|
|
\ tested.
|
|
\
|
|
\ Copyright 1997 Phil Burk
|
|
|
|
anew task-trace.fth
|
|
|
|
: SPACE.TO.COLUMN ( col -- )
|
|
out @ - spaces
|
|
;
|
|
|
|
: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
|
|
['] first_colon <
|
|
;
|
|
|
|
0 value TRACE_IP \ instruction pointer
|
|
0 value TRACE_LEVEL \ level of descent for inner interpreter
|
|
0 value TRACE_LEVEL_MAX \ maximum level of descent
|
|
|
|
private{
|
|
|
|
\ use fake return stack
|
|
128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
|
|
create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
|
|
variable TRACE-RSP
|
|
: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
|
|
: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
|
|
: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
|
|
: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
|
|
: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
|
|
: TRACE.RDROP ( -- ) cell trace-rsp +! ;
|
|
: TRACE.RCHECK ( -- , abort if return stack out of range )
|
|
trace-rsp @ trace-return-stack u<
|
|
abort" TRACE return stack OVERFLOW!"
|
|
trace-rsp @ trace-return-stack trace_return_size + 12 + u>
|
|
abort" TRACE return stack UNDERFLOW!"
|
|
;
|
|
|
|
\ save and restore several state variables
|
|
10 cells constant TRACE_STATE_SIZE
|
|
create TRACE-STATE-1 TRACE_STATE_SIZE allot
|
|
create TRACE-STATE-2 TRACE_STATE_SIZE allot
|
|
|
|
variable TRACE-STATE-PTR
|
|
: TRACE.SAVE++ ( addr -- , save next thing )
|
|
@ trace-state-ptr @ !
|
|
cell trace-state-ptr +!
|
|
;
|
|
|
|
: TRACE.SAVE.STATE ( -- )
|
|
state trace.save++
|
|
hld trace.save++
|
|
base trace.save++
|
|
;
|
|
|
|
: TRACE.SAVE.STATE1 ( -- , save normal state )
|
|
trace-state-1 trace-state-ptr !
|
|
trace.save.state
|
|
;
|
|
: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
|
|
trace-state-2 trace-state-ptr !
|
|
trace.save.state
|
|
;
|
|
|
|
|
|
: TRACE.RESTORE++ ( addr -- , restore next thing )
|
|
trace-state-ptr @ @ swap !
|
|
cell trace-state-ptr +!
|
|
;
|
|
|
|
: TRACE.RESTORE.STATE ( -- )
|
|
state trace.restore++
|
|
hld trace.restore++
|
|
base trace.restore++
|
|
;
|
|
|
|
: TRACE.RESTORE.STATE1 ( -- )
|
|
trace-state-1 trace-state-ptr !
|
|
trace.restore.state
|
|
;
|
|
: TRACE.RESTORE.STATE2 ( -- )
|
|
trace-state-2 trace-state-ptr !
|
|
trace.restore.state
|
|
;
|
|
|
|
\ The implementation of these pForth primitives is specific to pForth.
|
|
|
|
variable TRACE-LOCALS-PTR \ point to top of local frame
|
|
|
|
\ create a return stack frame for NUM local variables
|
|
: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
|
|
trace-locals-ptr @ trace.>r
|
|
trace-rsp @ trace-locals-ptr !
|
|
trace-rsp @ num cells - trace-rsp ! \ make room for locals
|
|
trace-rsp @ -> lp
|
|
num 0
|
|
DO
|
|
lp !
|
|
cell +-> lp \ move data into locals frame on return stack
|
|
LOOP
|
|
;
|
|
|
|
: TRACE.(LOCAL.EXIT) ( -- )
|
|
trace-locals-ptr @ trace-rsp !
|
|
trace.r> trace-locals-ptr !
|
|
;
|
|
: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
|
|
trace-locals-ptr @ swap cells - @
|
|
;
|
|
: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
|
|
: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
|
|
: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
|
|
: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
|
|
: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
|
|
: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
|
|
: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
|
|
: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
|
|
|
|
: TRACE.(LOCAL!) ( n l# -- , store into local frame )
|
|
trace-locals-ptr @ swap cells - !
|
|
;
|
|
: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
|
|
: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
|
|
: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
|
|
: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
|
|
: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
|
|
: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
|
|
: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
|
|
: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
|
|
|
|
: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
|
|
trace-locals-ptr @ swap cells - +!
|
|
;
|
|
: TRACE.(?DO) { limit start ip -- ip' }
|
|
limit start =
|
|
IF
|
|
ip @ +-> ip \ BRANCH
|
|
ELSE
|
|
start trace.>r
|
|
limit trace.>r
|
|
cell +-> ip
|
|
THEN
|
|
ip
|
|
;
|
|
|
|
: TRACE.(LOOP) { ip | limit indx -- ip' }
|
|
trace.r> -> limit
|
|
trace.r> 1+ -> indx
|
|
limit indx =
|
|
IF
|
|
cell +-> ip
|
|
ELSE
|
|
indx trace.>r
|
|
limit trace.>r
|
|
ip @ +-> ip
|
|
THEN
|
|
ip
|
|
;
|
|
|
|
: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
|
|
trace.r> -> limit
|
|
trace.r> -> oldindx
|
|
oldindx delta + -> indx
|
|
\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
|
|
\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
|
|
\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
|
|
oldindx limit - limit 1- indx - AND $ 80000000 AND
|
|
indx limit - limit 1- oldindx - AND $ 80000000 AND OR
|
|
IF
|
|
cell +-> ip
|
|
ELSE
|
|
indx trace.>r
|
|
limit trace.>r
|
|
ip @ +-> ip
|
|
THEN
|
|
ip
|
|
;
|
|
|
|
: TRACE.CHECK.IP { ip -- }
|
|
ip ['] first_colon u<
|
|
ip here u> OR
|
|
IF
|
|
." TRACE - IP out of range = " ip .hex cr
|
|
abort
|
|
THEN
|
|
;
|
|
|
|
: TRACE.SHOW.IP { ip -- , print name and offset }
|
|
ip code> >name dup id.
|
|
name> >code ip swap - ." +" .
|
|
;
|
|
|
|
: TRACE.SHOW.STACK { | mdepth -- }
|
|
base @ >r
|
|
." <" base @ decimal 1 .r ." :"
|
|
depth 1 .r ." > "
|
|
r> base !
|
|
depth 5 min -> mdepth
|
|
depth mdepth -
|
|
IF
|
|
." ... " \ if we don't show entire stack
|
|
THEN
|
|
mdepth 0
|
|
?DO
|
|
mdepth i 1+ - pick . \ show numbers in current base
|
|
LOOP
|
|
;
|
|
|
|
: TRACE.SHOW.NEXT { ip -- }
|
|
>newline
|
|
ip trace.check.ip
|
|
\ show word name and offset
|
|
." << "
|
|
ip trace.show.ip
|
|
30 space.to.column
|
|
\ show data stack
|
|
trace.show.stack
|
|
65 space.to.column ." ||"
|
|
trace_level 2* spaces
|
|
ip code@
|
|
cell +-> ip
|
|
\ show primitive about to be executed
|
|
dup .xt space
|
|
\ trap any primitives that are followed by inline data
|
|
CASE
|
|
['] (LITERAL) OF ip @ . ENDOF
|
|
['] (ALITERAL) OF ip a@ . ENDOF
|
|
[ exists? (FLITERAL) [IF] ]
|
|
['] (FLITERAL) OF ip f@ f. ENDOF
|
|
[ [THEN] ]
|
|
['] BRANCH OF ip @ . ENDOF
|
|
['] 0BRANCH OF ip @ . ENDOF
|
|
['] (.") OF ip count type .' "' ENDOF
|
|
['] (C") OF ip count type .' "' ENDOF
|
|
['] (S") OF ip count type .' "' ENDOF
|
|
ENDCASE
|
|
100 space.to.column ." >> "
|
|
;
|
|
|
|
: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
|
|
xt
|
|
CASE
|
|
0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
|
|
['] (CREATE) OF ip cell- body_offset + ENDOF
|
|
['] (LITERAL) OF ip @ cell +-> ip ENDOF
|
|
['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
|
|
[ exists? (FLITERAL) [IF] ]
|
|
['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
|
|
[ [THEN] ]
|
|
['] BRANCH OF ip @ +-> ip ENDOF
|
|
['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
|
|
['] >R OF trace.>r ENDOF
|
|
['] R> OF trace.r> ENDOF
|
|
['] R@ OF trace.r@ ENDOF
|
|
['] RDROP OF trace.rdrop ENDOF
|
|
['] 2>R OF trace.>r trace.>r ENDOF
|
|
['] 2R> OF trace.r> trace.r> ENDOF
|
|
['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
|
|
['] i OF 1 trace.rpick ENDOF
|
|
['] j OF 3 trace.rpick ENDOF
|
|
['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
|
|
['] (LOOP) OF ip trace.(loop) -> ip ENDOF
|
|
['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
|
|
['] (DO) OF trace.>r trace.>r ENDOF
|
|
['] (?DO) OF ip trace.(?do) -> ip ENDOF
|
|
['] (.") OF ip count type ip count + aligned -> ip ENDOF
|
|
['] (C") OF ip ip count + aligned -> ip ENDOF
|
|
['] (S") OF ip count ip count + aligned -> ip ENDOF
|
|
['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
|
|
['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
|
|
['] (LOCAL@) OF trace.(local@) ENDOF
|
|
['] (1_LOCAL@) OF trace.(1_local@) ENDOF
|
|
['] (2_LOCAL@) OF trace.(2_local@) ENDOF
|
|
['] (3_LOCAL@) OF trace.(3_local@) ENDOF
|
|
['] (4_LOCAL@) OF trace.(4_local@) ENDOF
|
|
['] (5_LOCAL@) OF trace.(5_local@) ENDOF
|
|
['] (6_LOCAL@) OF trace.(6_local@) ENDOF
|
|
['] (7_LOCAL@) OF trace.(7_local@) ENDOF
|
|
['] (8_LOCAL@) OF trace.(8_local@) ENDOF
|
|
['] (LOCAL!) OF trace.(local!) ENDOF
|
|
['] (1_LOCAL!) OF trace.(1_local!) ENDOF
|
|
['] (2_LOCAL!) OF trace.(2_local!) ENDOF
|
|
['] (3_LOCAL!) OF trace.(3_local!) ENDOF
|
|
['] (4_LOCAL!) OF trace.(4_local!) ENDOF
|
|
['] (5_LOCAL!) OF trace.(5_local!) ENDOF
|
|
['] (6_LOCAL!) OF trace.(6_local!) ENDOF
|
|
['] (7_LOCAL!) OF trace.(7_local!) ENDOF
|
|
['] (8_LOCAL!) OF trace.(8_local!) ENDOF
|
|
['] (LOCAL+!) OF trace.(local+!) ENDOF
|
|
>r xt EXECUTE r>
|
|
ENDCASE
|
|
ip
|
|
;
|
|
|
|
: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
|
|
ip trace.check.ip
|
|
\ set context for word under test
|
|
trace.save.state1
|
|
here -> oldhere
|
|
trace.restore.state2
|
|
oldhere 256 + dp !
|
|
\ get execution token
|
|
ip code@ -> xt
|
|
cell +-> ip
|
|
\ execute token
|
|
xt is.primitive?
|
|
IF \ primitive
|
|
ip xt trace.do.primitive -> ip
|
|
ELSE \ secondary
|
|
trace_level trace_level_max <
|
|
IF
|
|
ip trace.>r \ threaded execution
|
|
1 +-> trace_level
|
|
xt codebase + -> ip
|
|
ELSE
|
|
\ treat it as a primitive
|
|
ip xt trace.do.primitive -> ip
|
|
THEN
|
|
THEN
|
|
\ restore original context
|
|
trace.rcheck
|
|
trace.save.state2
|
|
trace.restore.state1
|
|
oldhere dp !
|
|
ip
|
|
;
|
|
|
|
: TRACE.NEXT { ip | xt -- ip' }
|
|
trace_level 0>
|
|
IF
|
|
ip trace.do.next -> ip
|
|
THEN
|
|
trace_level 0>
|
|
IF
|
|
ip trace.show.next
|
|
ELSE
|
|
." Finished." cr
|
|
THEN
|
|
ip
|
|
;
|
|
|
|
}private
|
|
|
|
: TRACE ( i*x <name> -- i*x , setup trace environment )
|
|
' dup is.primitive?
|
|
IF
|
|
drop ." Sorry. You can't trace a primitive." cr
|
|
ELSE
|
|
1 -> trace_level
|
|
trace_level -> trace_level_max
|
|
trace.0rp
|
|
>code -> trace_ip
|
|
trace_ip trace.show.next
|
|
trace-stack off
|
|
trace.save.state2
|
|
THEN
|
|
;
|
|
|
|
: s ( -- , step over )
|
|
trace_level -> trace_level_max
|
|
trace_ip trace.next -> trace_ip
|
|
;
|
|
|
|
: sd ( -- , step down )
|
|
trace_level 1+ -> trace_level_max
|
|
trace_ip trace.next -> trace_ip
|
|
;
|
|
|
|
: sm ( many -- , step down )
|
|
trace_level -> trace_level_max
|
|
0
|
|
?DO
|
|
trace_ip trace.next -> trace_ip
|
|
LOOP
|
|
;
|
|
|
|
: gd { more_levels | stop_level -- }
|
|
depth 1 <
|
|
IF
|
|
." GD requires a MORE_LEVELS parameter." cr
|
|
ELSE
|
|
trace_level more_levels + -> trace_level_max
|
|
trace_level 1- -> stop_level
|
|
BEGIN
|
|
trace_ip trace.next -> trace_ip
|
|
trace_level stop_level > not
|
|
UNTIL
|
|
THEN
|
|
;
|
|
|
|
: g ( -- , execute until end of word )
|
|
0 gd
|
|
;
|
|
|
|
: TRACE.HELP ( -- )
|
|
." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
|
|
." S ( -- , step over )" cr
|
|
." SM ( many -- , step over many times )" cr
|
|
." SD ( -- , step down )" cr
|
|
." G ( -- , go to end of word )" cr
|
|
." GD ( n -- , go down N levels from current level," cr
|
|
." stop at end of this level )" cr
|
|
;
|
|
|
|
privatize
|
|
|
|
0 [IF]
|
|
variable var1
|
|
100 var1 !
|
|
: FOO dup IF 1 + . THEN 77 var1 @ + . ;
|
|
: ZOO 29 foo 99 22 + . ;
|
|
: ROO 92 >r 1 r@ + . r> . ;
|
|
: MOO c" hello" count type
|
|
." This is a message." cr
|
|
s" another message" type cr
|
|
;
|
|
: KOO 7 FOO ." DONE" ;
|
|
: TR.DO 4 0 DO i . LOOP ;
|
|
: TR.?DO 0 ?DO i . LOOP ;
|
|
: TR.LOC1 { aa bb } aa bb + . ;
|
|
: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
|
|
[THEN]
|