neuttower/debug.jor

( 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
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 )
  cr dup .wordin s"  ip: " type dup . dup get-dbg-xp ` type cr
  >r .s <r cr ;

: 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