/test/hrc/forth/full/fth.trace.fth

\ @(#) trace.fth 98/01/28 1.2
\ 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-BEGWORD_IP \ Instruction pointer begining of words
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 code> ) ( code@ ) name> >name dup id.
    name> ip code> swap - 4 / ."  +" .dec ." 's words" ;

: 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
    ." <<  "
    trace_ip trace.show.ip
    30 space.to.column
\ show data stack
    trace.show.stack
    80 space.to.column ." ||   Next word - "
    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 @ dup . space 255 and emit ENDOF
        ['] (ALITERAL) OF ip a@ dup . space 255 and emit  ENDOF
[ exists? (FLITERAL) [IF] ]
        ['] (FLITERAL) OF ip f@ f. ENDOF
[ [THEN] ]
        ['] BRANCH     OF ip @ 4 / . ENDOF
        ['] 0BRANCH    OF ip @ 4 / . 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 ;
: MONITOR (  ) LIB ( B )
    case
        0 of tlink endof
        3 of getm  endof
        4 of putm  endof
      033 of ex    endof \ BR 0 TLINK  3 GETM  4 PUTM  033 EX  ELSE ER_COM
        er_com \ Default
    endcase (  ) ;

: 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
        dup -> TRACE-BEGWORD_IP
        >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 many times )
    trace_level -> trace_level_max
    0
    ?DO
        trace_ip trace.next -> trace_ip
    LOOP ;

defer trace.user   ( IP -- stop?  )
' 0= is trace.user

: gd { more_levels | stop_level userflag -- }
    here what's trace.user u<  \ has it been forgotten?
    IF
        ." Resetting TRACE.USER !!!" cr
        ['] 0= is trace.user
    THEN
    more_levels 0<
    more_levels 10 >
    IF
        ." GD level out of range (0-10), = " more_levels . cr
    ELSE
        trace_level more_levels + -> trace_level_max
        trace_level 1- -> stop_level
        BEGIN
            trace_ip trace.user \ call deferred user word
            dup \ leave flag for UNTIL
            IF
                ." TRACE.USER returned " dup . ." so stopping execution." cr
            ELSE
                -> userflag drop
\                cr ." before=" .s
                trace_ip 
                trace.next
                -> trace_ip
\                   ." after="  .s key drop
                   userflag
                trace_level stop_level > not
            THEN
        UNTIL
		drop
    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]