urflibs/debugger.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; interactive debugger
   8 ;; optional; not included by default
   9 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 debug:single-step@ [IF]
  12
  13 $include-once <linore.f>
  14
  15 vocabulary debugger
  16 also-defs: debugger
  17
  18 ;; debugger task id
  19 0 value debugger-task
  20 ;; task the we're debugging now
  21 0 value debuggee-stid
  22
  23 ;; source file
  24 0 value source-stx
  25 ;; source file name
  26 0 value source-name-stx
  27
  28 false value active?
  29
  30 ;; are we on the alt (debugger) screen now?
  31 false value alt-scr?
  32 true value alt-clear
  33
  34 ;; show keycodes?
  35 false value debug-show-keys
  36
  37
  38 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39 ;; TTY helpers
  40 ;;
  41
  42 ;; switch to alternative screen
  43 : to-alt-scr  ( -- )
  44   alt-scr? ifnot
  45     flush-emit
  46     alt-clear if " \e[?1049h"
  47     else " \e[?1048h\e[?47h" endif
  48     tty:raw-type \ tty:raw-flush
  49     true to alt-scr?
  50   endif
  51 ;
  52
  53 ;; switch to main screen
  54 : to-main-scr  ( -- )
  55   alt-scr? if
  56     alt-clear if " \e[?1049l"
  57     else " \e[?47l\e[?1048l" endif
  58     tty:raw-type tty:raw-flush
  59     false to alt-scr?
  60   endif
  61 ;
  62
  63
  64 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;; replace standard emit
  66 ;;
  67
  68 : (new-norm-emit-char)  ( ch -- ch )
  69   lo-byte alt-scr? ifnot
  70     dup bl < if
  71       case
  72         9 of 9 endof
  73         10 of 10 endof
  74         13 of 13 endof
  75         otherwise drop [char] ?
  76       endcase
  77     else dup 127 = if drop [char] ? endif
  78     endif
  79   endif
  80 ;
  81
  82 debug:replace (norm-emit-char) (new-norm-emit-char)
  83
  84
  85 : (debug-emit)  ( ch -- )
  86   ;; for alt-screen, prepend CR to LF
  87   alt-scr? if
  88     dup nl = if 13 tty:raw-emit endif
  89   endif
  90   dup tty:raw-emit
  91   dup nl = lastcr!
  92   ;; for main screen, flush on CR or LF
  93   alt-scr? ifnot
  94     dup nl = swap 10 = or if tty:raw-flush endif
  95   else drop
  96   endif
  97 ;
  98
  99 debug:replace (emit) (debug-emit)
 100
 101
 102 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;; load source code
 104 ;;
 105
 106 : same-source?  ( addr count -- bool )
 107   0 max
 108   source-name-stx if source-name-stx count string:=
 109   else 2drop false endif
 110 ;
 111
 112 : free-source  ( -- )
 113   source-stx handle:free 0-to source-stx
 114   source-name-stx handle:free 0-to source-name-stx
 115 ;
 116
 117 : load-source-file  ( addr count -- )
 118   free-source
 119   2dup handle:load-file dup to source-stx
 120   if
 121     0 handle:new to source-name-stx
 122     dup 8 + source-name-stx handle:size!
 123     dup source-name-stx !  ;; counter
 124     source-name-stx cell+ swap move
 125   else 2drop endif
 126 ;
 127
 128 : load-source  ( addr count -- )
 129   2dup same-source? if 2drop
 130   else dup 0> if load-source-file else 2drop endif
 131   endif
 132 ;
 133
 134
 135 : source-c@  ( ofs -- char )
 136   source-stx if
 137     dup source-stx handle:size@ u< if
 138       source-stx handle:c@
 139       ?dup ifnot bl endif
 140     else drop 0
 141     endif
 142   else drop 0
 143   endif
 144 ;
 145
 146
 147 : norm-source-ofs  ( ofs -- ofs )
 148   source-stx if 0 max source-stx handle:size@ min
 149   else drop 0 endif
 150 ;
 151
 152 : source-to-bol  ( ofs -- ofs )
 153   begin dup 1- + source-c@ dup 0= swap nl = or not-while 1- repeat
 154 ;
 155
 156 : source-to-eol  ( ofs -- ofs )
 157   begin dup source-c@ dup 0= swap nl = or not-while 1+ repeat
 158 ;
 159
 160 ;; `ofs` is BOL
 161 : source-prev-line  ( ofs -- ofs )
 162   1- source-to-bol norm-source-ofs
 163 ;
 164
 165 ;; `ofs` is BOL
 166 : source-next-line  ( ofs -- ofs )
 167   source-to-eol 1+ norm-source-ofs
 168 ;
 169
 170 : find-source-line  ( line -- ofs )
 171   0 swap 1- for source-next-line endfor
 172 ;
 173
 174 : .-source-line  ( ofs -- next-line-ofs )
 175   dup source-c@ if
 176     begin dup source-c@ dup 0= over nl = or not-while xemit 1+ repeat drop
 177     1+ cr
 178   endif
 179 ;
 180
 181 : show-source-line  ( addr count line -- )
 182   >r load-source
 183   source-stx if
 184     r@ 8 - find-source-line
 185     8 for .-source-line endfor
 186     ." \e[0;1m" .-source-line ." \e[0m"
 187     8 for .-source-line endfor
 188     drop
 189   endif
 190   rdrop
 191 ;
 192
 193
 194 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 195 ;; M-F5 to show main screen
 196 ;;
 197
 198 also-defs: linore:osc-actions
 199
 200 // M-F5
 201 : 15;3~  ( -- )
 202   alt-scr? if to-main-scr else to-alt-scr endif
 203 ;
 204
 205 // F12
 206 // switch "show keys" mode
 207 : 24~  ( -- )
 208   debug-show-keys not to debug-show-keys
 209 ;
 210
 211 prev-defs
 212
 213
 214 defer (linore-draw-prompt)
 215
 216 ;; return TRUE if key should be eaten
 217 : (check-key-alt)  ( flag -- FALSE / TRUE )
 218   drop alt-scr? ifnot to-alt-scr true else false endif
 219 ;
 220
 221 : (show-keycode)  ( ch -- )
 222   dup 0< if
 223     debug-show-keys if
 224       cr ." KEY: code: " dup .
 225       dup 33 127 within if ."  char: " dup xemit endif
 226       cr
 227     endif
 228   endif
 229   drop
 230 ;
 231
 232 : (show-osc)  ( addr count -- )
 233   debug-show-keys if
 234     cr ." OSC-KEY(" dup 0 u.r ." ): "
 235     xtype cr
 236   else 2drop endif
 237 ;
 238
 239 ..: linore:key-processor  ( ch FALSE -- ch FALSE / TRUE )
 240   active? if
 241     dup ifnot
 242       (check-key-alt) if drop true else false endif
 243       dup ifnot >r dup (show-keycode) r> endif
 244     endif
 245   endif
 246 ;..
 247
 248 ..: linore:osc-key-processor  ( addr count FALSE -- addr count FALSE / TRUE )
 249   active? if
 250     dup ifnot
 251       (check-key-alt) if 2drop true else false endif
 252       dup ifnot >r 2dup (show-osc) r> endif
 253     endif
 254   endif
 255 ;..
 256
 257 ..: linore:on-before-draw  ( FALSE -- FALSE / TRUE )
 258   active? if
 259     dup ifnot
 260       drop alt-scr? not
 261       dup ifnot (linore-draw-prompt) endif
 262     endif
 263   endif
 264 ;..
 265
 266
 267 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 268 ;; debugger helpers
 269 ;;
 270
 271 : do-resume  ( -- )
 272   false to active?
 273   debuggee-stid mtask:debugger-resume
 274 ;
 275
 276 : do-sstep  ( -- )
 277   false to active?
 278   debuggee-stid mtask:debugger-single-step
 279 ;
 280
 281
 282 : show-current-word  ( -- )
 283   ." \r*** CURRENT WORD: "
 284   debuggee-stid mtask:state-ip@ debug:ip->nfa id-count xtype cr
 285   debuggee-stid mtask:state-ip@ 6 u.r ." : "
 286   debuggee-stid mtask:state-ip@ @ ." [" 4 u.r ." ]: "
 287   debuggee-stid mtask:state-ip@ @ cfa->nfa id-count xtype cr
 288
 289   debuggee-stid mtask:state-ip@ debug:ip->file/line
 290   ( ip -- addr count line TRUE / FALSE )
 291   if
 292     >r 2dup r@ show-source-line r>
 293     ." line " . ."  in `" xtype ." `" cr
 294   endif
 295 ;
 296
 297 : process-task-switch  ( action old-stid -- )
 298   to debuggee-stid drop  ;; drop action id
 299   flush-emit
 300   true to active?
 301   (*
 302   case
 303     -1 of ." yay, a breakpoint!" cr endof
 304     -2 of ." yay, a single-step!" cr endof
 305     otherwise " wutafuck?!" error
 306   endcase
 307   *)
 308   base @ 10 <> " ass!" ?error
 309   compiler:comp? " hole!" ?error
 310   true to alt-clear to-alt-scr false to alt-clear
 311   show-current-word
 312 ;
 313
 314
 315 ;; used in step-line
 316 0 value step-from-line
 317 0 value step-from-file-hash
 318 0 value step-from-file-nlen
 319 ;; used in step-l-over
 320 0 value step-curr-nfa
 321 0 value step-over-loops
 322
 323
 324 ;; call before various dumps
 325 : (newline)  ( -- )
 326   flush-emit cr tty:raw-flush
 327 ;
 328
 329 : (.push-one)  ( n -- )
 330   debuggee-stid mtask:state-sp@ 1+ debuggee-stid mtask:state-sp!
 331   0 debuggee-stid mtask:state-ds!
 332 ;
 333
 334
 335 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 336 ;; debugger commands
 337 ;;
 338
 339 simple-vocabulary commands
 340 also-defs: commands
 341
 342 : .source  ( -- )
 343   show-current-word
 344 ;
 345 alias-for .source is ?
 346
 347 ;; dump data stack
 348 : .stack  ( -- )
 349   debuggee-stid debug:dump-stack-task
 350 ;
 351 alias-for .stack is .s
 352
 353 ;; dump data stack
 354 : .rstack  ( -- )
 355   debuggee-stid debug:dump-rstack-task
 356 ;
 357 alias-for .rstack is .r
 358
 359 ;; backtrace
 360 : bt  ( -- )
 361    debuggee-stid debug:backtrace-task
 362 ;
 363
 364 ;; drop value from the debuggee stack
 365 : .drop  ( -- )
 366   debuggee-stid mtask:state-sp@ dup if
 367     1- debuggee-stid mtask:state-sp!
 368     debuggee-stid debug:dump-stack-task
 369   else drop ." ERROR: debuggee stack is empty!" cr
 370   endif
 371 ;
 372
 373 ;; push value(s) to the debuggee stack
 374 : .push  ( ... -- )
 375   depth if
 376     ;; reserve room
 377     depth debuggee-stid mtask:state-sp@ + debuggee-stid mtask:state-sp!
 378     ;; move values
 379     depth for i debuggee-stid mtask:state-ds! endfor
 380     debuggee-stid debug:dump-stack-task
 381   else ." ERROR: push what?" cr
 382   endif
 383 ;
 384
 385 ;; clear debugger data stack
 386 : .dclear  ( -- )
 387   sp0!
 388 ;
 389
 390 ;; debugger data stack depth
 391 : .depth  ( -- )
 392   ." debugger stack depth: " depth . cr
 393 ;
 394
 395 : continue  ( -- )
 396   to-main-scr tty:raw-flush
 397   do-resume
 398   process-task-switch
 399 ;
 400 alias-for continue is c
 401
 402 : step  ( -- )
 403   to-main-scr tty:raw-flush
 404   do-sstep
 405   process-task-switch
 406 ;
 407 alias-for step is s
 408
 409 : quit  ( -- )
 410   to-main-scr tty:raw-flush
 411   abort
 412 ;
 413 alias-for quit is q
 414
 415 ;; run current line, stop when it changed
 416 : step-line  ( -- )
 417   debuggee-stid mtask:state-ip@ debug:ip->file-hash/line
 418   // ( ip -- len hash line TRUE / FALSE )
 419   if
 420     to step-from-line
 421     to step-from-file-hash
 422     to step-from-file-nlen
 423     ;; now single-step until everything is the same
 424     to-main-scr tty:raw-flush
 425     tty:set-cooked drop
 426     (*
 427       ." line: " step-from-line .
 428       ." hash: " step-from-file-hash .
 429       ." nlen: " step-from-file-nlen .
 430       ."   ip: " debuggee-stid mtask:state-ip@ .
 431       cr
 432     *)
 433     false to active?
 434     begin
 435       debuggee-stid mtask:debugger-single-step
 436       to debuggee-stid drop  ;; drop action id
 437       debuggee-stid mtask:state-ip@ debug:ip->file-hash/line
 438       if
 439         (*
 440           >r 2dup r@
 441           ." new-line: " .
 442           ." new-hash: " .
 443           ." new-nlen: " .
 444           ."   new-ip: " debuggee-stid mtask:state-ip@ .
 445           cr r>
 446         *)
 447         step-from-line =
 448         swap step-from-file-hash = and
 449         swap step-from-file-nlen = and
 450         ifnot break endif
 451       endif
 452     again
 453     flush-emit
 454     -3 debuggee-stid  ;; for PROCESS-TASK-SWITCH
 455     tty:set-raw drop
 456     process-task-switch
 457   endif
 458 ;
 459
 460 ;; run current line, stop when we returned to the current word
 461 : step-l-over  ( over-loops -- )
 462   to step-over-loops
 463   ;; HACK: check for FORTH:(EXIT)
 464   debuggee-stid mtask:state-ip@ @
 465   ['] forth:(exit) = if step exit endif
 466   debuggee-stid mtask:state-ip@ debug:ip->file-hash/line
 467   // ( ip -- len hash line TRUE / FALSE )
 468   if
 469     to step-from-line
 470     to step-from-file-hash
 471     to step-from-file-nlen
 472     debuggee-stid mtask:state-ip@ debug:ip->nfa to step-curr-nfa
 473     ;; now single-step until everything is the same
 474     to-main-scr tty:raw-flush
 475     tty:set-cooked drop
 476     false to active?
 477     begin
 478       debuggee-stid mtask:debugger-single-step
 479       to debuggee-stid drop  ;; drop action id
 480       debuggee-stid mtask:state-ip@ debug:ip->nfa
 481       step-curr-nfa =
 482       if
 483         debuggee-stid mtask:state-ip@ debug:ip->file-hash/line
 484         if
 485           step-over-loops if step-from-line <=
 486           else step-from-line = endif
 487           swap step-from-file-hash = and
 488           swap step-from-file-nlen = and
 489           ifnot break endif
 490         endif
 491       endif
 492     again
 493     flush-emit
 494     -3 debuggee-stid  ;; for PROCESS-TASK-SWITCH
 495     tty:set-raw drop
 496     process-task-switch
 497   endif
 498 ;
 499
 500 ;; run one forth instruction, step when it changed
 501 : step-over  ( -- )
 502   ;; HACK: check for FORTH:(EXIT)
 503   debuggee-stid mtask:state-ip@ @
 504   ['] forth:(exit) = if step exit endif
 505   debuggee-stid mtask:state-ip@ debug:ip->nfa to step-curr-nfa
 506   ;; now single-step
 507   to-main-scr tty:raw-flush
 508   tty:set-cooked drop
 509   false to active?
 510   begin
 511     debuggee-stid mtask:debugger-single-step
 512     to debuggee-stid drop  ;; drop action id
 513     debuggee-stid mtask:state-ip@ debug:ip->nfa
 514     step-curr-nfa =
 515   until
 516   flush-emit
 517   -3 debuggee-stid  ;; for PROCESS-TASK-SWITCH
 518   tty:set-raw drop
 519   process-task-switch
 520 ;
 521 alias-for step-over is o
 522
 523 : .help  ( -- )
 524   ."  ? .source     -- show source code (also enter)" CR
 525   ." .s .stack      -- dump debuggee data stack" CR
 526   ." .r .rstack     -- dump debuggee return stack" CR
 527   ."    bt          -- show backtrace" CR
 528   ."    .drop       -- drop value from debuggee data stack" CR
 529   ."    .push       -- push values to debuggee data stack (use `:` to exec Forth in dbg)" CR
 530   ."    .dclear     -- clear *debugger* data stack" CR
 531   ."    .depth      -- print *debugger* data stack depth" CR
 532   ." c  continue    -- leave debugger, continue program execution" CR
 533   ." s  step        -- single-step (execute once Forth instruction)" CR
 534   ." o  step-over   -- execute over once forth instruction (rstack check)" CR
 535   ." q  quit        -- quit application" CR
 536   ."    step-line   -- step over the current line (enter subroutines)" CR
 537   ."    step-l-over -- ( over-loops ) step over the current line (skip subroutines)" CR
 538 ;
 539 alias-for .help is .h
 540
 541 prev-defs
 542
 543
 544 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 545 ;; more LINORE hotkeys
 546 ;;
 547
 548 also-defs: linore:osc-actions
 549
 550 // F7
 551 : 18~  ( -- )  commands:step-line ;
 552 // F8
 553 : 19~  ( -- )  false commands:step-over ;
 554 // S-F8
 555 : 32~  ( -- )  true commands:step-over ;
 556
 557 prev-defs
 558
 559
 560 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 561 ;; working with breakpoints
 562 ;; UNFINISHED!
 563 ;;
 564
 565 ;; breakpoint info in user buffer
 566 16384 forth:(addr-temp-bit) + constant bp-area
 567 0 value bp-used
 568 (*
 569   breakpoint format:
 570     dd  address    ; 0: unused slot
 571     dd  old-value  ; original value  (~0: BP not set)
 572 *)
 573
 574 : (bp-rec)  ( idx -- addr )
 575   2 cells bp-area +
 576 ;
 577
 578
 579 : bp-addr@  ( bpinfo -- addr )  @ ;
 580 : bp-addr!  ( value bpinfo -- )  ! ;
 581
 582 : bp-oldval@  ( bpinfo -- oldval )  cell+ @ ;
 583 : bp-oldval!  ( value bpinfo -- )  cell+ ! ;
 584
 585
 586 : bp-alloc  ( -- bpinfo )
 587   bp-used for
 588     i (bp-rec) @ ifnot i (bp-rec) (unloop) exit endif
 589   endfor
 590   bp-used (bp-rec) +1-to bp-used
 591 ;
 592
 593 : bp-find  ( addr -- bpinfo / FALSE )
 594   bp-used for
 595     dup i (bp-rec) @ = if drop i (bp-rec) (unloop) exit endif
 596   endfor drop false
 597 ;
 598
 599 ;; add new breakpoint
 600 : bp-set  ( addr -- )
 601   dup bp-find ifnot  ;; create new breakpoint
 602     bp-alloc 2dup bp-addr!  0 bitnot over bp-oldval!
 603   else nip
 604   endif  ( bpinfo )
 605   dup bp-oldval@ 0 bitnot = ifnot  ;; not set yet
 606     dup bp-addr@ @ over bp-oldval! ;; save old value
 607     ['] debug:(bp) swap bp-addr@ ! ;; and patch the code
 608   else drop
 609   endif
 610 ;
 611
 612
 613 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 614 ;; main loop
 615 ;;
 616
 617 : debugger-draw-prompt  ( -- )
 618   " \r\e[0;1;5m>\e[0m" tty:raw-type
 619 ;
 620
 621 ' debugger-draw-prompt to (linore-draw-prompt)
 622
 623 0 value run-forth-ret-addr
 624
 625 : run-forth-done  ( -- )
 626   \ ." FORTH DONE!" cr
 627   endcr tty:raw-flush
 628   compiler:exec!
 629   linore:reset
 630   rp0! run-forth-ret-addr >r
 631 ;
 632
 633 ;; do not allow debugger to abort on bad forth word
 634 ..: forth:(interpret-word-not-found-post)  ( addr count -- addr count )
 635   active? if
 636     space xtype ." ? -- wut?!" cr
 637     run-forth-done
 638   endif
 639 ;..
 640
 641
 642 ;; run Forth code in debugger context.
 643 ;; this is used to execute all debugger commands, yay!
 644 : run-forth  ( ... )
 645   ;; set TIB and run one line
 646   0 linore:line + c!  ;; finish tib with 0 byte
 647   linore:line drop tib ! >in 0!  ;; setup tib
 648   ['] run-forth-done (user-interpret-next-line) !
 649   r@ to run-forth-ret-addr
 650   (newline)
 651   $IF 0
 652     tib @ >a begin c@a while c@a xemit +1>a repeat cr
 653     ." ---" cr
 654   $ENDIF
 655   tty:raw-flush
 656   interpret
 657   run-forth-done
 658 ;
 659
 660
 661 : debugger-main-loop ( -- )
 662   process-task-switch
 663   sp0! rp0!
 664   begin
 665     1 to linore:start-x
 666     tty:size drop to linore:draw-width
 667       \ linore:visible-amount 2* to linore:draw-width
 668     flush-emit linore:edit-line
 669     linore:accept-result 0<
 670     if
 671       linore:accept-result linore:result-esc <> if
 672         commands:continue
 673       endif
 674     else
 675       linore:line nip 0= if " .source" linore:line! endif
 676       only forth definitions also commands
 677       run-forth
 678     endif
 679   again
 680 ;
 681
 682 : debugger-startup  \ multitask entry point
 683   \ ." yay, we are in debugger!" cr
 684   \ ." debugger stid: " mtask:active-state . cr
 685   ( ... argc old-stid )
 686   swap " wuta?!" ?error   ;; there should be no args
 687   mtask:set-self-as-debugger
 688   0 swap mtask:yield-to   ;; return to the caller
 689   ['] debugger-main-loop execute-tail
 690 ;
 691
 692
 693 : setup-debugger  ( -- )
 694   ['] debugger-startup mtask:new-state to debugger-task
 695   0 debugger-task mtask:yield-to  ;; init it
 696   debugger-task <> " shit!" ?error
 697   " fuck!" ?error  ;; check number of args
 698 ;
 699
 700
 701 prev-defs
 702
 703 debugger:setup-debugger
 704
 705 [ENDIF]