| 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 |