[openfirmware] [commit] r2901 - cpu/arm forth/lib
repository service
svn at openfirmware.info
Tue Mar 20 10:37:24 CET 2012
Author: wmb
Date: Tue Mar 20 10:37:24 2012
New Revision: 2901
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2901
Log:
Debugger - 2D display of debugged word instead of scrolling. Not perfect yet, but pretty good. Revert to old behavior with "true to scrolling-debug?"
Modified:
cpu/arm/kerncode.fth
forth/lib/debug.fth
forth/lib/decomp.fth
forth/lib/objects.fth
Modified: cpu/arm/kerncode.fth
==============================================================================
--- cpu/arm/kerncode.fth Mon Mar 19 22:52:46 2012 (r2900)
+++ cpu/arm/kerncode.fth Tue Mar 20 10:37:24 2012 (r2901)
@@ -235,7 +235,7 @@
\rel ldrvc r0,[ip]
\rel addvc ip,ip,r0
\abs ldrvc ip,[ip]
- ldrvc pc,[ip],1cell
+ nxtvc
inc rp,3cells
inc ip,1cell
c;
@@ -248,7 +248,7 @@
\rel ldrvc r0,[ip]
\rel addvc ip,ip,r0
\abs ldrvc ip,[ip]
- ldrvc pc,[ip],1cell
+ nxtvc
inc rp,3cells
inc ip,1cell
c;
@@ -270,7 +270,7 @@
\rel ldreq r0,[ip]
\rel addeq ip,ip,r0
\abs ldreq ip,[ip]
- ldreq pc,[ip],1cell
+ nxteq
( r: loop-end-offset l+0x8000 i-l-0x8000 )
psh ip,rp \ save the do offset address
inc ip,1cell
@@ -312,7 +312,7 @@
code (?leave) ( f -- )
cmp tos,#0
pop tos,sp
- ldreq pc,[ip],1cell
+ nxteq
inc rp,2cells \ get rid of the loop indices
ldr ip,[rp],1cell
\rel ldr r0,[ip] \ branch
@@ -665,7 +665,7 @@
\ ldmia sp!,{r0,r2}
\ mov tos,#0
\ cmp r2,r0
-\ ldrlt pc,[ip],1cell
+\ nxtlt
\ cmp r2,r1
\ mvnle tos,#0
\ c;
@@ -936,6 +936,15 @@
-rot >>a or ( low2 r: high2 )
r> ( d2 )
;
+: du* ( d1 u -- d2 ) \ Double result
+ tuck u* >r ( d1.lo u r: d2.hi )
+ um* r> + ( d2 )
+;
+: du*t ( ud.lo ud.hi u -- res.lo res.mid res.hi ) \ Triple result
+ tuck um* 2>r ( ud.lo u r: res.mid0 res.hi0 )
+ um* ( res.lo res.mid1 r: res.mid0 res.hi0 )
+ 0 2r> d+ ( res.lo res.mid res.hi )
+;
code fill ( adr cnt char -- )
orr r2,tos,tos,lsl #8
Modified: forth/lib/debug.fth
==============================================================================
--- forth/lib/debug.fth Mon Mar 19 22:52:46 2012 (r2900)
+++ forth/lib/debug.fth Tue Mar 20 10:37:24 2012 (r2901)
@@ -26,6 +26,8 @@
only forth also definitions
+false value scrolling-debug?
+
hex
headerless
variable slow-next? slow-next? off
@@ -35,6 +37,7 @@
variable step? step? on
variable res
headers
+false value first-time?
: (debug) (s low-adr hi-adr -- )
unbug 1 cnt ! ip> ! <ip ! pnext
slow-next? @ 0= if
@@ -42,6 +45,7 @@
slow-next? on
then
step? on
+ true is first-time?
;
headerless
: 'unnest (s pfa -- pfa' )
@@ -51,7 +55,6 @@
<ip ! <ip @ ip> @ u>= if <ip @ 'unnest ip> ! then
;
-false value first-time?
headers
\ Enter and leave the debugger
forth definitions
@@ -60,7 +63,7 @@
begin dup defer? while behavior repeat
dup colon-cf? 0= abort" Not a colon definition"
- >body dup 'unnest (debug) true is first-time?
+ >body dup 'unnest (debug)
;
\ Debug the caller
: debug-me (s -- ) ip@ find-cfa (debug ;
@@ -113,9 +116,21 @@
." Q Quit: abandon execution of the debugged word" cr
;
d# 24 constant cmd-column
-0 value rp-mark
: to-cmd-column ( -- ) cmd-column to-column ;
+0 value stack-line
+d# 50 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 ;
+\ : 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 ;
+: to-result-loc ( -- ) result-col result-line at-xy ;
+
+0 value rp-mark
+
\ set-package is a hook for Open Firmware. When Open Firmware is loaded,
\ set-package should be set to a word that sets the active package to the
\ package corresponding to the current instance. set-package is called
@@ -150,9 +165,15 @@
;
: (trace ( -- )
first-time? if
- ??cr
- ip@ <ip @ = if ." : " else ." Inside " then
- <ip @ find-cfa .name
+ scrolling-debug? if
+ ??cr
+ ip@ <ip @ = if ." : " else ." Inside " then
+ <ip @ find-cfa .name
+ else
+ ip@ debug-see
+ 0 is stack-line \ So the initial stack is displayed in the right place
+ cr
+ then
0 show-rstack !
false is first-time?
rp@ is rp-mark
@@ -160,24 +181,37 @@
begin
step? @ if to-debug-window then
save#
- cmd-column 2+ to-column
+ 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
- ." )" cr
+ ." )"
restore#
- ['] noop is indent
- ip@ .token drop \ Show word name
- ['] (indent) is indent
- to-cmd-column
+ scrolling-debug? if
+ cr
+ ['] noop is indent
+ ip@ .token drop \ Show word name
+ ['] (indent) is indent
+ to-cmd-column
+ else
+ ip@ ip-set-cursor
+ #line @ to stack-line
+ then
step? @ key? or if
step? on res off
- key dup bl < if drop bl then dup emit upc
+ key dup bl < if drop bl then
+ scrolling-debug? if dup emit else to-result-loc then upc
restore-window
- reset-page
+ scrolling-debug? if reset-page then
case
ascii D of ip@ token@ executer ['] (debug try endof \ Down
ascii U of rp@ ['] up1 try endof \ Up
@@ -206,6 +240,7 @@
then
until
restore#
+ scrolling-debug? 0= if to-result-loc then
ip@ token@ dup ['] unnest = swap ['] exit = or if
cr true is first-time?
then
Modified: forth/lib/decomp.fth
==============================================================================
--- forth/lib/decomp.fth Mon Mar 19 22:52:46 2012 (r2900)
+++ forth/lib/decomp.fth Tue Mar 20 10:37:24 2012 (r2901)
@@ -54,9 +54,50 @@
defer (see)
hidden definitions
+d# 200 2* /n* constant /positions
+/positions buffer: positions
+0 value end-positions
+\ 0 value line-after-;
+
+: init-positions ( -- ) positions is end-positions ;
+: find-position ( ip -- true | adr false )
+ end-positions positions ?do ( ip )
+ i 2@ nip ( ip that-ip )
+ over = if ( ip )
+ drop i false ( adr false )
+ unloop exit ( adr false -- )
+ then ( ip )
+ 2 /n* +loop ( ip )
+ drop true ( true )
+;
+0 value the-ip
+: add-position ( ip -- )
+ the-ip find-position if ( )
+ end-positions positions /positions + >= ( flag )
+ abort" Decompiler position table overflow" ( )
+ end-positions dup 2 na+ is end-positions ( adr )
+ then ( adr )
+ #out @ #line @ wljoin the-ip rot 2! ( )
+;
+: ip>position ( ip -- true | #out #line false )
+ find-position if ( )
+ true ( true )
+ else ( adr )
+ 2@ drop lwsplit ( #out #line )
+ false ( #out #line false )
+ then ( true | #out #line false )
+;
+: ip-set-cursor ( ip -- )
+ ip>position 0= if at-xy then
+;
+
headerless
\ Like ." but goes to a new line if needed.
-: cr". ( adr len -- ) dup ?line magenta-letters type cancel ;
+: cr". ( adr len -- )
+ dup ?line ( adr len )
+ add-position ( adr len )
+ magenta-letters type cancel ( )
+;
: .." ( -- ) [compile] " compile cr". ; immediate
\ Positional case defining word
@@ -103,13 +144,14 @@
defer disassemble ' nulldis is disassemble
headerless
+
\ Breaks is a list of places in a colon definition where control
\ is transferred without there being a branch nearby.
\ Each entry has two items: the address and a number which indicates
\ what kind of branch target it is (either a begin, for backward branches,
\ a then, for forward branches, or an exit.
-80 /n* constant /breaks
+d# 40 2* /n* constant /breaks
/breaks buffer: breaks
variable end-breaks
@@ -185,7 +227,7 @@
: add-break ( break-address break-type -- )
end-breaks @ breaks /breaks + >= ( adr,type full? )
- abort" Decompiler internal table overlow" ( adr,type )
+ abort" Decompiler table overflow" ( adr,type )
end-breaks @ breaks > if ( adr,type )
over end-breaks @ /n 2* - >r r@ 2@ ( adr,type adr prev-adr,type )
['] .endof = -rot = and if ( adr,type )
@@ -280,7 +322,7 @@
dup immediate? if .." [compile] " then
;
-: put" (s -- ) ascii " emit space ;
+: put" (s -- ) ascii " emit space ;
: cword-name (s ip -- ip' $ name$ )
dup token@ ( ip acf )
@@ -294,24 +336,41 @@
2 pick over + 3 + ?line ( $ name$ ) \ Keep word and string on the same line
cr". space ( $ )
red-letters type ( )
- .." "" " ( )
+ magenta-letters ( )
+ ." "" " ( )
+ cancel ( )
+;
+
+: pretty-. ( n -- )
+ base @ d# 10 = if (.) else (u.) then ( adr len )
+ dup ?line add-position
+ green-letters type cancel space
+;
+
+: .compiled ( ip -- ip' )
+ dup token@ check-[compile] ( ip xt )
+ >name name>string ( ip adr len )
+ type space ( ip )
+ ta1+ ( ip' )
+;
+: .word ( ip -- ip' )
+ dup token@ check-[compile] ( ip xt )
+ >name name>string ( ip adr len )
+ dup ?line add-position ( ip adr len )
+ type space ( ip )
+ ta1+ ( ip' )
;
-
-: pretty-n. ( n -- ) green-letters n. cancel ;
-: pretty-. ( n -- ) green-letters . cancel ;
-
-: .word ( ip -- ip' ) dup token@ check-[compile] ?cr .name ta1+ ;
: skip-word ( ip -- ip' ) ta1+ ;
-: .inline ( ip -- ip' ) ta1+ dup unaligned-@ pretty-n. na1+ ;
+: .inline ( ip -- ip' ) ta1+ dup unaligned-@ pretty-. na1+ ;
: skip-inline ( ip -- ip' ) ta1+ na1+ ;
: .wlit ( ip -- ip' ) ta1+ dup unaligned-w@ 1- pretty-. wa1+ ;
: skip-wlit ( ip -- ip' ) ta1+ wa1+ ;
: .llit ( ip -- ip' ) ta1+ dup unaligned-l@ 1- pretty-. la1+ ;
: skip-llit ( ip -- ip' ) ta1+ la1+ ;
-: .dlit ( ip -- ip' ) ta1+ dup d@ (d.) green-letters type ." . " cancel 2 na+ ;
+: .dlit ( ip -- ip' ) ta1+ dup d@ (d.) add-position green-letters type ." . " cancel 2 na+ ;
: skip-dlit ( ip -- ip' ) ta1+ 2 na+ ;
: skip-branch ( ip -- ip' ) +branch ;
-: .compile ( ip -- ip' ) .." compile " ta1+ .word ;
+: .compile ( ip -- ip' ) .." compile " ta1+ .compiled ;
: skip-compile ( ip -- ip' ) ta1+ ta1+ ;
: skip-string ( ip -- ip' ) ta1+ +str ;
: skip-nstring ( ip -- ip' ) ta1+ +nstr ;
@@ -436,8 +495,10 @@
: .token ( ip -- ip' ) dup token@ execution-class .execution-class ;
\ Decompile the parameter field of colon definition
: .pf ( apf -- )
+ init-positions ( apf )
dup scan-pf next-break 3 lmargin ! indent ( apf )
begin ( adr )
+ dup is the-ip ( adr )
?cr break-addr @ over = if ( adr )
begin ( adr )
break-type @ execute ( adr )
@@ -460,23 +521,28 @@
: dump-body ( pfa -- )
push-hex
- dup @ pretty-n. 2 spaces 8 emit.ln
+ dup @ pretty-. 2 spaces 8 emit.ln
pop-base
;
\ Display category of word
: .: ( acf definer -- ) .definer space space >body .pf ;
-: .constant ( acf definer -- ) over >data @ pretty-n. .definer drop ;
-: .2constant ( acf definer -- ) over >data dup @ pretty-n. na1+ @ pretty-n. .definer drop ;
+: debug-see ( apf -- )
+ page-mode? >r no-page
+ d# 48 rmargin ! find-cfa ['] : page .:
+ r> is page-mode?
+;
+: .constant ( acf definer -- ) over >data @ pretty-. .definer drop ;
+: .2constant ( acf definer -- ) over >data dup @ pretty-. na1+ @ pretty-. .definer drop ;
: .vocabulary ( acf definer -- ) .definer drop ;
: .code ( acf definer -- ) .definer >code disassemble ;
: .variable ( acf definer -- )
- over >data n. .definer ." value = " >data @ pretty-n.
+ over >data n. .definer ." value = " >data @ pretty-.
;
: .create ( acf definer -- )
over >body n. .definer ." value = " >body dump-body
;
: .user ( acf definer -- )
- over >body @ n. .definer ." value = " >data @ pretty-n.
+ over >body @ n. .definer ." value = " >data @ pretty-.
;
: .defer ( acf definer -- )
.definer ." is " cr >data token@ (see)
@@ -485,7 +551,7 @@
.definer >body token@ .name
;
: .value ( acf definer -- )
- swap >data @ pretty-n. .definer
+ swap >data @ pretty-. .definer
;
@@ -560,7 +626,7 @@
\ top level of the decompiler SEE
: ((see ( acf -- )
- td 64 rmargin !
+ d# 48 rmargin !
dup dup definer dup definition-class .definition-class
.immediate
??cr
Modified: forth/lib/objects.fth
==============================================================================
--- forth/lib/objects.fth Mon Mar 19 22:52:46 2012 (r2900)
+++ forth/lib/objects.fth Tue Mar 20 10:37:24 2012 (r2901)
@@ -138,8 +138,12 @@
\ if it happens to be near the end of a line.
[ifdef] install-decomp
-: .action ( ip -- ip' ) dup token@ .name ta1+ dup token@ .name ta1+ ;
also hidden also
+: .action ( ip -- ip' )
+ d# 15 ?line \ Just a guess
+ dup token@ >name name>string cr". space ta1+
+ .compiled
+;
' to ' .action ' skip-(') install-decomp
' addr ' .action ' skip-(') install-decomp
previous previous
More information about the openfirmware
mailing list