tools.image-analyzer: now relocation pointers are decoded too -> nicer graphs
Björn Lindqvist
parent
46bfcbf3a2
commit
89eaca34bf
|
|
@ -1,12 +1,11 @@
|
|||
USING: accessors alien.strings assocs classes graphviz
|
||||
graphviz.attributes graphviz.notation kernel math.parser sequences
|
||||
slots.syntax system tools.image-analyzer
|
||||
tools.image-analyzer.ref-fixer tools.image-analyzer.vm vocabs.parser ;
|
||||
USING: accessors alien.strings assocs classes fry graphviz
|
||||
graphviz.attributes graphviz.notation kernel sequences system
|
||||
tools.image-analyzer.references tools.image-analyzer.vm vocabs.parser ;
|
||||
IN: tools.image-analyzer.graphviz
|
||||
FROM: arrays => 1array 2array ;
|
||||
FROM: byte-arrays => >byte-array ;
|
||||
FROM: kernel => object ;
|
||||
FROM: math => - ;
|
||||
FROM: math => <= - shift ;
|
||||
|
||||
<<
|
||||
! For the two annoying structs that differ on 32 and 64 bit.
|
||||
|
|
@ -16,22 +15,8 @@ cpu x86.32?
|
|||
? use-vocab
|
||||
>>
|
||||
|
||||
GENERIC: object-references ( struct -- seq )
|
||||
|
||||
M: word object-references ( struct -- seq )
|
||||
slots{ def entry_point name props vocabulary } ;
|
||||
|
||||
M: code-block object-references ( struct -- seq )
|
||||
slots{ owner parameters relocation } ;
|
||||
|
||||
M: object object-references ( struct -- seq )
|
||||
drop { } ;
|
||||
|
||||
: heap-node>edges ( heap-node -- edges )
|
||||
[ address>> ]
|
||||
[
|
||||
object>> object-references [ 1 = ] reject
|
||||
] bi [ 2array ] with map ;
|
||||
: array>string ( array -- str )
|
||||
0 suffix >byte-array alien>native-string ;
|
||||
|
||||
CONSTANT: node-colors {
|
||||
{ array "#999999" }
|
||||
|
|
@ -40,38 +25,47 @@ CONSTANT: node-colors {
|
|||
{ code-block "#ffaaff" }
|
||||
{ string "#aaddff" }
|
||||
{ quotation "#449900" }
|
||||
{ word "#00ff99" }
|
||||
{ word "#00ffcc" }
|
||||
}
|
||||
|
||||
: array>string ( array -- str )
|
||||
0 suffix >byte-array alien>native-string ;
|
||||
|
||||
: heap-node>label ( heap-node -- id )
|
||||
dup object>> dup string? [ drop payload>> array>string ] [
|
||||
[ address>> ] dip
|
||||
code-block? [ code-heap-shift - ] when number>string
|
||||
] if ;
|
||||
|
||||
: heap-node>fill-color ( heap-node -- color )
|
||||
: heap-node>color ( heap-node -- color )
|
||||
object>> class-of node-colors at ;
|
||||
|
||||
: heap-node>node ( heap-node -- node )
|
||||
dup address>> <node>
|
||||
over heap-node>fill-color =fillcolor
|
||||
swap heap-node>label =label
|
||||
"filled" =style ;
|
||||
: relativise-address ( image heap-node -- address )
|
||||
swap [
|
||||
[ address>> ] [ code-heap-node? ] bi
|
||||
] [
|
||||
header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
|
||||
] bi* ? - ;
|
||||
|
||||
: add-edges ( graph edges -- graph )
|
||||
: heap-node>label ( image heap-node -- label )
|
||||
dup object>> string? [
|
||||
nip payload>> array>string
|
||||
] [ relativise-address ] if ;
|
||||
|
||||
: heap-node>node ( image heap-node -- node )
|
||||
[ heap-node>label ] [ heap-node>color ] [ address>> ] tri
|
||||
<node> swap =fillcolor swap =label "filled" =style ;
|
||||
|
||||
: add-nodes ( graph image -- graph )
|
||||
dup heap>> [ heap-node>node add ] with each ;
|
||||
|
||||
: heap-node-edges ( heap heap-node -- seq )
|
||||
[ collect-pointers ] keep address>> '[ _ swap 2array ] map ;
|
||||
|
||||
: image>edges ( image -- edges )
|
||||
heap>> dup [ heap-node-edges ] with map concat ;
|
||||
|
||||
: add-graphviz-edges ( graph edges -- graph )
|
||||
[ first2 add-edge ] each ;
|
||||
|
||||
: setup-graph ( graph -- graph )
|
||||
: add-edges ( graph image -- graph )
|
||||
image>edges add-graphviz-edges ;
|
||||
|
||||
: <heap-graph> ( -- graph )
|
||||
<digraph>
|
||||
[graph "neato" =layout ];
|
||||
<graph-attributes> "false" >>overlap add ;
|
||||
|
||||
: make-graph ( heap-nodes -- graph )
|
||||
dup <digraph> setup-graph
|
||||
swap [ heap-node>node add ] each
|
||||
swap [ heap-node>edges add-edges ] each ;
|
||||
|
||||
: graph-image ( image -- graph )
|
||||
load-image swap dupd fix-references make-graph ;
|
||||
: image>graph ( image -- graph )
|
||||
<heap-graph> over add-nodes swap add-edges ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,30 @@
|
|||
USING: accessors classes.struct fry io io.encodings.binary io.files
|
||||
io.streams.byte-array kernel sequences
|
||||
io.streams.byte-array kernel math sequences
|
||||
tools.image-analyzer.code-heap-reader
|
||||
tools.image-analyzer.data-heap-reader tools.image-analyzer.utils
|
||||
tools.image-analyzer.vm ;
|
||||
IN: tools.image-analyzer
|
||||
|
||||
TUPLE: image header heap ;
|
||||
|
||||
: code-heap>code-blocks ( code-heap -- code-blocks )
|
||||
binary [ [ read-code-block ] consume-stream>sequence ] with-byte-reader ;
|
||||
|
||||
: data-heap>objects ( data-relocation-base data-heap -- seq )
|
||||
binary [ '[ _ read-object ] consume-stream>sequence ] with-byte-reader ;
|
||||
|
||||
: load-image ( image -- header heap-nodes )
|
||||
: (adjust-addresses) ( nodes base -- )
|
||||
'[ [ _ + ] change-address drop ] each ;
|
||||
|
||||
: adjust-addresses ( header data-nodes code-nodes -- )
|
||||
pick code-relocation-base>> (adjust-addresses)
|
||||
swap data-relocation-base>> (adjust-addresses) ;
|
||||
|
||||
: load-image ( image-file -- image )
|
||||
binary [
|
||||
image-header read-struct dup [
|
||||
[ data-relocation-base>> ] [ data-size>> read ] bi
|
||||
data-heap>objects
|
||||
]
|
||||
[ code-size>> read code-heap>code-blocks ] bi
|
||||
] with-file-reader append ;
|
||||
] with-file-reader 3dup adjust-addresses append image boa ;
|
||||
|
|
|
|||
|
|
@ -1,68 +0,0 @@
|
|||
USING: accessors arrays combinators fry kernel layouts math
|
||||
math.bitwise sequences ;
|
||||
IN: tools.image-analyzer.ref-fixer
|
||||
QUALIFIED-WITH: tools.image-analyzer.vm vm
|
||||
|
||||
: update-ref ( val rel-base -- val' )
|
||||
[ 15 unmask ] dip - ;
|
||||
|
||||
: update-data-ref ( val rel-base -- val' )
|
||||
over 1 = [ 2drop 1 ] [ update-ref ] if ;
|
||||
|
||||
: update-ep-ref ( val rel-base -- val' )
|
||||
update-ref 4 cell * - ;
|
||||
|
||||
|
||||
GENERIC# fix-data-reference 1 ( struct rel-base -- )
|
||||
|
||||
M: vm:word fix-data-reference ( word rel-base -- )
|
||||
'[ _ update-data-ref ]
|
||||
{
|
||||
[ change-name drop ]
|
||||
[ change-vocabulary drop ]
|
||||
[ change-def drop ]
|
||||
[ change-props drop ]
|
||||
} 2cleave ;
|
||||
|
||||
M: vm:code-block fix-data-reference ( quotation rel-base -- )
|
||||
'[ _ update-data-ref ]
|
||||
[ change-owner drop ]
|
||||
[ change-relocation drop ]
|
||||
[ change-parameters drop ] 2tri ;
|
||||
|
||||
M: object fix-data-reference ( object rel-base -- )
|
||||
2drop ;
|
||||
|
||||
: fix-data-references ( heap-nodes rel-base -- )
|
||||
'[ object>> _ fix-data-reference ] each ;
|
||||
|
||||
GENERIC# fix-code-reference 1 ( struct rel-base -- )
|
||||
|
||||
M: vm:word fix-code-reference ( word rel-base -- )
|
||||
'[ _ update-ep-ref ] change-entry_point drop ;
|
||||
|
||||
M: vm:quotation fix-code-reference ( quotation rel-base -- )
|
||||
'[ _ update-ep-ref ] change-entry_point drop ;
|
||||
|
||||
M: object fix-code-reference ( object rel-base -- )
|
||||
2drop ;
|
||||
|
||||
CONSTANT: code-heap-shift 65536
|
||||
|
||||
: shift-code-addresses ( heap-nodes -- )
|
||||
[ dup object>> vm:code-block? [
|
||||
[ code-heap-shift + ] change-address ] when drop
|
||||
] each ;
|
||||
|
||||
: shift-code-heap ( heap-nodes header -- )
|
||||
[ shift-code-addresses ] [
|
||||
[ code-heap-shift - ] change-code-relocation-base drop
|
||||
] bi* ;
|
||||
|
||||
: fix-code-references ( heap-nodes rel-base -- )
|
||||
'[ object>> _ fix-code-reference ] each ;
|
||||
|
||||
: fix-references ( heap-nodes header -- )
|
||||
2dup shift-code-heap
|
||||
[ data-relocation-base>> fix-data-references ]
|
||||
[ code-relocation-base>> fix-code-references ] 2bi ;
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Tools to follow references in the loaded image.
|
||||
USING: accessors byte-arrays fry kernel layouts math math.bitwise
|
||||
sequences slots.syntax tools.image-analyzer.relocations ;
|
||||
IN: tools.image-analyzer.references
|
||||
QUALIFIED-WITH: tools.image-analyzer.vm vm
|
||||
|
||||
! Edges in the heap
|
||||
GENERIC: pointers ( heap heap-node struct -- seq )
|
||||
|
||||
M: vm:array pointers ( heap heap-node struct -- seq )
|
||||
drop nip payload>> ;
|
||||
|
||||
: find-heap-node ( heap ptr -- node )
|
||||
15 unmask '[ address>> _ = ] find nip ;
|
||||
|
||||
: load-relocations ( heap code-block -- seq )
|
||||
relocation>> find-heap-node payload>> >byte-array byte-array>relocations
|
||||
[ first 2 = ] filter ;
|
||||
|
||||
: relocation>pointer ( heap-node relocation -- ptr )
|
||||
over payload>> swap load-relative-value swap address>> + ;
|
||||
|
||||
: relocation-pointers ( heap heap-node code-block -- seq )
|
||||
swapd load-relocations [ relocation>pointer ] with map ;
|
||||
|
||||
M: vm:code-block pointers ( heap heap-node struct -- seq )
|
||||
[ relocation-pointers ] [ slots{ owner parameters relocation } ] bi
|
||||
append ;
|
||||
|
||||
M: vm:word pointers ( heap heap-node struct -- seq )
|
||||
2nip [
|
||||
slots{ def name props vocabulary }
|
||||
] [ entry_point>> 4 cell * - ] bi suffix ;
|
||||
|
||||
M: object pointers ( heap heap-node struct -- seq )
|
||||
3drop { } ;
|
||||
|
||||
: collect-pointers ( heap heap-node -- seq )
|
||||
dup object>> pointers [ 1 <= ] reject [ 15 unmask ] map ;
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
USING: alien.c-types alien.data assocs combinators.smart kernel math
|
||||
sequences ;
|
||||
IN: tools.image-analyzer.relocations
|
||||
|
||||
CONSTANT: rel-params {
|
||||
{ 9 1 }
|
||||
{ 0 2 } { 13 2 }
|
||||
}
|
||||
|
||||
: rel-type ( uint -- type )
|
||||
-28 shift 0xf bitand ;
|
||||
|
||||
: rel-class ( uint -- class )
|
||||
-24 shift 0xf bitand ;
|
||||
|
||||
: rel-offset ( uint -- offset )
|
||||
0xffffff bitand ;
|
||||
|
||||
: rel-nr-params ( uint -- n )
|
||||
rel-params at 0 or ;
|
||||
|
||||
: uint>relocation ( uint -- relocation )
|
||||
{ [ rel-type ] [ rel-class ] [ rel-offset ] [ rel-nr-params ] }
|
||||
cleave>array ;
|
||||
|
||||
: byte-array>relocations ( byte-array -- relocations )
|
||||
uint cast-array [ uint>relocation ] { } map-as ;
|
||||
|
||||
: load-relative-value ( byte-array relocation -- value )
|
||||
third [ [ 4 - ] keep rot subseq int cast-array first ] keep + ;
|
||||
|
|
@ -9,10 +9,10 @@ STRUCT: image-header
|
|||
{ data-size cell_t }
|
||||
{ code-relocation-base cell_t }
|
||||
{ code-size cell_t }
|
||||
{ true-object cell_t }
|
||||
{ bignum-zero cell_t }
|
||||
{ bignum-pos-one cell_t }
|
||||
{ bignum-neg-one cell_t }
|
||||
{ reserved-1 cell_t }
|
||||
{ reserved-2 cell_t }
|
||||
{ reserved-3 cell_t }
|
||||
{ reserved-4 cell_t }
|
||||
{ special-objects cell_t[special-object-count] } ;
|
||||
|
||||
! These structs and words correspond to vm/layouts.hpp
|
||||
|
|
|
|||
Loading…
Reference in New Issue