Changeset 2901


Ignore:
Timestamp:
Mar 20, 2012, 10:37:24 AM (3 years ago)
Author:
wmb
Message:

Debugger - 2D display of debugged word instead of scrolling. Not perfect yet, but pretty good. Revert to old behavior with "true to scrolling-debug?"

Files:
4 edited

Legend:

Unmodified
Added
Removed
  • cpu/arm/kerncode.fth

    r2848 r2901  
    236236\rel  addvc   ip,ip,r0
    237237\abs  ldrvc   ip,[ip]
    238    ldrvc  pc,[ip],1cell
     238   nxtvc
    239239   inc    rp,3cells
    240240   inc    ip,1cell
     
    249249\rel  addvc   ip,ip,r0
    250250\abs  ldrvc   ip,[ip]
    251    ldrvc   pc,[ip],1cell
     251   nxtvc
    252252   inc     rp,3cells
    253253   inc     ip,1cell
     
    271271\rel  addeq   ip,ip,r0
    272272\abs  ldreq   ip,[ip]
    273    ldreq   pc,[ip],1cell
     273   nxteq
    274274                ( r: loop-end-offset l+0x8000 i-l-0x8000 )
    275275   psh     ip,rp          \ save the do offset address
     
    313313   cmp     tos,#0
    314314   pop     tos,sp
    315    ldreq   pc,[ip],1cell
     315   nxteq
    316316   inc     rp,2cells     \ get rid of the loop indices
    317317   ldr     ip,[rp],1cell
     
    666666\   mov       tos,#0
    667667\   cmp       r2,r0
    668 \   ldrlt     pc,[ip],1cell
     668\   nxtlt
    669669\   cmp       r2,r1
    670670\   mvnle     tos,#0
     
    936936   -rot  >>a  or                            ( low2  r: high2 )
    937937   r>                                       ( d2 )
     938;
     939: du*  ( d1 u -- d2 )  \ Double result
     940   tuck u* >r     ( d1.lo u r: d2.hi )
     941   um*  r> +      ( d2 )
     942;
     943: du*t  ( ud.lo ud.hi u -- res.lo res.mid res.hi )  \ Triple result
     944   tuck um*  2>r  ( ud.lo u          r: res.mid0 res.hi0 )
     945   um*            ( res.lo res.mid1  r: res.mid0 res.hi0 )
     946   0  2r> d+      ( res.lo res.mid res.hi )
    938947;
    939948
  • forth/lib/debug.fth

    r2821 r2901  
    2727only forth also definitions
    2828
     29false value scrolling-debug?
     30
    2931hex
    3032headerless
     
    3638variable res
    3739headers
     40false value first-time?
    3841: (debug)       (s low-adr hi-adr -- )
    3942   unbug   1 cnt !   ip> !   <ip !   pnext
     
    4346   then
    4447   step? on
     48   true is first-time?
    4549;
    4650headerless
     
    5256;
    5357
    54 false value first-time?
    5558headers
    5659\ Enter and leave the debugger
     
    6164
    6265   dup colon-cf?  0= abort" Not a colon definition"
    63    >body dup 'unnest  (debug)  true is first-time?
     66   >body dup 'unnest  (debug)
    6467;
    6568\ Debug the caller
     
    114117;
    115118d# 24 constant cmd-column
     119: to-cmd-column  ( -- )  cmd-column to-column  ;
     120
     1210 value stack-line
     122d# 50 constant stack-column
     123\ 0 0 2value result-loc
     1240 value result-line
     1250 value result-col
     126: to-stack-location  ( -- )  stack-column stack-line at-xy  kill-line  ;
     127\ : save-result-loc  ( -- )  #out @ #line @ to result-loc  ;
     128\ : to-result-loc  ( -- )  result-loc at-xy  ;
     129: save-result-loc  ( -- )  #out @ to result-col   #line @ to result-line  ;
     130: to-result-loc  ( -- )  result-col result-line at-xy  ;
     131
    1161320 value rp-mark
    117 : to-cmd-column  ( -- )  cmd-column to-column  ;
    118133
    119134\ set-package is a hook for Open Firmware.  When Open Firmware is loaded,
     
    151166: (trace  ( -- )
    152167   first-time?  if
    153       ??cr
    154       ip@  <ip @ =  if  ." : "  else  ." Inside "  then
    155       <ip @ find-cfa .name
     168      scrolling-debug?  if
     169         ??cr
     170         ip@  <ip @ =  if  ." : "  else  ." Inside "  then
     171         <ip @ find-cfa .name
     172      else
     173         ip@ debug-see
     174         0 is stack-line \ So the initial stack is displayed in the right place
     175         cr
     176      then
    156177      0 show-rstack !
    157178      false is first-time?
     
    161182      step? @  if  to-debug-window  then
    162183      save#
    163       cmd-column 2+ to-column
     184      scrolling-debug?  if
     185         cmd-column 2+ to-column
     186      else
     187         save-result-loc
     188         to-stack-location
     189      then
     190
    164191      hex-stack @  if  push-hex  then
    165192      ." ( " .s    \ Show data stack
    166193      hex-stack @  if  pop-base  then
    167194      show-rstack @  if  (.rs  then   \ Show return stack
    168       ." )" cr
     195      ." )"
    169196      restore#
    170197
    171       ['] noop is indent
    172       ip@ .token drop             \ Show word name
    173       ['] (indent) is indent
    174       to-cmd-column
     198      scrolling-debug?  if
     199         cr
     200         ['] noop is indent
     201         ip@ .token drop                  \ Show word name
     202         ['] (indent) is indent
     203         to-cmd-column
     204      else
     205         ip@ ip-set-cursor
     206         #line @ to stack-line
     207      then
    175208
    176209      step? @  key? or  if
    177210         step? on  res off
    178          key dup bl <  if  drop bl  then  dup emit  upc
     211         key dup bl <  if  drop bl  then
     212         scrolling-debug?  if  dup emit  else  to-result-loc  then  upc
    179213         restore-window
    180          reset-page
     214         scrolling-debug?  if  reset-page  then
    181215         case
    182216            ascii D  of  ip@ token@ executer  ['] (debug try endof \ Down
     
    207241   until
    208242   restore#
     243   scrolling-debug? 0=  if  to-result-loc  then
    209244   ip@ token@  dup ['] unnest =  swap ['] exit =  or  if
    210245      cr  true is first-time?
  • forth/lib/decomp.fth

    r2899 r2901  
    5555
    5656hidden definitions
     57d# 200 2* /n* constant /positions
     58/positions buffer: positions
     590 value end-positions
     60\ 0 value line-after-;
     61
     62: init-positions  ( -- )  positions is end-positions  ;
     63: find-position  ( ip -- true | adr false )
     64   end-positions positions  ?do   ( ip )
     65      i 2@ nip                    ( ip that-ip )
     66      over =  if                  ( ip )
     67         drop i false             ( adr false )
     68         unloop exit              ( adr false -- )
     69      then                        ( ip )
     70   2 /n* +loop                    ( ip )
     71   drop true                      ( true )
     72;
     730 value the-ip
     74: add-position  ( ip -- )
     75   the-ip find-position  if                        ( )
     76      end-positions  positions /positions +  >=    ( flag )
     77      abort" Decompiler position table overflow"   ( )
     78      end-positions  dup 2 na+  is end-positions   ( adr )
     79   then                                            ( adr )
     80   #out @ #line @ wljoin  the-ip  rot 2!           ( )
     81;
     82: ip>position  ( ip -- true | #out #line false )
     83   find-position  if    ( )
     84      true              ( true )
     85   else                 ( adr )
     86      2@ drop lwsplit   ( #out #line )
     87      false             ( #out #line false )
     88   then                 ( true | #out #line false )
     89;
     90: ip-set-cursor  ( ip -- )
     91   ip>position 0=  if  at-xy  then
     92;
     93
    5794headerless
    5895\ Like ." but goes to a new line if needed.
    59 : cr".  ( adr len -- )  dup ?line magenta-letters type cancel  ;
     96: cr".  ( adr len -- )
     97   dup ?line                    ( adr len )
     98   add-position                 ( adr len )
     99   magenta-letters type cancel  ( )
     100;
    60101: .."   ( -- )  [compile] " compile cr".  ; immediate
    61102
     
    104145
    105146headerless
     147
    106148\ Breaks is a list of places in a colon definition where control
    107149\ is transferred without there being a branch nearby.
     
    110152\ a then, for forward branches, or an exit.
    111153
    112 80 /n* constant /breaks
     154d# 40 2* /n* constant /breaks
    113155/breaks buffer: breaks
    114156variable end-breaks
     
    186228: add-break  ( break-address break-type -- )
    187229   end-breaks @  breaks /breaks +  >=        ( adr,type full? )
    188    abort" Decompiler internal table overlow" ( adr,type )
     230   abort" Decompiler table overflow"        ( adr,type )
    189231   end-breaks @ breaks >  if                 ( adr,type )
    190232      over end-breaks @ /n 2* - >r r@ 2@     ( adr,type  adr prev-adr,type )
     
    281323;
    282324
    283 : put"          (s -- )  ascii " emit  space  ;
     325: put"  (s -- )  ascii " emit  space  ;
    284326
    285327: cword-name  (s ip -- ip' $ name$ )
     
    295337   cr".  space                 ( $ )
    296338   red-letters type            ( )
    297    .." "" "                    ( )
    298 ;
    299 
    300 : pretty-n. ( n -- )  green-letters n. cancel ;
    301 : pretty-.  ( n -- )  green-letters  . cancel ;
    302 
    303 : .word         ( ip -- ip' )  dup token@ check-[compile] ?cr .name   ta1+  ;
     339   magenta-letters             ( )
     340   ." "" "                     ( )
     341   cancel                      ( )
     342;
     343
     344: pretty-. ( n -- )
     345   base @ d# 10 =  if  (.)  else  (u.)  then   ( adr len )
     346   dup ?line  add-position
     347   green-letters type cancel  space
     348;
     349
     350: .compiled  ( ip -- ip' )
     351   dup token@ check-[compile]   ( ip xt )
     352   >name name>string            ( ip adr len )
     353   type space                   ( ip )
     354   ta1+                         ( ip' )
     355;
     356: .word         ( ip -- ip' )
     357   dup token@ check-[compile]   ( ip xt )
     358   >name name>string            ( ip adr len )
     359   dup ?line  add-position      ( ip adr len )
     360   type space                   ( ip )
     361   ta1+                         ( ip' )
     362;
    304363: skip-word     ( ip -- ip' )  ta1+  ;
    305 : .inline       ( ip -- ip' )  ta1+ dup unaligned-@  pretty-n.  na1+   ;
     364: .inline       ( ip -- ip' )  ta1+ dup unaligned-@  pretty-.  na1+   ;
    306365: skip-inline   ( ip -- ip' )  ta1+ na1+  ;
    307366: .wlit         ( ip -- ip' )  ta1+ dup unaligned-w@ 1- pretty-. wa1+  ;
     
    309368: .llit         ( ip -- ip' )  ta1+ dup unaligned-l@ 1- pretty-. la1+  ;
    310369: skip-llit     ( ip -- ip' )  ta1+ la1+  ;
    311 : .dlit         ( ip -- ip' )  ta1+ dup d@ (d.) green-letters type ." . " cancel  2 na+  ;
     370: .dlit         ( ip -- ip' )  ta1+ dup d@ (d.) add-position green-letters type ." . " cancel  2 na+  ;
    312371: skip-dlit     ( ip -- ip' )  ta1+ 2 na+  ;
    313372: skip-branch   ( ip -- ip' )  +branch  ;
    314 : .compile      ( ip -- ip' )  .." compile " ta1+ .word   ;
     373: .compile      ( ip -- ip' )  .." compile " ta1+ .compiled   ;
    315374: skip-compile  ( ip -- ip' )  ta1+ ta1+  ;
    316375: skip-string   ( ip -- ip' )  ta1+ +str  ;
     
    437496\ Decompile the parameter field of colon definition
    438497: .pf   ( apf -- )
     498   init-positions                                     ( apf )
    439499   dup scan-pf next-break 3 lmargin ! indent          ( apf )
    440500   begin                                              ( adr )
     501      dup is the-ip                                   ( adr )
    441502      ?cr  break-addr @ over =  if                    ( adr )
    442503         begin                                        ( adr )
     
    461522: dump-body  ( pfa -- )
    462523   push-hex
    463    dup @ pretty-n. 2 spaces  8 emit.ln
     524   dup @ pretty-. 2 spaces  8 emit.ln
    464525   pop-base
    465526;
    466527\ Display category of word
    467528: .:           ( acf definer -- )  .definer space space  >body  .pf   ;
    468 : .constant    ( acf definer -- )  over >data @ pretty-n.  .definer drop  ;
    469 : .2constant   ( acf definer -- )  over >data dup @ pretty-n.  na1+ @ pretty-n. .definer drop  ;
     529: debug-see    ( apf -- )
     530   page-mode? >r  no-page
     531   d# 48 rmargin !  find-cfa ['] :  page  .:
     532   r> is page-mode?
     533;
     534: .constant    ( acf definer -- )  over >data @ pretty-.  .definer drop  ;
     535: .2constant   ( acf definer -- )  over >data dup @ pretty-.  na1+ @ pretty-. .definer drop  ;
    470536: .vocabulary  ( acf definer -- )  .definer drop  ;
    471537: .code        ( acf definer -- )  .definer >code disassemble  ;
    472538: .variable    ( acf definer -- )
    473    over >data n.   .definer   ." value = " >data @ pretty-n.
     539   over >data n.   .definer   ." value = " >data @ pretty-.
    474540;
    475541: .create     ( acf definer -- )
     
    477543;
    478544: .user        ( acf definer -- )
    479    over >body @ n.   .definer   ."  value = "   >data @ pretty-n.
     545   over >body @ n.   .definer   ."  value = "   >data @ pretty-.
    480546;
    481547: .defer       ( acf definer -- )
     
    486552;
    487553: .value      ( acf definer -- )
    488    swap >data @ pretty-n. .definer
     554   swap >data @ pretty-. .definer
    489555;
    490556
     
    561627\ top level of the decompiler SEE
    562628: ((see   ( acf -- )
    563    td 64 rmargin !
     629   d# 48 rmargin !
    564630   dup dup definer dup   definition-class .definition-class
    565631   .immediate
  • forth/lib/objects.fth

    r2244 r2901  
    139139
    140140[ifdef] install-decomp
    141 : .action  ( ip -- ip' )  dup token@ .name ta1+ dup token@ .name ta1+  ;
    142141also hidden also
     142: .action  ( ip -- ip' )
     143   d# 15 ?line  \ Just a guess
     144   dup token@ >name name>string cr". space ta1+
     145   .compiled
     146;
    143147' to   ' .action  ' skip-(')  install-decomp
    144148' addr ' .action  ' skip-(')  install-decomp
Note: See TracChangeset for help on using the changeset viewer.