[openfirmware] [commit] r2904 - cpu/x86 forth/lib ofw/core

repository service svn at openfirmware.info
Wed Mar 21 00:56:48 CET 2012


Author: wmb
Date: Wed Mar 21 00:56:47 2012
New Revision: 2904
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2904

Log:
Improvements to the 2D debugger.

Modified:
   cpu/x86/kerncode.fth
   forth/lib/debug.fth
   forth/lib/decomp.fth
   forth/lib/rstrace.fth
   ofw/core/ofwcore.fth

Modified: cpu/x86/kerncode.fth
==============================================================================
--- cpu/x86/kerncode.fth	Tue Mar 20 23:37:14 2012	(r2903)
+++ cpu/x86/kerncode.fth	Wed Mar 21 00:56:47 2012	(r2904)
@@ -299,13 +299,7 @@
 \ Run time word for ?do
 code (?do)  (s l i -- )
    ax pop   bx pop   ax bx cmp  = if  bran1 #) jmp  then
-[ifdef] big-endian-t
-   bx push  ax push
-   ip dx mov    0 [ip] ax mov  ?bswap-ax  ax dx add   rp adec   dx 0 [rp] mov
-   ax pop   bx pop      \ i in ax  l in bx
-[else]
-   ip dx mov    0 [ip] dx add   rp adec   dx 0 [rp] mov
-[then]
+   rp adec   ip 0 [rp] mov
    ip ainc  80000000 # bx add   rp adec   bx 0 [rp] mov
    bx ax sub                    rp adec   ax 0 [rp] mov
 \ ??? how about sp rp xchg  ... dx push bx push ax push  sp rp xchg
@@ -313,17 +307,9 @@
 
 \ Run time word for do
 code (do)  (s l i -- )
-[ifdef] big-endian-t
    ax pop   bx pop      \ i in ax  l in bx
+   rp adec   ip 0 [rp] mov
 
-   bx push  ax push
-   ip dx mov    0 [ip] ax mov  ?bswap-ax  ax dx add   rp adec   dx 0 [rp] mov
-   ax pop   bx pop      \ i in ax  l in bx
-[else]
-   ax pop   bx pop      \ i in ax  l in bx
-   
-   ip dx mov    0 [ip] dx add   rp adec   dx 0 [rp] mov
-[then]
    ip ainc  80000000 # bx add   rp adec   bx 0 [rp] mov
    bx ax sub                    rp adec   ax 0 [rp] mov
 \ ??? how about sp rp xchg  ... dx push bx push ax push  sp rp xchg
@@ -344,7 +330,13 @@
 
 code (leave)  (s -- )
 mloclabel pleave
-   2 /n* [rp] ip mov   3 /n* # rp add
+   2 /n* [rp] ip mov
+[ifdef] big-endian-t
+   0 [ip] ax mov  ?bswap-ax  ax ip add   
+[else]
+   0 [ip] ip add  
+[then]
+   3 /n* # rp add
 c;
 
 code (?leave)  (s f -- )   ax pop   ax ax or   pleave jne   c;

Modified: forth/lib/debug.fth
==============================================================================
--- forth/lib/debug.fth	Tue Mar 20 23:37:14 2012	(r2903)
+++ forth/lib/debug.fth	Wed Mar 21 00:56:47 2012	(r2904)
@@ -38,6 +38,8 @@
 variable res
 headers
 false value first-time?
+d# 10 circular-stack: locations
+
 : (debug)       (s low-adr hi-adr -- )
    unbug   1 cnt !   ip> !   <ip !   pnext
    slow-next? @ 0=  if
@@ -119,11 +121,21 @@
 : to-cmd-column  ( -- )  cmd-column to-column  ;
 
 0 value stack-line
-d# 50 constant stack-column
+d# 45 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  ;
+: show-partial-stack  ( -- )
+   to-stack-location
+
+   ." \ "
+   depth 0<  if  ." Stack Underflow" sp0 @ sp!  exit  then
+   depth 0=  if  ." Empty"  exit  then
+   depth 4 >  if  ." .. "  then
+   depth  depth 5 - 0 max  ?do  depth i - 1- pick n.  loop
+;
+
 \ : 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  ;
