Author: wmb Date: Thu Mar 22 01:21:57 2012 New Revision: 2913 URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2913
Log: Debugger - improved the "up" command so it will skip past the method call machinery to find the caller that the user cares about.
Modified: forth/lib/debug.fth forth/lib/rstrace.fth ofw/core/ofwcore.fth
Modified: forth/lib/debug.fth ============================================================================== --- forth/lib/debug.fth Wed Mar 21 23:25:54 2012 (r2912) +++ forth/lib/debug.fth Thu Mar 22 01:21:57 2012 (r2913) @@ -75,26 +75,28 @@ ; bug definitions headerless -\ Go up the return stack until we find the return address left by our caller -: caller-ip ( rp -- ip ) - begin - na1+ dup @ dup in-dictionary? if ( rs-adr ip ) - ip>token token@ - dup ['] execute = over defer? or swap <ip @ body> = or - else - drop false - then - until ( rs-adr ) - @ ip>token -; +\ Go up the return stack until we find an interesting caller : up1 ( rp -- ) - caller-ip - dup find-cfa ( ip cfa ) - dup ['] catch = if 2drop exit then - cr ." [ Up to " dup .name ." ]" cr ( ip cfa ) - over token@ .name ( ip cfa ) - >body swap 'unnest (debug) + begin na1+ dup rp0 @ <> while ( rs-adr ) + dup @ ( rs-adr ip ) + dup in-dictionary? if ( rs-adr ip ) + find-cfa dup indirect-call? if ( rs-adr xt ) + drop ( rs-adr ) + else ( rs-adr xt ) + nip ( rs-adr ) + scrolling-debug? if ( xt ) + cr ." [ Up to " dup .name ." ]" cr + then ( xt ) + (debug ( ) + exit ( -- ) + then ( rs-adr ) + else ( rs-adr ip ) + drop ( rs-adr ) + then ( rs-adr ) + repeat ( rs-adr ) + drop ( ) ; + defer to-debug-window ' noop is to-debug-window defer restore-window ' noop is restore-window : .debug-short-help ( -- ) @@ -183,19 +185,12 @@ d# 78 rmargin ! .debug-short-help ." Callers: " rp0 @ the-rp na1+ rslist kill-line cr - \ XXX the following is wrong when popping up - the-ip <ip @ = if - #line @ is stack-line \ So the initial stack is displayed in the right place - then d# 40 rmargin ! the-ip debug-see cr - \ When popping up from an interior word, display the initial stack on - \ the line where the cursor will be. - the-ip <ip @ <> if - the-ip ip>position if ( col row ) - drop is stack-line ( ) - then + \ Display the initial stack on the cursor line + the-ip ip>position 0= if ( col row ) + is stack-line drop ( ) then ; : setup-debug-display ( -- )
Modified: forth/lib/rstrace.fth ============================================================================== --- forth/lib/rstrace.fth Wed Mar 21 23:25:54 2012 (r2912) +++ forth/lib/rstrace.fth Thu Mar 22 01:21:57 2012 (r2913) @@ -103,9 +103,9 @@ \ boring? is a hook for Open Firmware. It recognizes words like \ $call-method that are essentially indirect calls. Such words \ just clutter up the stack display and should be elided for clarity. -defer boring? -: (boring?) ( ip -- flag ) drop false ; -' (boring?) is boring? +defer indirect-call? +: (indirect-call?) ( xt -- flag ) ['] catch = ; +' (indirect-call?) is indirect-call?
: rtraceword ( rs-end rs-adr -- rs-end rs-adr' ) @+ ( rs-end rs-adr' ip ) @@ -120,7 +120,7 @@
find-cfa ( rs-end rs-adr xt )
- dup boring? if ( rs-end rs-adr xt ) + dup indirect-call? if ( rs-end rs-adr xt ) drop exit ( -- rs-end rs-adr ) then ( rs-end rs-adr xt )
Modified: ofw/core/ofwcore.fth ============================================================================== --- ofw/core/ofwcore.fth Wed Mar 21 23:25:54 2012 (r2912) +++ ofw/core/ofwcore.fth Thu Mar 22 01:21:57 2012 (r2913) @@ -4772,20 +4772,21 @@ [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 ) +: method-call? ( xt -- flag ) + dup (indirect-call?) if drop true exit then ( xt ) + dup ['] $call-self = if drop true exit then ( xt ) + dup ['] $call-method = if drop true exit then ( xt ) + dup ['] $call-parent = if drop true exit then ( xt ) + dup ['] call-package = if drop true exit then ( xt ) + dup ['] $vexecute = if drop true exit then ( xt ) + dup ['] $vexecute? = if drop true exit then ( xt ) + dup ['] $package-execute? = if drop true exit then ( xt ) + dup ['] package-execute = if drop true exit then ( xt ) + dup ['] apply-method = if drop true exit then ( xt ) + dup ['] (apply-method) = if drop true exit then ( xt ) + dup ['] (execute-method) = if drop true exit then ( xt ) + dup ['] execute-device-method = if drop true exit then ( xt ) drop false ; -' method-call? to boring? +' method-call? to indirect-call? previous