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

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