diff options
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/debug.fs')
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/debug.fs | 422 |
1 files changed, 422 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/debug.fs b/qemu/roms/SLOF/slof/fs/debug.fs new file mode 100644 index 000000000..e54f729fe --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/debug.fs @@ -0,0 +1,422 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 IBM Corporation +\ * All rights reserved. +\ * This program and the accompanying materials +\ * are made available under the terms of the BSD License +\ * which accompanies this distribution, and is available at +\ * http://www.opensource.org/licenses/bsd-license.php +\ * +\ * Contributors: +\ * IBM Corporation - initial implementation +\ ****************************************************************************/ + + +\ Get the name of Forth command whose execution token is xt + +: xt>name ( xt -- str len ) + BEGIN + cell - dup c@ 0 2 within IF + dup 2+ swap 1+ c@ exit + THEN + AGAIN +; + +cell -1 * CONSTANT -cell +: cell- ( n -- n-cell-size ) + [ cell -1 * ] LITERAL + +; + +\ Search for xt of given address +: find-xt-addr ( addr -- xt ) + BEGIN + dup @ <colon> = IF + EXIT + THEN + cell- + AGAIN +; + +: (.immediate) ( xt -- ) + \ is it immediate? + xt>name drop 2 - c@ \ skip len and flags + immediate? IF + ." IMMEDIATE" + THEN +; + +: (.xt) ( xt -- ) + xt>name type +; + +\ Trace back on current return stack. +\ Start at 1, since 0 is return of trace-back itself + +: trace-back ( ) + 1 + BEGIN + cr dup dup . ." : " rpick dup . ." : " + ['] tib here within IF + dup rpick find-xt-addr (.xt) + THEN + 1+ dup rdepth 5 - >= IF cr drop EXIT THEN + AGAIN +; + +VARIABLE see-my-type-column + +: (see-my-type) ( indent limit xt str len -- indent limit xt ) + dup see-my-type-column @ + dup 50 >= IF + -rot over " " comp 0= IF + \ blank causes overflow: just enforce new line with next call + 2drop see-my-type-column ! + ELSE + rot drop ( indent limit xt str len ) + \ Need to copy string since we use (u.) again (kills internal buffer): + pocket swap 2dup >r >r ( indent limit xt str pk len R: len pk ) + move r> r> ( indent limit xt pk len ) + 2 pick (u.) dup -rot + cr type ( indent limit xt pk len xt-len ) + " :" type 1+ ( indent limit xt pk len prefix-len ) + 5 pick dup spaces + ( indent limit xt pk len prefix-len ) + over + see-my-type-column ! ( indent limit xt pk len ) + type + THEN ( indent limit xt ) + ELSE + see-my-type-column ! type ( indent limit xt ) + THEN +; + +: (see-my-type-init) ( -- ) + ffff see-my-type-column ! \ just enforce a new line +; + +: (see-colon-body) ( indent limit xt -- indent limit xt ) + (see-my-type-init) \ enforce new line + BEGIN ( indent limit xt ) + cell+ 2dup <> + over @ + dup <semicolon> <> + rot and ( indent limit xt @xt flag ) + WHILE ( indent limit xt @xt ) + xt>name (see-my-type) " " (see-my-type) + dup @ ( indent limit xt @xt) + CASE + <0branch> OF cell+ dup @ + over + cell+ dup >r + (u.) (see-my-type) r> ( indent limit xt target) + 2dup < IF + over 4 pick 3 + -rot recurse + nip nip nip cell- ( indent limit xt ) + ELSE + drop ( indent limit xt ) + THEN + (see-my-type-init) ENDOF \ enforce new line + <branch> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <do?do> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <lit> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <dotick> OF cell+ dup @ xt>name (see-my-type) + " " (see-my-type) ENDOF + <doloop> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <do+loop> OF cell+ dup @ (u.) (see-my-type) + " " (see-my-type) ENDOF + <doleave> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <do?leave> OF cell+ dup @ over + cell+ (u.) + (see-my-type) " " (see-my-type) ENDOF + <sliteral> OF cell+ " """ (see-my-type) dup count dup >r + (see-my-type) " """ (see-my-type) + " " (see-my-type) + r> -cell and + ENDOF + ENDCASE + REPEAT + drop +; + +: (see-colon) ( xt -- ) + (see-my-type-init) + 1 swap 0 swap ( indent limit xt ) + " : " (see-my-type) dup xt>name (see-my-type) + rot drop 4 -rot (see-colon-body) ( indent limit xt ) + rot drop 1 -rot (see-my-type-init) " ;" (see-my-type) + 3drop +; + +\ Create words are a bit tricky. We find out where their code points. +\ If this code is part of SLOF, it is not a user generated CREATE. + +: (see-create) ( xt -- ) + dup cell+ @ + CASE + <2constant> OF + dup cell+ cell+ dup @ swap cell+ @ . . ." 2CONSTANT " + ENDOF + + <instancevalue> OF + dup cell+ cell+ @ . ." INSTANCE VALUE " + ENDOF + + <instancevariable> OF + ." INSTANCE VARIABLE " + ENDOF + + dup OF + ." CREATE " + ENDOF + ENDCASE + (.xt) +; + +\ Decompile Forth command whose execution token is xt + +: (see) ( xt -- ) + cr dup dup @ + CASE + <variable> OF ." VARIABLE " (.xt) ENDOF + <value> OF dup execute . ." VALUE " (.xt) ENDOF + <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF + <defer> OF dup cell+ @ swap ." DEFER " (.xt) ." is " (.xt) ENDOF + <alias> OF dup cell+ @ swap ." ALIAS " (.xt) ." " (.xt) ENDOF + <buffer:> OF ." BUFFER: " (.xt) ENDOF + <create> OF (see-create) ENDOF + <colon> OF (see-colon) ENDOF + dup OF ." ??? PRIM " (.xt) ENDOF + ENDCASE + (.immediate) cr + ; + +\ Decompile Forth command old-name + +: see ( "old-name<>" -- ) + ' (see) +; + +\ Work in progress... + +0 value forth-ip +true value trace>stepping? +true value trace>print? +true value trace>up? +0 value trace>depth +0 value trace>rdepth +0 value trace>recurse +: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ; +: trace-depth- ( -- ) trace>depth 1- to trace>depth ; + +: stepping ( -- ) + true to trace>stepping? +; + +: tracing ( -- ) + false to trace>stepping? +; + +: trace-print-on ( -- ) + true to trace>print? +; + +: trace-print-off ( -- ) + false to trace>print? +; + + +\ Add n to ip + +: fip-add ( n -- ) + forth-ip + to forth-ip +; + +\ Save execution token address and content + +0 value debug-last-xt +0 value debug-last-xt-content + +: trace-print ( -- ) + forth-ip cr u. ." : " + forth-ip @ + dup ['] breakpoint = IF drop debug-last-xt-content THEN + xt>name type ." " + ." ( " .s ." ) | " +; + +: trace-interpret ( -- ) + rdepth 1- to trace>rdepth + BEGIN + depth . [char] > dup emit emit space + source expect ( str len ) + ['] interpret catch print-status + AGAIN +; + +\ Main trace routine, trace a colon definition + +: trace-xt ( xt -- ) + trace>recurse IF + r> drop \ Drop return of 'trace-xt call + cell+ \ Step over ":" + ELSE + debug-last-xt-content <colon> = IF + \ debug colon-definition + ['] breakpoint @ debug-last-xt ! \ Re-arm break point + r> drop \ Drop return of 'trace-xt call + cell+ \ Step over ":" + ELSE + ['] breakpoint debug-last-xt ! \ Re-arm break point + 2r> 2drop + THEN + THEN + + to forth-ip + true to trace>print? + BEGIN + trace>print? IF trace-print THEN + + forth-ip ( ip ) + trace>stepping? IF + BEGIN + key + CASE + [char] d OF dup @ @ <colon> = IF \ recurse only into colon definitions + trace-depth+ + 1 to trace>recurse + dup >r @ recurse + THEN true ENDOF + [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF + [char] f OF drop cr trace-interpret ENDOF \ quit trace and start interpreter FIXME rstack + [char] c OF tracing true ENDOF + [char] t OF trace-back false ENDOF + [char] q OF drop cr quit ENDOF + 20 OF true ENDOF + dup OF cr ." Press d: Down into current word" cr + ." Press u: Up to caller" cr + ." Press f: Switch to forth interpreter, 'resume' will continue tracing" cr + ." Press c: Switch to tracing" cr + ." Press <space>: Execute current word" cr + ." Press q: Abort execution, switch to interpreter" cr + false ENDOF + ENDCASE + UNTIL + THEN ( ip' ) + dup to forth-ip @ ( xt ) + dup ['] breakpoint = IF drop debug-last-xt-content THEN + dup ( xt xt ) + + CASE + <sliteral> OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF + <dotick> OF drop forth-ip cell+ @ cell fip-add ENDOF + <lit> OF drop forth-ip cell+ @ cell fip-add ENDOF + <doto> OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF + <(doito)> OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF + <0branch> OF drop IF + cell fip-add + ELSE + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + <do?do> OF drop 2dup <> IF + swap >r >r cell fip-add + ELSE + forth-ip cell+ @ cell+ fip-add 2drop THEN + ENDOF + <branch> OF drop forth-ip cell+ @ cell+ fip-add ENDOF + <doleave> OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF + <do?leave> OF drop IF + r> r> 2drop forth-ip cell+ @ cell+ fip-add + ELSE + cell fip-add + THEN + ENDOF + <doloop> OF drop r> 1+ r> 2dup = IF + 2drop cell fip-add + ELSE >r >r + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + <do+loop> OF drop r> + r> 2dup >= IF + 2drop cell fip-add + ELSE >r >r + forth-ip cell+ @ cell+ fip-add THEN + ENDOF + + <semicolon> OF trace>depth 0> IF + trace-depth- 1 to trace>recurse + stepping drop r> recurse + ELSE + drop exit THEN + ENDOF + <exit> OF trace>depth 0> IF + trace-depth- stepping drop r> recurse + ELSE + drop exit THEN + ENDOF + dup OF execute ENDOF + ENDCASE + forth-ip cell+ to forth-ip + AGAIN +; + +\ Resume execution from tracer +: resume ( -- ) + trace>rdepth rdepth! + forth-ip cell - trace-xt +; + +\ Turn debug off, by erasing breakpoint + +: debug-off ( -- ) + debug-last-xt IF + debug-last-xt-content debug-last-xt ! \ Restore overwritten token + 0 to debug-last-xt + THEN +; + + + +\ Entry point for debug + +: (break-entry) ( -- ) + debug-last-xt dup @ ['] breakpoint <> swap ( debug-addr? debug-last-xt ) + debug-last-xt-content swap ! \ Restore overwritten token + r> drop \ Don't return to bp, but to caller + debug-last-xt-content <colon> <> and IF \ Execute non colon definition + debug-last-xt cr u. ." : " + debug-last-xt xt>name type ." " + ." ( " .s ." ) | " + key drop + debug-last-xt execute + ELSE + debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt \ Trace colon definition + THEN +; + +\ Put entry point bp defer +' (break-entry) to BP + +\ Mark an address for debugging + +: debug-address ( addr -- ) + debug-off ( xt ) \ Remove active breakpoint + dup to debug-last-xt ( xt ) \ Save token for later debug + dup @ to debug-last-xt-content ( xt ) \ Save old value + ['] breakpoint swap ! +; + +\ Mark the command indicated by xt for debugging + +: (debug ( xt -- ) + debug-off ( xt ) \ Remove active breakpoint + dup to debug-last-xt ( xt ) \ Save token for later debug + dup @ to debug-last-xt-content ( xt ) \ Save old value + ['] breakpoint @ swap ! +; + +\ Mark the command indicated by xt for debugging + +: debug ( "old-name<>" -- ) + parse-word $find IF \ Get xt for old-name + (debug + ELSE + ." undefined word " type cr + THEN +; |