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