[openfirmware] [commit] r2913 - forth/lib ofw/core
repository service
svn at openfirmware.info
Thu Mar 22 01:21:57 CET 2012
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
More information about the openfirmware
mailing list