Author: wmb Date: Wed Mar 21 00:56:47 2012 New Revision: 2904 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2904
Log: Improvements to the 2D debugger.
Modified: cpu/x86/kerncode.fth forth/lib/debug.fth forth/lib/decomp.fth forth/lib/rstrace.fth ofw/core/ofwcore.fth
Modified: cpu/x86/kerncode.fth ============================================================================== --- cpu/x86/kerncode.fth Tue Mar 20 23:37:14 2012 (r2903) +++ cpu/x86/kerncode.fth Wed Mar 21 00:56:47 2012 (r2904) @@ -299,13 +299,7 @@ \ Run time word for ?do code (?do) (s l i -- ) ax pop bx pop ax bx cmp = if bran1 #) jmp then -[ifdef] big-endian-t - bx push ax push - ip dx mov 0 [ip] ax mov ?bswap-ax ax dx add rp adec dx 0 [rp] mov - ax pop bx pop \ i in ax l in bx -[else] - ip dx mov 0 [ip] dx add rp adec dx 0 [rp] mov -[then] + rp adec ip 0 [rp] mov ip ainc 80000000 # bx add rp adec bx 0 [rp] mov bx ax sub rp adec ax 0 [rp] mov \ ??? how about sp rp xchg ... dx push bx push ax push sp rp xchg @@ -313,17 +307,9 @@
\ Run time word for do code (do) (s l i -- ) -[ifdef] big-endian-t ax pop bx pop \ i in ax l in bx + rp adec ip 0 [rp] mov
- bx push ax push - ip dx mov 0 [ip] ax mov ?bswap-ax ax dx add rp adec dx 0 [rp] mov - ax pop bx pop \ i in ax l in bx -[else] - ax pop bx pop \ i in ax l in bx - - ip dx mov 0 [ip] dx add rp adec dx 0 [rp] mov -[then] ip ainc 80000000 # bx add rp adec bx 0 [rp] mov bx ax sub rp adec ax 0 [rp] mov \ ??? how about sp rp xchg ... dx push bx push ax push sp rp xchg @@ -344,7 +330,13 @@
code (leave) (s -- ) mloclabel pleave - 2 /n* [rp] ip mov 3 /n* # rp add + 2 /n* [rp] ip mov +[ifdef] big-endian-t + 0 [ip] ax mov ?bswap-ax ax ip add +[else] + 0 [ip] ip add +[then] + 3 /n* # rp add c;
code (?leave) (s f -- ) ax pop ax ax or pleave jne c;
Modified: forth/lib/debug.fth ============================================================================== --- forth/lib/debug.fth Tue Mar 20 23:37:14 2012 (r2903) +++ forth/lib/debug.fth Wed Mar 21 00:56:47 2012 (r2904) @@ -38,6 +38,8 @@ variable res headers false value first-time? +d# 10 circular-stack: locations + : (debug) (s low-adr hi-adr -- ) unbug 1 cnt ! ip> ! <ip ! pnext slow-next? @ 0= if @@ -119,11 +121,21 @@ : to-cmd-column ( -- ) cmd-column to-column ;
0 value stack-line -d# 50 constant stack-column +d# 45 constant stack-column \ 0 0 2value result-loc 0 value result-line 0 value result-col : to-stack-location ( -- ) stack-column stack-line at-xy kill-line ; +: show-partial-stack ( -- ) + to-stack-location + + ." \ " + depth 0< if ." Stack Underflow" sp0 @ sp! exit then + depth 0= if ." Empty" exit then + depth 4 > if ." .. " then + depth depth 5 - 0 max ?do depth i - 1- pick n. loop +; + \ : save-result-loc ( -- ) #out @ #line @ to result-loc ; \ : to-result-loc ( -- ) result-loc at-xy ; : save-result-loc ( -- ) #out @ to result-col #line @ to result-line ; @@ -170,38 +182,51 @@ ip@ <ip @ = if ." : " else ." Inside " then <ip @ find-cfa .name else + page + d# 78 rmargin ! + ." Callers: " rp0 @ rp@ na1+ rslist kill-line cr + \ XXX the following is wrong when popping up + ip@ <ip @ = if + #line @ is stack-line \ So the initial stack is displayed in the right place + then + d# 40 rmargin ! ip@ debug-see - 0 is stack-line \ So the initial stack is displayed in the right place cr +\ ip@ <ip @ <> if +\ ip@ ip>position if ( col row ) +\ swap +\ is stack-line +\ then +\ #line @ is stack-line \ So the initial stack is displayed in the right place + \ then then 0 show-rstack ! false is first-time? rp@ is rp-mark then + begin step? @ if to-debug-window then save# scrolling-debug? if cmd-column 2+ to-column - else - save-result-loc - to-stack-location - then
- hex-stack @ if push-hex then - ." ( " .s \ Show data stack - hex-stack @ if pop-base then - show-rstack @ if (.rs then \ Show return stack - ." )" - restore# + hex-stack @ if push-hex then + ." ( " .s \ Show data stack + hex-stack @ if pop-base then + show-rstack @ if (.rs then \ Show return stack + ." )" + restore#
- scrolling-debug? if cr ['] noop is indent ip@ .token drop \ Show word name ['] (indent) is indent to-cmd-column else + save-result-loc + show-partial-stack + ip@ ip-set-cursor #line @ to stack-line then @@ -233,6 +258,8 @@ ascii * of ip@ find-cfa dup <ip ! 'unnest ip> ! false endof ascii \ of show-rstack @ 0= show-rstack ! false endof ascii X of hex-stack @ 0= hex-stack ! false endof + ascii V of scrolling-debug? 0= to scrolling-debug? + scrolling-debug? 0= if true to first-time? then false endof ( default ) true swap endcase else
Modified: forth/lib/decomp.fth ============================================================================== --- forth/lib/decomp.fth Tue Mar 20 23:37:14 2012 (r2903) +++ forth/lib/decomp.fth Wed Mar 21 00:56:47 2012 (r2904) @@ -528,7 +528,7 @@ : .: ( acf definer -- ) .definer space space >body .pf ; : debug-see ( apf -- ) page-mode? >r no-page - d# 48 rmargin ! find-cfa ['] : page .: + find-cfa ['] : .: r> is page-mode? ; : .constant ( acf definer -- ) over >data @ pretty-. .definer drop ;
Modified: forth/lib/rstrace.fth ============================================================================== --- forth/lib/rstrace.fth Tue Mar 20 23:37:14 2012 (r2903) +++ forth/lib/rstrace.fth Wed Mar 21 00:56:47 2012 (r2904) @@ -28,16 +28,20 @@ over na1+ @ reasonable-ip? if ( rs-adr n ) \ The third entry is a reasonable IP so it could be a do loop frame \ Make sure it points just past a loop end - over na1+ @ ( rs-adr n n2 ) - ip>token -1 na+ token@ ( rs-adr n xt ) - dup ['] (loop) = swap ['] (+loop) = or if ( rs-adr n ) - \ The two numbers span the +- boundary, so probably a do loop - ." Do loop frame inside " - over na1+ @ ip>token .current-word ( rs-adr n ) - over @ ( rs-adr n n1 ) - ." i: " tuck + . ( rs-adr n1 ) - ." limit: " minus0 + . ( rs-adr ) - 2 na+ exit + over na1+ @ dup @ + ( rs-adr n n2 ) + dup reasonable-ip? if ( rs-adr n adr ) + ip>token -1 na+ token@ ( rs-adr n xt ) + dup ['] (loop) = swap ['] (+loop) = or if ( rs-adr n ) + \ The two numbers span the +- boundary, so probably a do loop + ." Do loop frame inside " + over na1+ @ ip>token .current-word ( rs-adr n ) + over @ ( rs-adr n n1 ) + ." i: " tuck + . ( rs-adr n1 ) + ." limit: " minus0 + . ( rs-adr ) + 2 na+ exit + then ( rs-adr n ) + else ( rs-adr n n2 ) + drop ( rs-adr n ) then ( rs-adr n ) then ( rs-adr n ) then ( rs-adr n ) @@ -73,6 +77,67 @@ repeat ( end-adr adr ) 2drop ; +: skip-catch ( rs-adr -- rs-adr' ) 3 na+ ; +: skip-do-or-n ( rs-adr n -- rs-adr' ) + over @ reasonable-ip? 0= if ( rs-adr n ) + \ The second number is not an IP so it could be a do loop frame + over na1+ @ reasonable-ip? if ( rs-adr n ) + \ The third entry is a reasonable IP so it could be a do loop frame + \ Make sure it points to an offset that points just past a loop end + over na1+ @ dup @ + ( rs-adr n n2 ) + dup reasonable-ip? if ( rs-adr n adr ) + ip>token -1 na+ token@ ( rs-adr n xt ) + dup ['] (loop) = swap ['] (+loop) = or if ( rs-adr n ) + \ The two numbers span the +- boundary, so probably a do loop + drop ( rs-adr ) + 2 na+ exit ( -- rs-adr ) + then ( rs-adr n ) + else ( rs-adr n n2 ) + drop ( rs-adr n ) + then ( rs-adr n ) + then ( rs-adr n ) + then ( rs-adr n ) + drop ( rs-adr ) +; +defer boring? +: (boring?) ( ip -- flag ) drop false ; +: rtraceword ( rs-end rs-adr -- rs-end rs-adr' ) + @+ ( rs-end rs-adr' ip ) + dup reasonable-ip? 0= if ( rs-end rs-adr ip ) + skip-do-or-n exit ( -- rs-end rs-adr ) + then ( rs-end rs-adr ) + + dup in-catch? if ( rs-end rs-adr ip ) + drop skip-catch ( rs-end rs-adr' ) + exit ( -- rs-end rs-adr' ) + then ( rs-end rs-adr ip ) + + find-cfa ( rs-end rs-adr xt ) + + dup boring? if ( rs-end rs-adr xt ) + drop exit ( -- rs-end rs-adr ) + then ( rs-end rs-adr xt ) + + dup ['] interpret-do-defined = if ( rs-end rs-adr xt ) + \ Set rs-adr = rs-end so the caller will exit + 2drop dup exit ( -- rs-end rs-adr' ) + then ( rs-end rs-adr xt ) + + >name name>string ( rs-end rs-adr adr len ) + dup #out @ + rmargin @ >= if ( rs-end rs-adr adr len ) + \ Set rs-adr = rs-end so the caller will exit + 2drop ." ..." ( rs-end rs-adr ) + drop dup exit ( -- rs-end rs-adr' ) + then ( rs-end rs-adr adr len ) + + type space ( rs-end rs-adr ) +; +: rslist ( end-adr start-adr -- ) + begin 2dup u> while ( end-adr adr ) + rtraceword ( end-adr adr' ) + repeat ( end-adr adr ) + 2drop +; headers forth definitions : rstrace ( -- ) \ Return stack backtrace
Modified: ofw/core/ofwcore.fth ============================================================================== --- ofw/core/ofwcore.fth Tue Mar 20 23:37:14 2012 (r2903) +++ ofw/core/ofwcore.fth Wed Mar 21 00:56:47 2012 (r2904) @@ -4770,3 +4770,22 @@ [ifdef] do-autoload ' do-drop-in is do-autoload [then] + +also hidden +: method-call? ( ip -- flag ) + dup ['] $call-self = if drop true exit then ( ip ) + dup ['] $call-method = if drop true exit then ( ip ) + dup ['] $call-parent = if drop true exit then ( ip ) + dup ['] call-package = if drop true exit then ( ip ) + dup ['] $vexecute = if drop true exit then ( ip ) + dup ['] $vexecute? = if drop true exit then ( ip ) + dup ['] $package-execute? = if drop true exit then ( ip ) + dup ['] package-execute = if drop true exit then ( ip ) + dup ['] apply-method = if drop true exit then ( ip ) + dup ['] (apply-method) = if drop true exit then ( ip ) + dup ['] (execute-method) = if drop true exit then ( ip ) + dup ['] execute-device-method = if drop true exit then ( ip ) + drop false +; +' method-call? to boring? +previous