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