\ Assembly language breakpoints
\
\ Files needed:
\
\ objects.fth           Defining words for multiple code field words
\ registers.fth         Defines the register save area.
\                               CPU dependent
\ catchexc.fth          Saves the machine state in the register save area.
\                               CPU & operating system dependent
\ machdep.fth           Defines CPU-dependent words for placing breakpoints
\                       and finding the next instruction.
\                               CPU-dependent
\ breakpt.fth           (This file) Manages the list of breakpoints, handles
\                       single-stepping.        Machine-independent

needs array extend\array.fth

only forth also hidden also system  also bug also
hidden definitions

decimal

20 constant max#breakpoints
max#breakpoints array >breakpoint
max#breakpoints array >saved-opcode

2 array >step-breakpoint
2 array >step-saved-opcode
variable #breakpoints
variable #steps
variable pc-at-breakpoint
variable breakpoints-installed

: init-breakpoints      ( -- )
        #steps off
        #breakpoints off
        0 >step-breakpoint off
        1 >step-breakpoint off
        breakpoints-installed off ;
init-breakpoints

\ Search the breakpoint table to see if adr is breakpointed.
\ If it is, return the index into the table, or -1 if it's not there.
: find-breakpoint       ( adr -- breakpoint#|-1 )
        -1 swap  #breakpoints @
        0 ?do   dup  i >breakpoint @  =
                if  nip i swap leave  then
        loop  ( breakpoint# | -1 )
        drop ;

\ Enter a breakpoint at addr.  If adr is already breakpointed,
\ don't enter it twice.
: set-breakpoint  ( adr -- )
        dup find-breakpoint  0<         ( adr breakpoint# )
        if      #breakpoints @ max#breakpoints >=  abort" Too many breakpoints"
                #breakpoints @  1 #breakpoints +!  ( breakpoint# )
                >breakpoint !
        else    drop
        then ;

\ Display the breakpoint table.
: show-breakpoints ( -- )
        #breakpoints @  0  ?do  i >breakpoint @ u.  loop ;

\ If the breakpoint is installed in memory, take it out.
: repair-breakpoint  ( breakpoint# -- )
        dup >breakpoint @ at-breakpoint?
        if  dup >saved-opcode @   over >breakpoint @  op!   then
        drop ;

\ Remove the breakpoint at adr from the table, if it's there.
: remove-breakpoint  ( adr -- )
        find-breakpoint  ( breakpoint# )
        dup 0<  ( breakpoint# flag )
        if      drop
        else    ( breakpoint# )
                dup repair-breakpoint
                \ Shuffle the remaining breakpoints down to fill the vacated slot
                #breakpoints @  swap 1+  ( last-breakpoint# breakpoint# )
                ?do   i >breakpoint  @  i 1- >breakpoint  !  loop
                -1 #breakpoints +!
        then ;

\ When we restart the program, we have to put breakpoints at all the
\ places in the breakpoint list.  If there is a breakpoint at the
\ current PC, we have to temporarily not put one there, because we
\ want to execute it at least once (presumably we just hit it).
\ So we have to single step by putting breakpoints at the next instruction,
\ then when we hit that instruction, we put the breakpoint at the previous
\ place.  In fact, the "next instruction" may actually be 2 instructions
\ because the current instruction could be a branch.

: install-breakpoints  ( -- )
        breakpoints-installed @ ?exit
        breakpoints-installed on
        #breakpoints @ 0
        ?do     i >breakpoint @              ( breakpoint-adr )
                dup op@  i >saved-opcode !   ( breakpoint-adr )
                put-breakpoint
        loop ;
: repair-breakpoints  ( -- )
        #breakpoints @  0   ?do  i repair-breakpoint  loop
        breakpoints-installed off ;

defer restart  ( -- )  ' (restart  is restart

\ Single stepping:
\ To single step, we have to breakpoint the instruction just after the
\ current instruction.  If that instruction is a conditional branch, we
\ have to breakpoint both the next instruction and the branch target.
\ The machine-dependent next-instruction routine finds the next instruction
\ and the branch target.

variable following-jsrs?
: set-step-breakpoints  ( -- )
        following-jsrs? @   next-instruction  ( next-adr branch-target|0 )
        swap              ( step-breakpoint-adr0 step-breakpoint-adr1 )
        2 0
        do      dup i >step-breakpoint !  ?dup          ( step-breakpoint-adr )
                if      dup op@  i >step-saved-opcode ! ( step-breakpoint-adr )
                        put-breakpoint
                then
        loop ;
: repair-step-breakpoints  ( -- )
        2 0 do  i >step-breakpoint @  ?dup
                if      at-breakpoint?
                        if i >step-saved-opcode @ i >step-breakpoint @ op! then
                        0 i >step-breakpoint !
                then
        loop ;
: remove-all-breakpoints        ( -- )
        repair-breakpoints  repair-step-breakpoints  #breakpoints off ;
: current-address-breakpointed? ( -- flag )
        rpc  find-breakpoint 0>= ;
: (step                         ( -- )
        set-step-breakpoints  restart  ;

forth definitions
: breakpoint-go ( -- )          install-breakpoints  restart  ;
: steps         ( n -- )        #steps !  following-jsrs? on  (step  ;
: step          ( -- )          1 steps  ;
: hops          ( n -- )        #steps !  following-jsrs? off  (step  ;
: hop           ( -- )          1 hops  ;
: go            ( -- )
        #steps off
        current-address-breakpointed?
        if  -1 #steps !  (step  else  install-breakpoints  restart  then ;
alias continue go
: till          ( adr -- )      set-breakpoint  go  ;
: return        (      -- )     \ Finsh and return from subroutine
        return-adr  till  ;
: returnl       ( -- )          \ Finish and ret. from leaf subr.
        leaf-return-adr  till  ;
: finish-loop   ( -- )          \ Finish the enclosing loop
        loop-exit-adr  till  ;

variable #gos
: gos   ( n -- )        1- #gos !  go  ;
: .pc   ( -- )          rpc  .  ;
defer .step
defer .breakpoint

hidden definitions

' .instruction is .step
' .instruction is .breakpoint

: breakpoint-message  ( -- )
        #steps @
        if      \ Hidden step to execute an instruction with a breakpoint on it
                #steps @  -1 =  if  #steps off continue  then
                \ Real step
                .step   -1 #steps +!  #steps @  if  (step  then
        else
                pc-at-breakpoint @
                if      .breakpoint
                        #gos @  if  -1 #gos +!  go  then
                else    .exception
                then
        then ;
: (handle-breakpoint  ( -- )
        current-address-breakpointed?  pc-at-breakpoint !
        repair-step-breakpoints
        repair-breakpoints
        breakpoint-message
        quit ;
' (handle-breakpoint is handle-breakpoint

forth definitions
: +bp   ( adr -- )      set-breakpoint  ;
: -bp   ( adr -- )      remove-breakpoint  ;
\ Remove most-recently-set breakpoint
: --bp  ( -- )
	#breakpoints @
	if	#breakpoints @ 1-  repair-breakpoint
		-1 #breakpoints +!
	then ;

\ XXX The Sun boot PROM resets the illegal instruction exception vector
\ when you use it to boot a subprogram.
\ stand-catch-exceptions should be executed after doing so
: bpon          ( -- )          install-breakpoints  ;
: .bp           ( -- )          show-breakpoints  ;
: bpoff         ( -- )          remove-all-breakpoints  ;
: cstart        ( adr -- )      bpon goto  ;
: skip          ( -- )          bumppc go  ;
: trace		( -- )		' dup +bp #steps off cstart ;
: (cold-hook    ( -- )          (cold-hook  init-breakpoints  ;
only forth also definitions