@@ -170,38 +182,51 @@
          ip@  <ip @ =  if  ." : "  else  ." Inside "  then
          <ip @ find-cfa .name
       else
+         page
+         d# 78 rmargin !
+         ." Callers: "  rp0 @ rp@ na1+ rslist kill-line cr
+         \ XXX the following is wrong when popping up
+         ip@  <ip @ =  if  
+            #line @ is stack-line \ So the initial stack is displayed in the right place
+         then
+         d# 40 rmargin !
          ip@ debug-see
-         0 is stack-line \ So the initial stack is displayed in the right place
          cr
+\         ip@  <ip @ <>  if  
+\            ip@ ip>position  if   ( col row )
+\               swap 
+\               is stack-line
+\            then
+\            #line @ is stack-line \ So the initial stack is displayed in the right place
+ \        then
       then
       0 show-rstack !
       false is first-time?
       rp@ is rp-mark
    then
+
    begin
       step? @  if  to-debug-window  then
       save#
       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
-      ." )"
-      restore#
+         hex-stack @  if  push-hex  then
+         ." ( " .s    \ Show data stack
+         hex-stack @  if  pop-base  then
+         show-rstack @  if  (.rs  then   \ Show return stack
+         ." )"
+         restore#
 
-      scrolling-debug?  if
          cr
          ['] noop is indent
          ip@ .token drop		  \ Show word name
          ['] (indent) is indent
          to-cmd-column
       else
+         save-result-loc
+         show-partial-stack
+        
          ip@ ip-set-cursor
          #line @ to stack-line
       then
@@ -233,6 +258,8 @@
             ascii *  of  ip@ find-cfa dup <ip !  'unnest ip> !  false  endof
             ascii \  of  show-rstack @ 0= show-rstack ! false endof
             ascii X  of  hex-stack @ 0= hex-stack !   false  endof
+            ascii V  of  scrolling-debug? 0= to scrolling-debug?
+                         scrolling-debug? 0=  if  true to first-time?  then  false  endof
             ( default )  true swap
          endcase
       else

Modified: forth/lib/decomp.fth
==============================================================================
--- forth/lib/decomp.fth	Tue Mar 20 23:37:14 2012	(r2903)
+++ forth/lib/decomp.fth	Wed Mar 21 00:56:47 2012	(r2904)
@@ -528,7 +528,7 @@
 : .:           ( acf definer -- )  .definer space space  >body  .pf   ;
 : debug-see    ( apf -- )
    page-mode? >r  no-page
-   d# 48 rmargin !  find-cfa ['] :  page  .:
+   find-cfa ['] :  .:
    r> is page-mode?
 ;
 : .constant    ( acf definer -- )  over >data @ pretty-.  .definer drop  ;

Modified: forth/lib/rstrace.fth
==============================================================================
--- forth/lib/rstrace.fth	Tue Mar 20 23:37:14 2012	(r2903)
+++ forth/lib/rstrace.fth	Wed Mar 21 00:56:47 2012	(r2904)
@@ -28,16 +28,20 @@
       over na1+ @  reasonable-ip?  if         ( rs-adr n )
          \ The third entry is a reasonable IP so it could be a do loop frame
          \ Make sure it points just past a loop end
-         over na1+ @                          ( rs-adr n n2 )
-         ip>token  -1 na+  token@             ( rs-adr n xt )
-         dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n )
-            \ The two numbers span the +- boundary, so probably a do loop
-            ."    Do loop frame inside "
-            over na1+ @ ip>token .current-word ( rs-adr n )
-            over @                             ( rs-adr n n1 )
-            ."   i: "  tuck + .                ( rs-adr n1 )
-            ."   limit: "  minus0  + .         ( rs-adr )
-            2 na+ exit
+         over na1+ @  dup @ +                 ( rs-adr n n2 )
+         dup reasonable-ip?  if               ( rs-adr n adr )
+            ip>token  -1 na+  token@          ( rs-adr n xt )
+            dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n )
+               \ The two numbers span the +- boundary, so probably a do loop
+               ."    Do loop frame inside "
+               over na1+ @ ip>token .current-word ( rs-adr n )
+               over @                             ( rs-adr n n1 )
+               ."   i: "  tuck + .                ( rs-adr n1 )
+               ."   limit: "  minus0  + .         ( rs-adr )
+               2 na+ exit
+            then                               ( rs-adr n )
+         else                                  ( rs-adr n n2 )
+            drop                               ( rs-adr n )
          then                                  ( rs-adr n )
       then                                     ( rs-adr n )
    then                                        ( rs-adr n )
@@ -73,6 +77,67 @@
     repeat                          ( end-adr adr )
     2drop
 ;
+: skip-catch  ( rs-adr -- rs-adr' )  3 na+  ;
+: skip-do-or-n  ( rs-adr n -- rs-adr' )
+   over @ reasonable-ip?  0=  if              ( rs-adr n )
+      \ The second number is not an IP so it could be a do loop frame
+      over na1+ @  reasonable-ip?  if         ( rs-adr n )
+         \ The third entry is a reasonable IP so it could be a do loop frame
+         \ Make sure it points to an offset that points just past a loop end
+         over na1+ @  dup @ +                 ( rs-adr n n2 )
+         dup reasonable-ip?  if               ( rs-adr n adr )
+            ip>token  -1 na+  token@          ( rs-adr n xt )
+            dup ['] (loop) =  swap ['] (+loop) =  or  if  ( rs-adr n )
+               \ The two numbers span the +- boundary, so probably a do loop
+               drop                           ( rs-adr )
+               2 na+ exit                     ( -- rs-adr )
+            then                              ( rs-adr n )
+         else                                 ( rs-adr n n2 )
+            drop                              ( rs-adr n )
+         then                                 ( rs-adr n )
+      then                                    ( rs-adr n )
+   then                                       ( rs-adr n )
+   drop                                       ( rs-adr )
+;
+defer boring?
+: (boring?)  ( ip -- flag )  drop false  ;
+: rtraceword  ( rs-end rs-adr -- rs-end rs-adr' )
+   @+                          ( rs-end rs-adr' ip )
+   dup reasonable-ip?  0=  if  ( rs-end rs-adr ip )
+      skip-do-or-n exit        ( -- rs-end rs-adr )
+   then                        ( rs-end rs-adr )
+
+   dup in-catch?  if           ( rs-end rs-adr ip )
+      drop skip-catch          ( rs-end rs-adr' )
+      exit                     ( -- rs-end rs-adr' )
+   then                        ( rs-end rs-adr ip )
+
+   find-cfa                    ( rs-end rs-adr xt )
+
+   dup boring?  if             ( rs-end rs-adr xt )
+      drop exit                ( -- rs-end rs-adr )
+   then                        ( rs-end rs-adr xt )
+
+   dup ['] interpret-do-defined =  if  ( rs-end rs-adr xt )
+      \ Set rs-adr = rs-end so the caller will exit
+      2drop dup exit           ( -- rs-end rs-adr' )
+   then                        ( rs-end rs-adr xt )
+
+   >name name>string           ( rs-end rs-adr adr len )
+   dup #out @ +  rmargin @  >=  if  ( rs-end rs-adr adr len )
+      \ Set rs-adr = rs-end so the caller will exit
+      2drop ." ..."            ( rs-end rs-adr )
+      drop dup exit            ( -- rs-end rs-adr' )
+   then                        ( rs-end rs-adr adr len )
+
+   type space                  ( rs-end rs-adr )
+;
+: rslist  ( end-adr start-adr -- )
+   begin  2dup u>  while           ( end-adr adr )
+      rtraceword                   ( end-adr adr' )
+   repeat                          ( end-adr adr )
+   2drop
+;
 headers
 forth definitions
 : rstrace  ( -- )  \ Return stack backtrace

Modified: ofw/core/ofwcore.fth
==============================================================================
--- ofw/core/ofwcore.fth	Tue Mar 20 23:37:14 2012	(r2903)
+++ ofw/core/ofwcore.fth	Wed Mar 21 00:56:47 2012	(r2904)
@@ -4770,3 +4770,22 @@
 [ifdef] do-autoload
 ' do-drop-in is do-autoload
 [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 )
+   drop false
+;
+' method-call? to boring?
+previous



More information about the openfirmware mailing list