Changeset 2901


Ignore:
Timestamp:
Mar 20, 2012 10:37:24 AM (14 months 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.