disasm.ft

\ Copyright (c) 2012, Matt Hellige
\ All rights reserved.
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions are met:
\
\   Redistributions of source code must retain the above copyright notice,
\   this list of conditions and the following disclaimer.
\
\   Redistributions in binary form must reproduce the above copyright
\   notice, this list of conditions and the following disclaimer in the
\   documentation and/or other materials provided with the distribution.
\
\ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
\ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
\ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
\ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
\ HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
\ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
\ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
\ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
\ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
\ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
\ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


\ this file contains a simple forth decompiler in the form of SEE.
\ it relies on a number of heuristics which will generally be correct
\ for user-defined words, but will not always be correct for words
\ defined in the forth kernel. some tidying of the kernel and care
\ to separate forth-visible words from other fragments of assembly
\ code should clean that up. but we'll still have to rely on heuristics
\ in any event, so the situation as it is isn't so terrible.

\ a number of other words in this file may be useful in their own
\ right for navigating the dictionary.


\ we exploit the fact that the final link pointer is 0, and
\ thus less than any word in the dictionary
: next-head  ( addr -- limit addr )
    latest @ here ! here ( start at here in case we 'see' latest )
    swap >r ( stash addr )
    begin dup @ r@ > while @ repeat
    r> ;
: >name  ( xt -- nt ) next-head drop @ 1+ ;

: count  ( c-addr -- c-addr u )  dup 1+ swap @ ;
: id.  ( nt -- )  count lenmask and type ;

: xu.r0  ( u n -- ) base @ >r hex u.r0 r> base ! ;


\ colon decompiler for forth words

: '"' char " emit ;
: see-word  ( addr -- n )
    space dup 4 xu.r0 ." : "
    dup @ case
        ['] lit of ." < " 1+ ? ." >" 2 endof
        ['] litstring of '"' 1+ dup @ 2 + swap count type '"' endof
        ['] 0branch of ." 0branch " 1+ ? 2 endof
        ['] branch of ." branch " 1+ ? 2 endof
        >name id. 1 swap
    endcase ;
\ includes start, excludes limit
: see-range  ( limit start -- )  cr ?do i see-word cr +loop ;


\ native disassembler for primitives (and any other memory, obviously)

variable /disasm-pc
: disasm-pc@  ( -- u )  /disasm-pc @  1 /disasm-pc +! ;
: "regs"   S" abcxyzij" ;
: reg  ( reg -- )  "regs" drop + @ emit ;
: "opname" S" ---setaddsubmulmlidivdvimodmdiandborxorshrasrshlifbifcifeifnifgifaiflifu------adxsbx------stistd" ;
: opname  ( op -- )  3 * "opname" drop + 3 type space ;
: disasm-op  ( inst -- op )  0x 1f and ;
: disasm-nextlit  ( arg -- ea )  case
        0x 1a of disasm-pc@ @ endof
        0x 1e of disasm-pc@ @ endof
        0x 1f of disasm-pc@ @ endof
        dup 0x 10 0x 18 within if drop disasm-pc@ @ else
        0 swap
    endcase ;
: fetch-b  ( inst -- arg ) 5 rshift 0x 1f and ;
: disasm-b  ( inst -- pa pl ea arg )  S" push" rot fetch-b
    dup disasm-nextlit swap ;
: disasm-a  ( inst -- pa pl ea arg )  S" pop" rot 10 rshift
    dup disasm-nextlit swap ;
: decode-arg  ( pa pl ea arg -- ) case
        0x 18 of drop 2dup type endof
        0x 19 of ." peek" drop endof
        0x 1a of ." pick " 0 .r endof
        0x 1b of ." sp" drop endof
        0x 1c of ." pc" drop endof
        0x 1d of ." ex" drop endof
        0x 1e of ." [" 0 .r ." ]" endof
        0x 1f of 0 .r endof
        dup 0x 08 u< if 7 and reg drop else
        dup 0x 10 u< if 7 and ." [" reg ." ]" drop else
        dup 0x 18 u< if 7 and ." [" 0 .r ." +" reg ." ]" drop else
        dup 0x 1f u> if 0x 21 - 0 xu.r0 drop else
        dup ." unknown oparg: " 2 xu.r0 nip
    endcase 2drop ;
: disasm-special ( inst -- )
    ( it's ok to deal with b before a, since b can't advance pc )
    dup fetch-b case
        0x 01 of ." jsr" endof
        0x 08 of ." int" endof
        0x 09 of ." iag" endof
        0x 0a of ." ias" endof
        0x 0b of ." rfi" endof
        0x 0c of ." iaq" endof
        0x 10 of ." hwn" endof
        0x 11 of ." hwq" endof
        0x 12 of ." hwi" endof
        dup ." unk[" 2 xu.r0 ." ]"
    endcase
    space disasm-a decode-arg ;
: disasm-inst  ( -- )
    space disasm-pc@ dup 4 xu.r0 ." : "
    @ dup disasm-op ?dup if
        opname dup disasm-a 2>r 2>r disasm-b decode-arg ." , "
        2r> 2r> decode-arg
    else
        disasm-special
    then ;
\ include start excludes limit
: disasm-range  ( limit start -- )
    cr /disasm-pc !
    begin dup /disasm-pc @ > while disasm-inst cr repeat drop ;


\ higher-level 'see' support

: docol-see  ( xt -- ) ." colon-defined word:" 1+ next-head see-range ;
: const-see  ( xt -- ) ." constant: " 1+ ? ;
: var-see  ( xt -- ) ." variable: " 1+ ? ;
: prim-see  ( xt -- ) ." primitive:" next-head disasm-range ;
: xt-see   dup @ case
    docol: of dup docol-see endof
    dovar: of dup var-see endof
    docon: of dup const-see endof
    ( xt [xt] -- )
    2dup 1- = if prim-see else
    ( TODO heuristic check for does> dispatch at the target address )
    ." unrecognized code field value"
    endcase
    drop cr ;
: see   ' ?dup 0= if abort" no such word" then cr xt-see ;


\ save the new image
here dump-core
bye