Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 5d6680814c
Fetching contributors…

Cannot retrieve contributors at this time

157 lines (138 sloc) 5.853 kB
\ 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 swap ." [" 0 .r ." +" reg ." ]" 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= abort" no such word" cr xt-see ;
\ save the new image
here dump-core
bye
Jump to Line
Something went wrong with that request. Please try again.