\ vandys
\ debug.f
\ Implement a simple debugger
\ This debugger is influenced in spirit, if not implementation details,
\ by Joerg Plewe's ANSI Forth debugger. Like his, we implement the
\ debugger by inserting our actions into the code generation process.
\ However, we do this not because it's the only "allowed" place, but
\ rather because we have no centralized "next" (and switching to one
\ would cost us 2x slowdown in execution speed, I tried it).
\
\ The compiler has a call to the 'genhook vector, which is usually
\ a no-op. [+debug] instead switches this to a routine which emits
\ an @execute via 'trap instead. We then insert appropriate checking
\ in a trap handling routine, and drop into the debugger when needed.
only extensions definitions
\ vandys
\ Vector to our 'trap handler, and our 'abortTrap handler
variable (''trap) variable (''atrap)
\ Ranges of addresses to trap as breakpoints
8 constant MAXBPT
create (bpts) MAXBPT cells 2* allot
create (nbpt) 0 ,
\ Flag to break ASAP--for "single" stepping
create (stepping?) 0 ,
\ Flag that we're in debug command mode
create (indebug?) 0 ,
\ List of words explicitly breakpointed by user
create (ubpts) MAXBPT cells allot
create (nubpt) 0 ,
\ Convert tick addr into address of first high-level word pointer
: >hilev ( a -- a' ) cell+ cell+ ;
\ vandys
\ Convert addr to beginning of hilev definition
\ This is *very* machine specific; it looks for the signature of
\ the assembly code header leading into a high-level definition,
\ and thus must be adjusted for targets other than the x86.
: hilev? ( a -- bool ) @ $E82E2E2E = ;
: <hilev ( a -- a' ) begin dup hilev? not while cell- repeat >hilev ;
\ Convert index into breakpoint slot
: >bpt ( u -- a ) cells 2* (bpts) + ;
\ Find the slot matching our address, or return false
: (findBpt) ( a -- F | u T )
(nbpt) @ 0 ?do i >bpt 2@
>r over u>= if r> over u<= if
drop i true unloop exit then
else r> drop then
loop drop false ;
\ vandys
\ Find the ending address of a high-level routine
\ Assumes there's a (;) at the end; not true for kernel words (yet?)
: >endCode ( a -- a' ) begin dup @ ['] (;) - while cell+ repeat ;
\ Set a breakpoint
: (setBpt) ( cfaLow cfaHigh -- )
swap dup (findBpt) if >bpt >r 2dup r> 2@ d= if 2drop exit then then
(nbpt) @ dup MAXBPT >= abort" Too many breakpoints"
>bpt 2! 1 (nbpt) +! ;
\ Clear a breakpoint
: (clrBpt) ( cfa -- )
begin dup (findBpt) while
dup >bpt dup cell+ cell+ swap rot (nbpt) @ swap 1+ - cells 2* move
-1 (nbpt) +!
repeat drop ;
\ Convert index to user breakpoint word
: >ubpt cells (ubpts) + ;
\ vandys
: (clrUbpt) ( cfa -- ) (nubpt) @ 0 ?do i >ubpt @ over = if
drop i >ubpt dup cell+ swap (nubpt) @ i - 1- cells move
-1 (nubpt) +! unloop exit then
loop drop ;
: (setUbpt) ( cfa -- ) dup (clrUbpt) \ Just in case
(nubpt) @ dup MAXBPT >= abort" Too many breakpoints"
>ubpt ! 1 (nubpt) +! ;
: (setTraps) ( ? -- ) 0= if 'trap off 'abortTrap off exit then
(''trap) @ 'trap ! (''atrap) @ 'abortTrap ! ;
: (syncBpt) ( -- ) (nubpt) @ dup (nbpt) ! 0 ?do
i >ubpt @ dup i >bpt 2! loop (nbpt) @ (setTraps) ;
\ vandys
\ Show successive memory locations, return on CR
: (showMem) ( a -- ) begin
dup (prval) ." : " dup @ (showval) cr
key case
13 of drop exit endof \ Leave on CR or 'q'
[char] q of drop exit endof
[char] - of cell- endof \ Back up one cell on '-'
[char] + of cell+ endof \ Forward one cell on '+' or space key
32 of cell+ endof
." ?" endcase
again ;
\ Set a break across an entire function
: (breakFn) ( cfa -- ) dup @ ['] exit = if
\ Break at the calling function if we're going to execute "exit"
drop r> r> r@ swap >r swap >r
then <hilev dup >endCode (setBpt) ;
\ Stack backtrace, with calling frame knowledge vandys
[ifndef] #locals
8 constant #locals variable 'end}--
[then]
: .frame ( frame -- 'frame ptr-rp )
@+ 'end}-- = ( frame extended? )
swap dup #locals (dumpw) #locals cells + ( extended? frame+ )
@+ -rot ( 'frame extended? frame++ )
swap if cell+ cell+ @+ ." in: " (showval) cr then ; scrLocal
: xwhere ( -- ) cr (local) @ rp@ begin ( frame ptr-rp )
dup rp0 @ < while
2dup = if drop .frame else @+ (showval) cr then
repeat 2drop ; Local
defer .src \ Defined later
: .srcs ( -- ) rp@ begin
dup @ dup .src dup (prval) ." : " @ (prval) cr ( 'rp )
key dup [char] < = if drop cell+ rp0 @ min else
[char] > = if cell- rp@ max
else drop exit then then
again ;
\ vandys
\ Main UI of debugger mode
defer Undebug
: (debugger) ." Debugger at " r@ dup (prval) ." : " @ (prval) cr
(syncBpt) (stepping?) off (indebug?) on
begin .s cr ." debug>" key case
32 of ." next" cr r@ (breakFn) (indebug?) off exit endof
[char] a of 1 abort" Aborted" endof
[char] c of ." continue" cr (syncBpt) (indebug?) off exit endof
[char] d of ." delete breakpoint" cr r@ <hilev (clrUbpt) endof
[char] s of ." step" (stepping?) on (indebug?) off exit endof
[char] U of ." Undebug" Undebug endof
[char] w of ." where:" ['] xwhere catch drop endof
[char] . of ." stack contents: " cr endof \ They'll see it anyway
[char] / of ." show mem:" r@ (showMem) endof
[char] < of ." Walk return stack:" cr .srcs endof
[char] : of ." Command line: " query ['] eval catch if
." (aborted)" then cr endof
[char] ? of ." Commands are: [ ] step [c]ontinue [d]elete breakpoint " cr
." [.]s (print stack) [w]here [/] display mem [?] show this help" cr
." [a]bort [s]tep into" cr
endof
." ?" cr
endcase again ;
\ Breakpoint handling vandys
: debug ( -- ) ' >hilev (setUbpt) (syncBpt) ;
: undebug ( -- ) ' >hilev (clrUbpt) (syncBpt) ;
:noname (bpts) MAXBPT cells 2* erase
(ubpts) MAXBPT cells erase 'trap off 'abortTrap off
(nbpt) off (nubpt) off (stepping?) off ; is Undebug
: (findBpt?) (findBpt) dup if swap drop then ;
\ Source code access support--data structures, init, DB store vandys
variable 'tagSrc Local variable srcMap
variable nMap variable srcHigh
struct src
intcell ca intcell blk intcell off endstruct
: entry! ( a-entry -- ) blk @ over src>blk !
>in @ swap src>off ! ; Local
\ Note: bootup init is at end of this source file (boot-srcMap)
\ Source code access support--creating blk/line# database vandys
: update? ( -- ? ) here srcHigh @ > if
here srcHigh ! false exit then
srcMap @ nMap @ 0 ?do
here over src>ca @ = if entry! drop unloop true exit then
src.size + loop drop false ; scrLocal
: growMap ( -- a-entry ) nMap inc srcMap @ ( a-map )
nMap @ src.size * tuck bkrealloc dup srcMap !
( u-sz a-map' ) swap src.size - + ; scrLocal
: tagSrc ( -- ) blk @ 0= if exit then update? if exit then
growMap here over src>ca ! entry! ; scrLocal
: +g ( -- ) ['] tagSrc 'tagSrc ! ;
: -g ( -- ) 'tagSrc off ;
\ Source code access support--search DB vandys
: (entry@) ( ca -- a-entry T | F )
srcMap @ nMap @ 0 ?do ( ca a-entry )
2dup src>ca @ = if unloop nip true exit then
src.size + loop 2drop false ; scrLocal
4 constant backDistance scrLocal
: entry@ ( ca -- a-entry T | F ) backDistance 0 do
dup (entry@) if unloop nip true exit then
cell- loop drop false ; Local
\ Source code access support--display support vandys
2 constant nearLines Local
: .lines ( line# buf -- ) swap dup nearLines + swap do ( buf )
i 0 BLKROWS within if
dup i BLKCOLS * + BLKCOLS -trailing type cr then
loop drop ; Local
variable pos scrLocal variable line scrLocal variable idx scrLocal
: .srcLine ( line pos -- )
dup BLKCOLS < if 1- then tuck pos ! line !
( pos' ) begin 1- dup line @ + c@ ( pos' c )
bl = dup if swap 1+ swap then over 0= or until
idx ! line @ idx @ type
inv-on line @ idx @ + pos @ idx @ - type inv-off
line @ pos @ + BLKCOLS pos @ - -trailing type cr ; Local
\ Source code access support--display source vandys
variable buf scrLocal variable line# scrLocal variable pos2 scrLocal
:noname ( : .src ) ( ca -- ) entry@ 0= if exit then ( entry )
." Block" dup src>blk @ . ." , line" dup src>off @ BLKCOLS / . cr
dup src>blk @ block buf ! src>off @ dup pos2 !
( pos ) BLKCOLS / dup line# ! nearLines - buf @ .lines
buf @ line# @ BLKCOLS * + pos2 @ BLKCOLS mod .srcLine
line# @ 1+ buf @ .lines ; is .src
\ Trap handling vandys
variable 'sniffer ( word is called { ? -- ? | T } )
: ('trap) ( -- ) r@ cell- (findBpt?) (stepping?) @ or
'sniffer @execute
if branch [ ' (debugger) >hilev , ] then ;
: ('atrap) ( a -- a ) (indebug?) @ if exit then
." Abort: " dup count type cr
blk @ ?dup if ." Block" . >in @ ." line" dup BLKCOLS / 1+ .
." column" BLKCOLS mod 1+ . cr then
branch [ ' (debugger) >hilev , ] ;
' ('trap) >hilev (''trap) ! ' ('atrap) (''atrap) !
: (trap) ( -- ) 'trap @ ?dup if >r then ;
: (genTrap) ( -- ) ['] (trap) , 'tagSrc @execute ;
\ vandys
\ Disable and enable debug code generation. Note the words are
\ immediate, so it can be done at a granularity finer than a
\ single word definition.
: [+debug] ['] (genTrap) 'genhook ! ; immediate
: [-debug] 0 'genhook ! ; immediate
\ Stop at the next stoppable point; most useful for breaking in
\ an OO method
: breakNext ( -- ) (stepping?) on true (setTraps) ;
\ Hook to init src code DB; "definitions" clears Local names, so we put
\ this at the tail of the source code
also initialize definitions
: boot-srcMap ( ? -- u | ) if
srcMap off nMap off srcHigh off exit then
20000 ;
only
: (clrUbpt) Clean user-initiated breakpoint
: (setUbpt) Set user-initiated breakpoint on the named word
: (setTraps) Update trap vectors based on whether we have breakpoints
: (syncBpt) Set active breakpoints to just those in the user breakpoint list
Forward references from the local variable implementation; # of local
variables supported, and high-level return catcher
: .frame Display a particular frame, returning next frame and RP pointer
Fetch return addr, from this deduce the frame format
For either case, dump the local variables themselves
Also for either case, next up is pointer to next frame
For return format checking, show caller and skip rest
: xwhere Show calling stack; this version is only compiled if we have
local variables compiled into the system
: .srcs Walk up and down return stack, interpreting contents
Fetch cell at this slot, display source and symbolic interpretation
Get a key; < walks deeper into the stack, > walks back out
We, of course, cap at top and bottom of stack
Any other key leaves this mode
: debug Set breakpoint on word
: undebug ...clean breakpoint
: Undebug Clean all breakpoints
: (findBpt?) Only return flag for finding breakpoint, don't return an index
Vector for tagging source, and actual data structure for mapping
# entries in srcMap
Record of a code location in the source
Storage addr Blk # Offset to src in blk
: entry! Save current blk # and src offset into entry
: update? See if this code addr is already recorded; just update it in
place if so; optimize for common case of new code above highest
previous addr
: growMap Grow size of srcMap, return pointer to new entry at end of it
: tagSrc Save current code location, blk#, and src offset. No-op if not
compiling from disk, update old entry in place if present.
: g+/g- Enable and disable recording of source information
vandys
: (entry@) Fetch source code entry for this location
# cells backward to permit a match
: entry@ Fetch source code entry for this location, or one "close
enough"
vandys
# lines to show on each side of source line
: .lines Display nearLines # of lines, starting at the given line #.
Inhibit action if the number is out of the range 0..BLKROWS-1
No { variables } at this stage of system boot, so plain old variables
: .srcLine Display the actual source line, with position highlighted
Back up over terminating whitespace (if any)
Walk back over letters of word, until whitespace or start of line
Then display leading part of line
Actual word for this location
And trailing part of line
vandys
: .src Display source and surrounding lines
Code hook for arbitrary condition to break to debugger
: ('trap) Drop into debugger if we're in a selected debug trap range
Also drop in if our code sniffer hook or'ed in a TRUE
Note: unstructured jump to (debugger), to leave stack frame intact from caller
: ('atrap) Trap on about to throw from an abort"
Show abort string
Show an input location if our input is from a block
Jump into the debugger
\ Point our trap vectors at these routines
: (trap) Branch over to trap handling if set in 'trap
: (genTrap) Compile a (trap) call