[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