105 lines
3.1 KiB
Plaintext
Executable file
105 lines
3.1 KiB
Plaintext
Executable file
( xp -- execution pointer - pointer to word definition
|
|
ip -- instruction pointer - pointer to pointer to word def
|
|
fp -- C function pointer used to drive the VM )
|
|
|
|
var brk-xp
|
|
var dbg-ip
|
|
var dbg-task
|
|
var dbg-emit
|
|
defer dbg-cmd
|
|
|
|
: dbg-first-ip ( xp -- [ip|0] )
|
|
dup cell + swap @ ( worddata fp )
|
|
dup $DOCOLON = if drop else
|
|
dup $DOCREATE = if drop @ else
|
|
$DODEFERRED = if @ dbg-first-ip else
|
|
drop 0 then then then ; userword
|
|
|
|
: tail :| rdrop dbg-first-ip >r |; , [ ' [ , ] ; immediate
|
|
|
|
: get-dbg-xp ( ip -- xp ) brk-xp @ not if @ else drop brk-xp @ then ;
|
|
: consume-dbg-xp ( ip -- xp ) get-dbg-xp 0 brk-xp ! ;
|
|
|
|
: DBG-WAIT ( ip -- ip )
|
|
running dbg-task !
|
|
' DBG-WAIT ' dbg-cmd redefine
|
|
dup dbg-ip !
|
|
suspend
|
|
' dbg-cmd tail
|
|
|
|
: .dbg ( ip -- ip )
|
|
task-emit @ >r dbg-emit @ dup if task-emit ! else drop then
|
|
cr dup .wordin s" ip: " type dup . dup get-dbg-xp ` type cr
|
|
>r .s <r cr
|
|
<r task-emit ! ;
|
|
|
|
: debugger <r .dbg ' DBG-WAIT tail userword
|
|
: debug ( xp -- ) dbg-first-ip .dbg ' DBG-WAIT tail userword
|
|
|
|
: DBG-STEP-IN ( ip -- ip ) dup consume-dbg-xp swap emulate .dbg ' DBG-WAIT tail
|
|
: DBG-STEP-OVER ( ip -- ip )
|
|
dup consume-dbg-xp swap over dbg-first-ip not if ( xp ip )
|
|
emulate ( is primitive - can't step over )
|
|
else
|
|
>r execute <r cell +
|
|
then .dbg ' DBG-WAIT tail
|
|
: DBG-RUN-TO-END ( ip -- ) [ ' debugger dbg-first-ip lit ] >r >r ;
|
|
: DBG-CONT ( ip -- ) >r ;
|
|
|
|
: s ' DBG-STEP-IN ' dbg-cmd redefine ; userword
|
|
: n ' DBG-STEP-OVER ' dbg-cmd redefine ; userword
|
|
: c ' DBG-CONT ' dbg-cmd redefine ; userword
|
|
: u ' DBG-RUN-TO-END ' dbg-cmd redefine ; userword
|
|
: bt dbg-task @ task.bt ; userword
|
|
: l dbg-ip @ decompile-from ; userword
|
|
|
|
: bp.do 2 cells - ;
|
|
: bp.ip ; immediate
|
|
: bp.xp cell + ;
|
|
|
|
( byte golfing is annoyingly satisfying - we don't need or want $DOCOLON
|
|
at the start nor ret at the end, so instead of using an inline function
|
|
or a :noname, we just turn on the compiler with "]" and go. )
|
|
here ] bp.xp @ brk-xp ! <r cell - .dbg ' DBG-WAIT tail
|
|
: bp, $DOCREATE , [ lit ] , 0 , 0 , ;
|
|
|
|
array breakpoints bp, bp, bp, bp, bp,
|
|
5 const MAX-BREAKPOINTS
|
|
: breakpoint# ( n -- p ) 4 * 2 + cells breakpoints + ;
|
|
|
|
: clear-breakpoint ( bp -- )
|
|
dup bp.ip @ if
|
|
dup bp.xp @ over bp.ip @ !
|
|
0 over bp.ip ! 0 swap bp.xp !
|
|
else drop then ;
|
|
: set-breakpoint ( ip bp -- )
|
|
over if
|
|
2dup bp.ip !
|
|
over @ over bp.xp !
|
|
bp.do swap !
|
|
else drop drop then ;
|
|
: reset-breakpoint ( ip bp -- ) dup clear-breakpoint set-breakpoint ;
|
|
|
|
: free-breakpoint 0 MAX-BREAKPOINTS 0 for
|
|
i 1 - breakpoint# bp.ip @ not if
|
|
drop i 1 -
|
|
then next ;
|
|
|
|
: set-next-breakpoint ( ip -- )
|
|
free-breakpoint >r r@ breakpoint# reset-breakpoint
|
|
<r s" bp " type . s" set" type cr ; userword
|
|
|
|
: b word lookup drop dbg-first-ip dup if set-next-breakpoint
|
|
else s" word not found" type cr drop then ; userword
|
|
: unb breakpoint# clear-breakpoint ; userword
|
|
: break-after cells dbg-ip @ + set-next-breakpoint ; userword
|
|
: bh 0 break-after ; userword
|
|
|
|
: .bp 0 MAX-BREAKPOINTS for
|
|
i .
|
|
i breakpoint# bp.ip @ dup .
|
|
` type
|
|
i breakpoint# bp.xp @ ` type
|
|
cr
|
|
next ; userword
|