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

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