\ ========== Copyright Header Begin ========================================== \ \ Hypervisor Software File: breakpt.fth \ \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. \ \ - Do no alter or remove copyright notices \ \ - Redistribution and use of this software in source and binary forms, with \ or without modification, are permitted provided that the following \ conditions are met: \ \ - Redistribution of source code must retain the above copyright notice, \ this list of conditions and the following disclaimer. \ \ - Redistribution in binary form must reproduce the above copyright notice, \ this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ Neither the name of Sun Microsystems, Inc. or the names of contributors \ may be used to endorse or promote products derived from this software \ without specific prior written permission. \ \ This software is provided "AS IS," without a warranty of any kind. \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. \ \ You acknowledge that this software is not designed, licensed or \ intended for use in the design, construction, operation or maintenance of \ any nuclear facility. \ \ ========== Copyright Header End ============================================ \ breakpt.fth 2.15 01/05/18 \ Copyright 1985-1990 Bradley Forthware \ Copyright 1990-2001 Sun Microsystems, Inc. All Rights Reserved \ 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 array.fth only forth also hidden also forth definitions decimal \ Moved to cpustate.fth \ nuser restartable? restartable? off defer restart ( -- ) defer restart-step ( -- ) hidden definitions headerless 20 constant max#breakpoints max#breakpoints array >breakpoint max#breakpoints array >breakpoint-action max#breakpoints array >saved-opcode 2 array >step-breakpoint 2 array >step-saved-opcode variable #breakpoints variable #steps variable pc-at-breakpoint variable pc-at-step variable breakpoints-installed : init-breakpoints ( -- ) #steps off #breakpoints off 0 >step-breakpoint off 1 >step-breakpoint off breakpoints-installed off ; \ 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 ( adr breakpoint# ) 0< if dup ( adr adr ) #breakpoints @ max#breakpoints >= abort" Too many breakpoints" #breakpoints @ 1 #breakpoints +! ( adr breakpoint# ) >breakpoint ! then ( adr ) \ Set default action to be .breakpoint 0 swap find-breakpoint >breakpoint-action ! ; \ Display the breakpoint table. : show-breakpoints ( -- ) #breakpoints @ 0 ?do i >breakpoint @ u. i >breakpoint-action @ ?dup if ." { " >name .id ." } " then 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 ! i >breakpoint-action @ i 1- >breakpoint-action ! 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 @ if exit then breakpoints-installed on #breakpoints @ 0 ?do i >breakpoint @ ( breakpoint-adr ) dup op@ ( adr opcode ) over at-breakpoint? 0= if ( adr opcode ) i >saved-opcode ! ( breakpoint-adr ) put-breakpoint else 2drop then loop ; : repair-breakpoints ( -- ) #breakpoints @ 0 ?do i repair-breakpoint loop breakpoints-installed off ; \ 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 ! ( step-breakpoint-adr ) ?dup if ( step-breakpoint-adr ) dup op@ i >step-saved-opcode ! ( step-breakpoint-adr ) put-breakpoint then loop ; : repair-step-breakpoints ( -- ) 2 0 do i >step-breakpoint @ ?dup if ( step-breakpoint-adr ) 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 ; : uninstall-breakpoints ( -- ) breakpoints-installed @ if remove-all-breakpoints then ; : current-address-breakpointed? ( -- flag ) rpc find-breakpoint 0>= ; : current-address-stepped? ( -- flag ) rpc 0 >step-breakpoint @ = rpc 1 >step-breakpoint @ = or ; : ?restart-ok ( -- ) restartable? @ 0= abort" No program is active." ; : (step ( -- ) set-step-breakpoints ?restart-ok restart-step ; headers forth definitions chain: go-chain \ Put stuff to do before returning to a client in this chain. ; defer go-hook ' go-chain is go-hook \ : 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 ( -- ) go-hook ?restart-ok #steps off current-address-breakpointed? if following-jsrs? on (step else install-breakpoints restart then ; : +bp ( adr -- ) uninstall-breakpoints dup bp-address-valid? if set-breakpoint else ." Invalid breakpoint address " .x cr then ; : +bpx ( adr -- ) \ name ' over +bp ( adr acf ) swap find-breakpoint ( acf bp# | -1 ) dup 0< if ( acf -1 ) 2drop ( ) else ( acf bp# ) >breakpoint-action ! ( ) then ; : till ( adr -- ) +bp go ; : return ( -- ) return-adr till ; \ Finish and return from subroutine : returnl ( -- ) leaf-return-adr till ; \ Finish and ret. from leaf subr. : finish-loop ( -- ) loop-exit-adr till ; \ Finish the enclosing loop headerless alias continue go variable #gos headers : gos ( n -- ) 1- #gos ! go ; : .pc ( -- ) rpc u. ; defer .step defer .breakpoint headerless hidden definitions ' .instruction is .step ' .instruction is .breakpoint : breakpoint-message ( -- ) \ If the trap type is inconsistent with a breakpoint, then we \ just print the exception type and exit. breakpoint-trap? 0= if .exception quit then \ Exit to interpreter \ If we are doing multiple single-steps, then we decrement the \ step count and continue stepping until the count reaches 0. #steps @ if restartable? on .step -1 #steps +! #steps @ if (step then \ Exit to program quit \ Exit to interpreter then \ If we are at a single-step location, but the step count variable was 0, \ then it was a "hidden step". A "hidden step" happens when "go" is \ executed from a location where there is a breakpoint set. We had to \ step once to execute the breakpointed instruction, and then we replace \ the location with a breakpoint insruction and go. pc-at-step @ if restartable? on go then \ Exit to program \ If we are at a breakpoint location, then we consult the #gos variable \ to determine how many more times to go, and either go or "quit" to \ the interactive interpreter. pc-at-breakpoint @ if restartable? on rpc find-breakpoint >breakpoint-action @ ?dup if execute else .breakpoint then #gos @ if -1 #gos +! go then \ Exit to program quit \ Exit to interpreter then \ If we get here, a "breakpoint trap" occurred at a location where \ we don't think there should have been a breakpoint. This means \ that the location happens to contain an instruction that causes the \ same kind of trap that is used for breakpoints (whatever that is for \ the particular system). This could happen if a previous breakpoint \ didn't get cleaned up properly, or if memory got overwritten with \ breakpoint (or equivalent) instructions, or if the program jumped to \ an invalid location that happened to contain breakpoint (or equivalent) \ instructions. .exception quit \ Exit to interpreter ; headers : (handle-breakpoint ( -- ) current-address-stepped? pc-at-step ! current-address-breakpointed? pc-at-breakpoint ! repair-step-breakpoints repair-breakpoints breakpoint-message ; ' (handle-breakpoint is handle-breakpoint forth definitions : -bp ( adr -- ) uninstall-breakpoints remove-breakpoint ; \ Remove most-recently-set breakpoint : --bp ( -- ) #breakpoints @ if #breakpoints @ 1- repair-breakpoint -1 #breakpoints +! then ; : bpon ( -- ) uninstall-breakpoints install-breakpoints ; : .bp ( -- ) show-breakpoints ; : bpoff ( -- ) remove-all-breakpoints ; : skip ( -- ) bumppc go ; chain: init ( -- ) init-breakpoints ; init-breakpoints also keys-forth definitions : ^t step ; only forth also definitions