git.gag.com Git - debian/pforth/blob - fth/trace.fth

   1 \ @(#) trace.fth 98/01/28 1.2
   2 \ TRACE ( <name> -- , trace pForth word )
   3 \
   4 \ Single step debugger.
   5 \   TRACE  ( i*x <name> -- , setup trace for Forth word )
   6 \   S      ( -- , step over )
   7 \   SM     ( many -- , step over many times )
   8 \   SD     ( -- , step down )
   9 \   G      ( -- , go to end of word )
  10 \   GD     ( n -- , go down N levels from current level, stop at end of this level )
  11 \
  12 \ This debugger works by emulating the inner interpreter of pForth.
  13 \ It executes code and maintains a separate return stack for the
  14 \ program under test.  Thus all primitives that operate on the return
  15 \ stack, such as DO and R> must be trapped.  Local variables must
  16 \ also be handled specially.  Several state variables are also
  17 \ saved and restored to establish the context for the program being
  18 \ tested.
  19 \
  20 \ Copyright 1997 Phil Burk
  21 \
  22 \ Modifications:
  23 \      19990930 John Providenza - Fixed stack bugs in GD
  24
  25 anew task-trace.fth
  26
  27 : SPACE.TO.COLUMN  ( col -- )
  28     out @ - spaces
  29 ;
  30
  31 : IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
  32     ['] first_colon <
  33 ;
  34
  35 0 value TRACE_IP         \ instruction pointer
  36 0 value TRACE_LEVEL      \ level of descent for inner interpreter
  37 0 value TRACE_LEVEL_MAX  \ maximum level of descent
  38
  39 private{
  40
  41 \ use fake return stack
  42 128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
  43 create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
  44 variable TRACE-RSP
  45 : TRACE.>R     ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ;  \ *(--rsp) = n
  46 : TRACE.R>     ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ;  \ n = *rsp++
  47 : TRACE.R@     ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
  48 : TRACE.RPICK  ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
  49 : TRACE.0RP    ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
  50 : TRACE.RDROP  ( --  ) cell trace-rsp +! ;
  51 : TRACE.RCHECK ( -- , abort if return stack out of range )
  52     trace-rsp @ trace-return-stack u<
  53         abort" TRACE return stack OVERFLOW!"
  54     trace-rsp @ trace-return-stack trace_return_size + 12 + u>
  55         abort" TRACE return stack UNDERFLOW!"
  56 ;
  57
  58 \ save and restore several state variables
  59 10 cells constant TRACE_STATE_SIZE
  60 create TRACE-STATE-1 TRACE_STATE_SIZE allot
  61 create TRACE-STATE-2 TRACE_STATE_SIZE allot
  62
  63 variable TRACE-STATE-PTR
  64 : TRACE.SAVE++ ( addr -- , save next thing )
  65     @ trace-state-ptr @ !
  66     cell trace-state-ptr +!
  67 ;
  68
  69 : TRACE.SAVE.STATE  ( -- )
  70     state trace.save++
  71     hld   trace.save++
  72     base  trace.save++
  73 ;
  74
  75 : TRACE.SAVE.STATE1  ( -- , save normal state )
  76     trace-state-1 trace-state-ptr !
  77     trace.save.state
  78 ;
  79 : TRACE.SAVE.STATE2  ( -- , save state of word being debugged )
  80     trace-state-2 trace-state-ptr !
  81     trace.save.state
  82 ;
  83
  84
  85 : TRACE.RESTORE++ ( addr -- , restore next thing )
  86     trace-state-ptr @ @ swap !
  87     cell trace-state-ptr +!
  88 ;
  89
  90 : TRACE.RESTORE.STATE  ( -- )
  91     state trace.restore++
  92     hld   trace.restore++
  93     base  trace.restore++
  94 ;
  95
  96 : TRACE.RESTORE.STATE1  ( -- )
  97     trace-state-1 trace-state-ptr !
  98     trace.restore.state
  99 ;
 100 : TRACE.RESTORE.STATE2  ( -- )
 101     trace-state-2 trace-state-ptr !
 102     trace.restore.state
 103 ;
 104
 105 \ The implementation of these pForth primitives is specific to pForth.
 106
 107 variable TRACE-LOCALS-PTR  \ point to top of local frame
 108
 109 \ create a return stack frame for NUM local variables
 110 : TRACE.(LOCAL.ENTRY)  ( x0 x1 ... xn n -- )  { num | lp -- }
 111     trace-locals-ptr @ trace.>r
 112     trace-rsp @ trace-locals-ptr !
 113     trace-rsp @  num cells - trace-rsp !  \ make room for locals
 114     trace-rsp @ -> lp
 115     num 0
 116     DO
 117         lp !
 118         cell +-> lp  \ move data into locals frame on return stack
 119     LOOP
 120 ;
 121
 122 : TRACE.(LOCAL.EXIT) ( -- )
 123     trace-locals-ptr @  trace-rsp !
 124     trace.r> trace-locals-ptr !
 125 ;
 126 : TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
 127     trace-locals-ptr @  swap cells - @
 128 ;
 129 : TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
 130 : TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
 131 : TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
 132 : TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
 133 : TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
 134 : TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
 135 : TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
 136 : TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
 137
 138 : TRACE.(LOCAL!) ( n l# -- , store into local frame )
 139     trace-locals-ptr @  swap cells - !
 140 ;
 141 : TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
 142 : TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
 143 : TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
 144 : TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
 145 : TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
 146 : TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
 147 : TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
 148 : TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
 149
 150 : TRACE.(LOCAL+!) ( n l# -- , store into local frame )
 151     trace-locals-ptr @  swap cells - +!
 152 ;
 153 : TRACE.(?DO)  { limit start ip -- ip' }
 154     limit start =
 155     IF
 156         ip @ +-> ip \ BRANCH
 157     ELSE
 158         start trace.>r
 159         limit trace.>r
 160         cell +-> ip
 161     THEN
 162     ip
 163 ;
 164
 165 : TRACE.(LOOP)  { ip | limit indx -- ip' }
 166     trace.r> -> limit
 167     trace.r> 1+ -> indx
 168     limit indx =
 169     IF
 170         cell +-> ip
 171     ELSE
 172         indx trace.>r
 173         limit trace.>r
 174         ip @ +-> ip
 175     THEN
 176     ip
 177 ;
 178
 179 : TRACE.(+LOOP)  { delta ip | limit indx oldindx -- ip' }
 180     trace.r> -> limit
 181     trace.r> -> oldindx
 182     oldindx delta + -> indx
 183 \ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
 184 \  if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
 185 \    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
 186     oldindx limit -    limit 1-    indx -  AND $ 80000000 AND
 187        indx limit -    limit 1- oldindx -  AND $ 80000000 AND OR
 188     IF
 189         cell +-> ip
 190     ELSE
 191         indx trace.>r
 192         limit trace.>r
 193         ip @ +-> ip
 194     THEN
 195     ip
 196 ;
 197
 198 : TRACE.CHECK.IP  {  ip -- }
 199     ip ['] first_colon u<
 200     ip here u> OR
 201     IF
 202         ." TRACE - IP out of range = " ip .hex cr
 203         abort
 204     THEN
 205 ;
 206
 207 : TRACE.SHOW.IP { ip -- , print name and offset }
 208     ip code> >name dup id.
 209     name> >code ip swap - ."  +" .
 210 ;
 211
 212 : TRACE.SHOW.STACK { | mdepth -- }
 213     base @ >r
 214     ." <" base @ decimal 1 .r ." :"
 215     depth 1 .r ." > "
 216     r> base !
 217     depth 5 min -> mdepth
 218     depth mdepth  -
 219     IF
 220         ." ... "  \ if we don't show entire stack
 221     THEN
 222     mdepth 0
 223     ?DO
 224         mdepth i 1+ - pick .  \ show numbers in current base
 225     LOOP
 226 ;
 227
 228 : TRACE.SHOW.NEXT { ip -- }
 229     >newline
 230     ip trace.check.ip
 231 \ show word name and offset
 232     ." << "
 233     ip trace.show.ip
 234     16 space.to.column
 235 \ show data stack
 236     trace.show.stack
 237     40 space.to.column ."  ||"
 238     trace_level 2* spaces
 239     ip code@
 240     cell +-> ip
 241 \ show primitive about to be executed
 242     dup .xt space
 243 \ trap any primitives that are followed by inline data
 244     CASE
 245         ['] (LITERAL)  OF ip @  . ENDOF
 246         ['] (ALITERAL) OF ip a@ . ENDOF
 247 [ exists? (FLITERAL) [IF] ]
 248         ['] (FLITERAL) OF ip f@ f. ENDOF
 249 [ [THEN] ]
 250         ['] BRANCH     OF ip @  . ENDOF
 251         ['] 0BRANCH    OF ip @  . ENDOF
 252         ['] (.")       OF ip count type .' "' ENDOF
 253         ['] (C")       OF ip count type .' "' ENDOF
 254         ['] (S")       OF ip count type .' "' ENDOF
 255     ENDCASE
 256     65 space.to.column ." >> "
 257 ;
 258
 259 : TRACE.DO.PRIMITIVE  { ip xt | oldhere --  ip' , perform code at ip }
 260     xt
 261     CASE
 262         0 OF -1 +-> trace_level  trace.r> -> ip ENDOF \ EXIT
 263         ['] (CREATE)   OF ip cell- body_offset + ENDOF
 264         ['] (LITERAL)  OF ip @ cell +-> ip ENDOF
 265         ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
 266 [ exists? (FLITERAL) [IF] ]
 267         ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
 268 [ [THEN] ]
 269         ['] BRANCH     OF ip @ +-> ip ENDOF
 270         ['] 0BRANCH    OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
 271         ['] >R         OF trace.>r ENDOF
 272         ['] R>         OF trace.r> ENDOF
 273         ['] R@         OF trace.r@ ENDOF
 274         ['] RDROP      OF trace.rdrop ENDOF
 275         ['] 2>R        OF trace.>r trace.>r ENDOF
 276         ['] 2R>        OF trace.r> trace.r> ENDOF
 277         ['] 2R@        OF trace.r@ 1 trace.rpick ENDOF
 278         ['] i          OF 1 trace.rpick ENDOF
 279         ['] j          OF 3 trace.rpick ENDOF
 280         ['] (LEAVE)    OF trace.rdrop trace.rdrop  ip @ +-> ip ENDOF
 281         ['] (LOOP)     OF ip trace.(loop) -> ip  ENDOF
 282         ['] (+LOOP)    OF ip trace.(+loop) -> ip  ENDOF
 283         ['] (DO)       OF trace.>r trace.>r ENDOF
 284         ['] (?DO)      OF ip trace.(?do) -> ip ENDOF
 285         ['] (.")       OF ip count type  ip count + aligned -> ip ENDOF
 286         ['] (C")       OF ip  ip count + aligned -> ip ENDOF
 287         ['] (S")       OF ip count  ip count + aligned -> ip ENDOF
 288         ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
 289         ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
 290         ['] (LOCAL@)   OF trace.(local@)   ENDOF
 291         ['] (1_LOCAL@) OF trace.(1_local@) ENDOF
 292         ['] (2_LOCAL@) OF trace.(2_local@) ENDOF
 293         ['] (3_LOCAL@) OF trace.(3_local@) ENDOF
 294         ['] (4_LOCAL@) OF trace.(4_local@) ENDOF
 295         ['] (5_LOCAL@) OF trace.(5_local@) ENDOF
 296         ['] (6_LOCAL@) OF trace.(6_local@) ENDOF
 297         ['] (7_LOCAL@) OF trace.(7_local@) ENDOF
 298         ['] (8_LOCAL@) OF trace.(8_local@) ENDOF
 299         ['] (LOCAL!)   OF trace.(local!)   ENDOF
 300         ['] (1_LOCAL!) OF trace.(1_local!) ENDOF
 301         ['] (2_LOCAL!) OF trace.(2_local!) ENDOF
 302         ['] (3_LOCAL!) OF trace.(3_local!) ENDOF
 303         ['] (4_LOCAL!) OF trace.(4_local!) ENDOF
 304         ['] (5_LOCAL!) OF trace.(5_local!) ENDOF
 305         ['] (6_LOCAL!) OF trace.(6_local!) ENDOF
 306         ['] (7_LOCAL!) OF trace.(7_local!) ENDOF
 307         ['] (8_LOCAL!) OF trace.(8_local!) ENDOF
 308         ['] (LOCAL+!)  OF trace.(local+!)  ENDOF
 309         >r xt EXECUTE r>
 310     ENDCASE
 311     ip
 312 ;
 313
 314 : TRACE.DO.NEXT  { ip | xt oldhere --  ip' , perform code at ip }
 315     ip trace.check.ip
 316 \ set context for word under test
 317     trace.save.state1
 318     here -> oldhere
 319     trace.restore.state2
 320     oldhere 256 + dp !
 321 \ get execution token
 322     ip code@ -> xt
 323     cell +-> ip
 324 \ execute token
 325     xt is.primitive?
 326     IF  \ primitive
 327         ip xt trace.do.primitive -> ip
 328     ELSE \ secondary
 329         trace_level trace_level_max <
 330         IF
 331             ip trace.>r         \ threaded execution
 332             1 +-> trace_level
 333             xt codebase + -> ip
 334         ELSE
 335             \ treat it as a primitive
 336             ip xt trace.do.primitive -> ip
 337         THEN
 338     THEN
 339 \ restore original context
 340     trace.rcheck
 341     trace.save.state2
 342     trace.restore.state1
 343     oldhere dp !
 344     ip
 345 ;
 346
 347 : TRACE.NEXT { ip | xt -- ip' }
 348     trace_level 0>
 349     IF
 350         ip trace.do.next -> ip
 351     THEN
 352     trace_level 0>
 353     IF
 354         ip trace.show.next
 355     ELSE
 356         trace-stack on
 357         ." Finished." cr
 358     THEN
 359     ip
 360 ;
 361
 362 }private
 363
 364 : TRACE ( i*x <name> -- i*x , setup trace environment )
 365     ' dup is.primitive?
 366     IF
 367         drop ." Sorry. You can't trace a primitive." cr
 368     ELSE
 369         1 -> trace_level
 370         trace_level -> trace_level_max
 371         trace.0rp
 372         >code -> trace_ip
 373         trace_ip trace.show.next
 374         trace-stack off
 375         trace.save.state2
 376     THEN
 377 ;
 378
 379 : s ( -- , step over )
 380     trace_level -> trace_level_max
 381     trace_ip trace.next -> trace_ip
 382 ;
 383
 384 : sd ( -- , step down )
 385     trace_level 1+ -> trace_level_max
 386     trace_ip trace.next -> trace_ip
 387 ;
 388
 389 : sm ( many -- , step many times )
 390     trace_level -> trace_level_max
 391     0
 392     ?DO
 393         trace_ip trace.next -> trace_ip
 394     LOOP
 395 ;
 396
 397 defer trace.user   ( IP -- stop?  )
 398 ' 0= is trace.user
 399
 400 : gd { more_levels | stop_level -- }
 401     here   what's trace.user   u<  \ has it been forgotten?
 402     IF
 403         ." Resetting TRACE.USER !!!" cr
 404         ['] 0= is trace.user
 405     THEN
 406
 407     more_levels 0<
 408     more_levels 10 >
 409     or  \ 19990930 - OR was missing
 410     IF
 411         ." GD level out of range (0-10), = " more_levels . cr
 412     ELSE
 413         trace_level more_levels + -> trace_level_max
 414         trace_level 1- -> stop_level
 415         BEGIN
 416             trace_ip trace.user \ call deferred user word
 417             ?dup \ leave flag for UNTIL \ 19990930 - was DUP
 418             IF
 419                 ." TRACE.USER returned " dup . ." so stopping execution." cr
 420             ELSE
 421                 trace_ip trace.next -> trace_ip
 422                 trace_level stop_level > not
 423             THEN
 424         UNTIL
 425     THEN
 426 ;
 427
 428 : g ( -- , execute until end of word )
 429     0 gd
 430 ;
 431
 432 : TRACE.HELP ( -- )
 433     ."   TRACE  ( i*x <name> -- , setup trace for Forth word )" cr
 434     ."   S      ( -- , step over )" cr
 435     ."   SM     ( many -- , step over many times )" cr
 436     ."   SD     ( -- , step down )" cr
 437     ."   G      ( -- , go to end of word )" cr
 438     ."   GD     ( n -- , go down N levels from current level," cr
 439     ."                   stop at end of this level )" cr
 440 ;
 441
 442 privatize
 443
 444 0 [IF]
 445 variable var1
 446 100 var1 !
 447 : FOO  dup IF 1 + . THEN 77 var1 @ + . ;
 448 : ZOO 29 foo 99 22 + . ;
 449 : ROO 92 >r 1 r@ + . r> . ;
 450 : MOO  c" hello" count type
 451     ." This is a message." cr
 452     s" another message" type cr
 453 ;
 454 : KOO 7 FOO ." DONE" ;
 455 : TR.DO  4 0 DO i . LOOP ;
 456 : TR.?DO  0 ?DO i . LOOP ;
 457 : TR.LOC1 { aa bb } aa bb + . ;
 458 : TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
 459
 460 [THEN]