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 >
Text File  |  1995-03-01  |  8KB  |  210 lines
  1. \ Assembly language breakpoints
  2. \
  3. \ Files needed:
  4. \
  5. \ objects.fth           Defining words for multiple code field words
  6. \ registers.fth         Defines the register save area.
  7. \                               CPU dependent
  8. \ catchexc.fth          Saves the machine state in the register save area.
  9. \                               CPU & operating system dependent
  10. \ machdep.fth           Defines CPU-dependent words for placing breakpoints
  11. \                       and finding the next instruction.
  12. \                               CPU-dependent
  13. \ breakpt.fth           (This file) Manages the list of breakpoints, handles
  14. \                       single-stepping.        Machine-independent
  15.  
  16. needs array extend\array.fth
  17.  
  18. only forth also hidden also system  also bug also
  19. hidden definitions
  20.  
  21. decimal
  22.  
  23. 20 constant max#breakpoints
  24. max#breakpoints array >breakpoint
  25. max#breakpoints array >saved-opcode
  26.  
  27. 2 array >step-breakpoint
  28. 2 array >step-saved-opcode
  29. variable #breakpoints
  30. variable #steps
  31. variable pc-at-breakpoint
  32. variable breakpoints-installed
  33.  
  34. : init-breakpoints      ( -- )
  35.         #steps off
  36.         #breakpoints off
  37.         0 >step-breakpoint off
  38.         1 >step-breakpoint off
  39.         breakpoints-installed off ;
  40. init-breakpoints
  41.  
  42. \ Search the breakpoint table to see if adr is breakpointed.
  43. \ If it is, return the index into the table, or -1 if it's not there.
  44. : find-breakpoint       ( adr -- breakpoint#|-1 )
  45.         -1 swap  #breakpoints @
  46.         0 ?do   dup  i >breakpoint @  =
  47.                 if  nip i swap leave  then
  48.         loop  ( breakpoint# | -1 )
  49.         drop ;
  50.  
  51. \ Enter a breakpoint at addr.  If adr is already breakpointed,
  52. \ don't enter it twice.
  53. : set-breakpoint  ( adr -- )
  54.         dup find-breakpoint  0<         ( adr breakpoint# )
  55.         if      #breakpoints @ max#breakpoints >=  abort" Too many breakpoints"
  56.                 #breakpoints @  1 #breakpoints +!  ( breakpoint# )
  57.                 >breakpoint !
  58.         else    drop
  59.         then ;
  60.  
  61. \ Display the breakpoint table.
  62. : show-breakpoints ( -- )
  63.         #breakpoints @  0  ?do  i >breakpoint @ u.  loop ;
  64.  
  65. \ If the breakpoint is installed in memory, take it out.
  66. : repair-breakpoint  ( breakpoint# -- )
  67.         dup >breakpoint @ at-breakpoint?
  68.         if  dup >saved-opcode @   over >breakpoint @  op!   then
  69.         drop ;
  70.  
  71. \ Remove the breakpoint at adr from the table, if it's there.
  72. : remove-breakpoint  ( adr -- )
  73.         find-breakpoint  ( breakpoint# )
  74.         dup 0<  ( breakpoint# flag )
  75.         if      drop
  76.         else    ( breakpoint# )
  77.                 dup repair-breakpoint
  78.                 \ Shuffle the remaining breakpoints down to fill the vacated slot
  79.                 #breakpoints @  swap 1+  ( last-breakpoint# breakpoint# )
  80.                 ?do   i >breakpoint  @  i 1- >breakpoint  !  loop
  81.                 -1 #breakpoints +!
  82.         then ;
  83.  
  84. \ When we restart the program, we have to put breakpoints at all the
  85. \ places in the breakpoint list.  If there is a breakpoint at the
  86. \ current PC, we have to temporarily not put one there, because we
  87. \ want to execute it at least once (presumably we just hit it).
  88. \ So we have to single step by putting breakpoints at the next instruction,
  89. \ then when we hit that instruction, we put the breakpoint at the previous
  90. \ place.  In fact, the "next instruction" may actually be 2 instructions
  91. \ because the current instruction could be a branch.
  92.  
  93. : install-breakpoints  ( -- )
  94.         breakpoints-installed @ ?exit
  95.         breakpoints-installed on
  96.         #breakpoints @ 0
  97.         ?do     i >breakpoint @              ( breakpoint-adr )
  98.                 dup op@  i >saved-opcode !   ( breakpoint-adr )
  99.                 put-breakpoint
  100.         loop ;
  101. : repair-breakpoints  ( -- )
  102.         #breakpoints @  0   ?do  i repair-breakpoint  loop
  103.         breakpoints-installed off ;
  104.  
  105. defer restart  ( -- )  ' (restart  is restart
  106.  
  107. \ Single stepping:
  108. \ To single step, we have to breakpoint the instruction just after the
  109. \ current instruction.  If that instruction is a conditional branch, we
  110. \ have to breakpoint both the next instruction and the branch target.
  111. \ The machine-dependent next-instruction routine finds the next instruction
  112. \ and the branch target.
  113.  
  114. variable following-jsrs?
  115. : set-step-breakpoints  ( -- )
  116.         following-jsrs? @   next-instruction  ( next-adr branch-target|0 )
  117.         swap              ( step-breakpoint-adr0 step-breakpoint-adr1 )
  118.         2 0
  119.         do      dup i >step-breakpoint !  ?dup          ( step-breakpoint-adr )
  120.                 if      dup op@  i >step-saved-opcode ! ( step-breakpoint-adr )
  121.                         put-breakpoint
  122.                 then
  123.         loop ;
  124. : repair-step-breakpoints  ( -- )
  125.         2 0 do  i >step-breakpoint @  ?dup
  126.                 if      at-breakpoint?
  127.                         if i >step-saved-opcode @ i >step-breakpoint @ op! then
  128.                         0 i >step-breakpoint !
  129.                 then
  130.         loop ;
  131. : remove-all-breakpoints        ( -- )
  132.         repair-breakpoints  repair-step-breakpoints  #breakpoints off ;
  133. : current-address-breakpointed? ( -- flag )
  134.         rpc  find-breakpoint 0>= ;
  135. : (step                         ( -- )
  136.         set-step-breakpoints  restart  ;
  137.  
  138. forth definitions
  139. : breakpoint-go ( -- )          install-breakpoints  restart  ;
  140. : steps         ( n -- )        #steps !  following-jsrs? on  (step  ;
  141. : step          ( -- )          1 steps  ;
  142. : hops          ( n -- )        #steps !  following-jsrs? off  (step  ;
  143. : hop           ( -- )          1 hops  ;
  144. : go            ( -- )
  145.         #steps off
  146.         current-address-breakpointed?
  147.         if  -1 #steps !  (step  else  install-breakpoints  restart  then ;
  148. alias continue go
  149. : till          ( adr -- )      set-breakpoint  go  ;
  150. : return        (      -- )     \ Finsh and return from subroutine
  151.         return-adr  till  ;
  152. : returnl       ( -- )          \ Finish and ret. from leaf subr.
  153.         leaf-return-adr  till  ;
  154. : finish-loop   ( -- )          \ Finish the enclosing loop
  155.         loop-exit-adr  till  ;
  156.  
  157. variable #gos
  158. : gos   ( n -- )        1- #gos !  go  ;
  159. : .pc   ( -- )          rpc  .  ;
  160. defer .step
  161. defer .breakpoint
  162.  
  163. hidden definitions
  164.  
  165. ' .instruction is .step
  166. ' .instruction is .breakpoint
  167.  
  168. : breakpoint-message  ( -- )
  169.         #steps @
  170.         if      \ Hidden step to execute an instruction with a breakpoint on it
  171.                 #steps @  -1 =  if  #steps off continue  then
  172.                 \ Real step
  173.                 .step   -1 #steps +!  #steps @  if  (step  then
  174.         else
  175.                 pc-at-breakpoint @
  176.                 if      .breakpoint
  177.                         #gos @  if  -1 #gos +!  go  then
  178.                 else    .exception
  179.                 then
  180.         then ;
  181. : (handle-breakpoint  ( -- )
  182.         current-address-breakpointed?  pc-at-breakpoint !
  183.         repair-step-breakpoints
  184.         repair-breakpoints
  185.         breakpoint-message
  186.         quit ;
  187. ' (handle-breakpoint is handle-breakpoint
  188.  
  189. forth definitions
  190. : +bp   ( adr -- )      set-breakpoint  ;
  191. : -bp   ( adr -- )      remove-breakpoint  ;
  192. \ Remove most-recently-set breakpoint
  193. : --bp  ( -- )
  194.         #breakpoints @
  195.         if      #breakpoints @ 1-  repair-breakpoint
  196.                 -1 #breakpoints +!
  197.         then ;
  198.  
  199. \ XXX The Sun boot PROM resets the illegal instruction exception vector
  200. \ when you use it to boot a subprogram.
  201. \ stand-catch-exceptions should be executed after doing so
  202. : bpon          ( -- )          install-breakpoints  ;
  203. : .bp           ( -- )          show-breakpoints  ;
  204. : bpoff         ( -- )          remove-all-breakpoints  ;
  205. : cstart        ( adr -- )      bpon goto  ;
  206. : skip          ( -- )          bumppc go  ;
  207. : trace        ( -- )        ' dup +bp #steps off cstart ;
  208. : (cold-hook    ( -- )          (cold-hook  init-breakpoints  ;
  209. only forth also definitions
  210.