qemu/roms/SLOF/slof/fs/debug.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 \ Get the name of Forth command whose execution token is xt
  15
  16 : xt>name ( xt -- str len )
  17     BEGIN
  18         cell - dup c@ 0 2 within IF
  19             dup 2+ swap 1+ c@ exit
  20         THEN
  21     AGAIN
  22 ;
  23
  24 cell -1 * CONSTANT -cell
  25 : cell- ( n -- n-cell-size )
  26    [ cell -1 * ] LITERAL +
  27 ;
  28
  29 \ Search for xt of given address
  30 : find-xt-addr ( addr -- xt )
  31    BEGIN
  32       dup @ <colon> = IF
  33          EXIT
  34       THEN
  35       cell-
  36    AGAIN
  37 ;
  38
  39 : (.immediate) ( xt -- )
  40    \ is it immediate?
  41    xt>name drop 2 - c@ \ skip len and flags
  42    immediate? IF
  43      ."  IMMEDIATE"
  44    THEN
  45 ;
  46
  47 : (.xt) ( xt -- )
  48    xt>name type
  49 ;
  50
  51 \ Trace back on current return stack.
  52 \ Start at 1, since 0 is return of trace-back itself
  53
  54 : trace-back (  )
  55    1
  56    BEGIN
  57       cr dup dup . ."  : " rpick dup . ."  : "
  58       ['] tib here within IF
  59           dup rpick find-xt-addr (.xt)
  60       THEN
  61       1+ dup rdepth 5 - >= IF cr drop EXIT THEN
  62    AGAIN
  63 ;
  64
  65 VARIABLE see-my-type-column
  66
  67 : (see-my-type) ( indent limit xt str len -- indent limit xt )
  68    dup see-my-type-column @ + dup 50 >= IF
  69       -rot over "  " comp 0= IF
  70          \ blank causes overflow: just enforce new line with next call
  71          2drop see-my-type-column !
  72       ELSE
  73          rot drop                     ( indent limit xt str len )
  74          \ Need to copy string since we use (u.) again (kills internal buffer):
  75          pocket swap 2dup >r >r       ( indent limit xt str pk len  R: len pk )
  76          move r> r>                   ( indent limit xt pk len )
  77          2 pick (u.) dup -rot
  78          cr type                      ( indent limit xt pk len xt-len )
  79          " :" type 1+                 ( indent limit xt pk len prefix-len )
  80          5 pick dup spaces +          ( indent limit xt pk len prefix-len )
  81          over + see-my-type-column !  ( indent limit xt pk len )
  82          type
  83       THEN                            ( indent limit xt )
  84    ELSE
  85       see-my-type-column ! type       ( indent limit xt )
  86    THEN
  87 ;
  88
  89 : (see-my-type-init) ( -- )
  90    ffff see-my-type-column !        \ just enforce a new line
  91 ;
  92
  93 : (see-colon-body) ( indent limit xt -- indent limit xt )
  94    (see-my-type-init)                              \ enforce new line
  95    BEGIN                                           ( indent limit xt )
  96       cell+ 2dup <>
  97       over @
  98       dup <semicolon> <>
  99       rot and                                      ( indent limit xt @xt flag )
 100    WHILE                                           ( indent limit xt @xt )
 101       xt>name (see-my-type) "  " (see-my-type)
 102       dup @                                        ( indent limit xt @xt)
 103       CASE
 104          <0branch>  OF cell+ dup @
 105                     over + cell+ dup >r
 106                     (u.) (see-my-type) r>          ( indent limit xt target)
 107                     2dup < IF
 108                        over 4 pick 3 + -rot recurse
 109                        nip nip nip cell-           ( indent limit xt )
 110                     ELSE
 111                        drop                        ( indent limit xt )
 112                     THEN
 113                     (see-my-type-init) ENDOF       \ enforce new line
 114          <branch>   OF cell+ dup @ over + cell+ (u.)
 115                     (see-my-type) "  " (see-my-type) ENDOF
 116          <do?do>    OF cell+ dup @ (u.) (see-my-type)
 117                     "  " (see-my-type) ENDOF
 118          <lit>      OF cell+ dup @ (u.) (see-my-type)
 119                     "  " (see-my-type) ENDOF
 120          <dotick>   OF cell+ dup @ xt>name (see-my-type)
 121                     "  " (see-my-type) ENDOF
 122          <doloop>   OF cell+ dup @ (u.) (see-my-type)
 123                     "  " (see-my-type) ENDOF
 124          <do+loop>  OF cell+ dup @ (u.) (see-my-type)
 125                     "  " (see-my-type) ENDOF
 126          <doleave>  OF cell+ dup @ over + cell+ (u.)
 127                     (see-my-type) "  " (see-my-type) ENDOF
 128          <do?leave> OF cell+ dup @ over + cell+ (u.)
 129                     (see-my-type) "  " (see-my-type) ENDOF
 130          <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
 131                     (see-my-type) " """ (see-my-type)
 132                     "  " (see-my-type)
 133                     r> -cell and + ENDOF
 134       ENDCASE
 135    REPEAT
 136    drop
 137 ;
 138
 139 : (see-colon) ( xt -- )
 140    (see-my-type-init)
 141    1 swap 0 swap                                    ( indent limit xt )
 142    " : " (see-my-type) dup xt>name (see-my-type)
 143    rot drop 4 -rot (see-colon-body)                 ( indent limit xt )
 144    rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
 145    3drop
 146 ;
 147
 148 \ Create words are a bit tricky. We find out where their code points.
 149 \ If this code is part of SLOF, it is not a user generated CREATE.
 150
 151 : (see-create) ( xt -- )
 152    dup cell+ @
 153    CASE
 154       <2constant> OF
 155          dup cell+ cell+ dup @ swap cell+ @ . .  ." 2CONSTANT "
 156       ENDOF
 157
 158       <instancevalue> OF
 159          dup cell+ cell+ @ . ." INSTANCE VALUE "
 160       ENDOF
 161
 162       <instancevariable> OF
 163          ." INSTANCE VARIABLE "
 164       ENDOF
 165
 166       dup OF
 167          ." CREATE "
 168       ENDOF
 169    ENDCASE
 170    (.xt)
 171 ;
 172
 173 \ Decompile Forth command whose execution token is xt
 174
 175 : (see) ( xt -- )
 176    cr dup dup @
 177    CASE
 178       <variable> OF ." VARIABLE " (.xt) ENDOF
 179       <value>    OF dup execute . ." VALUE " (.xt) ENDOF
 180       <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
 181       <defer>    OF dup cell+ @ swap ." DEFER " (.xt) ."  is " (.xt) ENDOF
 182       <alias>    OF dup cell+ @ swap ." ALIAS " (.xt) ."  " (.xt) ENDOF
 183       <buffer:>  OF ." BUFFER: " (.xt) ENDOF
 184       <create>   OF (see-create) ENDOF
 185       <colon>    OF (see-colon)  ENDOF
 186       dup        OF ." ??? PRIM " (.xt) ENDOF
 187    ENDCASE
 188    (.immediate) cr
 189   ;
 190
 191 \ Decompile Forth command old-name
 192
 193 : see ( "old-name<>" -- )
 194    ' (see)
 195 ;
 196
 197 \ Work in progress...
 198
 199 0    value forth-ip
 200 true value trace>stepping?
 201 true value trace>print?
 202 true value trace>up?
 203 0    value trace>depth
 204 0    value trace>rdepth
 205 0    value trace>recurse
 206 : trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
 207 : trace-depth- ( -- ) trace>depth 1- to trace>depth ;
 208
 209 : stepping ( -- )
 210     true to trace>stepping?
 211 ;
 212
 213 : tracing ( -- )
 214     false to trace>stepping?
 215 ;
 216
 217 : trace-print-on ( -- )
 218     true to trace>print?
 219 ;
 220
 221 : trace-print-off ( -- )
 222     false to trace>print?
 223 ;
 224
 225
 226 \ Add n to ip
 227
 228 : fip-add ( n -- )
 229    forth-ip + to forth-ip
 230 ;
 231
 232 \ Save execution token address and content
 233
 234 0 value debug-last-xt
 235 0 value debug-last-xt-content
 236
 237 : trace-print ( -- )
 238    forth-ip cr u. ." : "
 239    forth-ip @
 240    dup ['] breakpoint = IF drop debug-last-xt-content THEN
 241    xt>name type ."  "
 242    ."     ( " .s  ."  )  | "
 243 ;
 244
 245 : trace-interpret ( -- )
 246    rdepth 1- to trace>rdepth
 247    BEGIN
 248       depth . [char] > dup emit emit space
 249       source expect                        ( str len )
 250       ['] interpret catch print-status
 251    AGAIN
 252 ;
 253
 254 \ Main trace routine, trace a colon definition
 255
 256 : trace-xt ( xt -- )
 257     trace>recurse IF
 258        r> drop                                \ Drop return of 'trace-xt call
 259        cell+                                  \ Step over ":"
 260     ELSE
 261        debug-last-xt-content <colon> = IF
 262           \ debug colon-definition
 263           ['] breakpoint @ debug-last-xt !    \ Re-arm break point
 264           r> drop                             \ Drop return of 'trace-xt call
 265           cell+                               \ Step over ":"
 266        ELSE
 267           ['] breakpoint debug-last-xt !      \ Re-arm break point
 268           2r> 2drop
 269        THEN
 270     THEN
 271
 272     to forth-ip
 273     true to trace>print?
 274     BEGIN
 275        trace>print? IF trace-print THEN
 276
 277        forth-ip                                              ( ip )
 278        trace>stepping? IF
 279           BEGIN
 280              key
 281              CASE
 282                 [char] d OF dup @ @ <colon> = IF             \ recurse only into colon definitions
 283                                                  trace-depth+
 284                                                  1 to trace>recurse
 285                                                  dup >r @ recurse
 286                                               THEN true ENDOF
 287                 [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
 288                 [char] f OF drop cr trace-interpret ENDOF       \ quit trace and start interpreter FIXME rstack
 289                 [char] c OF tracing true ENDOF
 290                 [char] t OF trace-back false ENDOF
 291                 [char] q OF drop cr quit ENDOF
 292                 20       OF true ENDOF
 293                 dup      OF cr ." Press d:       Down into current word" cr
 294                             ." Press u:       Up to caller" cr
 295                             ." Press f:       Switch to forth interpreter, 'resume' will continue tracing" cr
 296                             ." Press c:       Switch to tracing" cr
 297                             ." Press <space>: Execute current word" cr
 298                             ." Press q:       Abort execution, switch to interpreter" cr
 299                             false ENDOF
 300              ENDCASE
 301           UNTIL
 302        THEN                                                   ( ip' )
 303        dup to forth-ip @                                      ( xt )
 304        dup ['] breakpoint = IF drop debug-last-xt-content THEN
 305        dup                                                    ( xt xt )
 306
 307        CASE
 308             <sliteral>  OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
 309             <dotick>    OF drop forth-ip cell+ @ cell fip-add ENDOF
 310             <lit>       OF drop forth-ip cell+ @ cell fip-add ENDOF
 311             <doto>      OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
 312             <(doito)>   OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
 313             <0branch>   OF drop IF
 314                                     cell fip-add
 315                                 ELSE
 316                                     forth-ip cell+ @ cell+ fip-add THEN
 317                         ENDOF
 318             <do?do>     OF drop 2dup <> IF
 319                                            swap >r >r cell fip-add
 320                                         ELSE
 321                                            forth-ip cell+ @ cell+ fip-add 2drop THEN
 322                         ENDOF
 323             <branch>    OF drop forth-ip cell+ @ cell+ fip-add ENDOF
 324             <doleave>   OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF
 325             <do?leave>  OF drop IF
 326                                    r> r> 2drop forth-ip cell+ @ cell+ fip-add
 327                                 ELSE
 328                                    cell fip-add
 329                                 THEN
 330                         ENDOF
 331             <doloop>    OF drop r> 1+ r> 2dup = IF
 332                                                    2drop cell fip-add
 333                                                 ELSE >r >r
 334                                                     forth-ip cell+ @ cell+ fip-add THEN
 335                         ENDOF
 336             <do+loop>   OF drop r> + r> 2dup >= IF
 337                                                    2drop cell fip-add
 338                                                 ELSE >r >r
 339                                                     forth-ip cell+ @ cell+ fip-add THEN
 340                         ENDOF
 341
 342             <semicolon> OF trace>depth 0> IF
 343                                              trace-depth- 1 to trace>recurse
 344                                              stepping drop r> recurse
 345                                           ELSE
 346                                              drop exit THEN
 347                         ENDOF
 348             <exit>      OF trace>depth 0> IF
 349                                              trace-depth- stepping drop r> recurse
 350                                           ELSE
 351                                              drop exit THEN
 352                         ENDOF
 353             dup         OF execute ENDOF
 354         ENDCASE
 355         forth-ip cell+ to forth-ip
 356     AGAIN
 357 ;
 358
 359 \ Resume execution from tracer
 360 : resume ( -- )
 361     trace>rdepth rdepth!
 362     forth-ip cell - trace-xt
 363 ;
 364
 365 \ Turn debug off, by erasing breakpoint
 366
 367 : debug-off ( -- )
 368     debug-last-xt IF
 369         debug-last-xt-content debug-last-xt !  \ Restore overwritten token
 370         0 to debug-last-xt
 371     THEN
 372 ;
 373
 374
 375
 376 \ Entry point for debug
 377
 378 : (break-entry) ( -- )
 379    debug-last-xt dup @ ['] breakpoint <> swap  ( debug-addr? debug-last-xt )
 380    debug-last-xt-content swap !                \ Restore overwritten token
 381    r> drop                                     \ Don't return to bp, but to caller
 382    debug-last-xt-content <colon> <> and IF     \ Execute non colon definition
 383       debug-last-xt cr u. ." : "
 384       debug-last-xt xt>name type ."  "
 385       ."     ( " .s  ."  )  | "
 386       key drop
 387       debug-last-xt execute
 388    ELSE
 389       debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt   \ Trace colon definition
 390    THEN
 391 ;
 392
 393 \ Put entry point bp defer
 394 ' (break-entry) to BP
 395
 396 \ Mark an address for debugging
 397
 398 : debug-address ( addr --  )
 399    debug-off                       ( xt )  \ Remove active breakpoint
 400    dup to debug-last-xt            ( xt )  \ Save token for later debug
 401    dup @ to debug-last-xt-content  ( xt )  \ Save old value
 402    ['] breakpoint swap !
 403 ;
 404
 405 \ Mark the command indicated by xt for debugging
 406
 407 : (debug ( xt --  )
 408    debug-off                       ( xt )  \ Remove active breakpoint
 409    dup to debug-last-xt            ( xt )  \ Save token for later debug
 410    dup @ to debug-last-xt-content  ( xt )  \ Save old value
 411    ['] breakpoint @ swap !
 412 ;
 413
 414 \ Mark the command indicated by xt for debugging
 415
 416 : debug ( "old-name<>" -- )
 417     parse-word $find IF                       \ Get xt for old-name
 418        (debug
 419     ELSE
 420        ." undefined word " type cr
 421     THEN
 422 ;