home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.uni-stuttgart.de/pub/systems/acorn/
/
Acorn.tar
/
Acorn
/
acornet
/
dev
/
forth
/
forthmacs
/
tools1
/
tools1~
/
!Forthmacs.extend.breakpt
< prev
next >
Wrap
Text File
|
1995-03-01
|
8KB
|
210 lines
\ 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