-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.
? 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" }
{ code-block "#ffaaff" }
{ string "#aaddff" }
{ quotation "#449900" }
- { word "#00ff99" }
+ { word "#00ffcc" }
}
-: array>string ( array -- str )
- 0 suffix >byte-array alien>native-string ;
+: heap-node>color ( heap-node -- color )
+ object>> class-of node-colors at ;
-: 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 ;
+: relativise-address ( image heap-node -- address )
+ swap [
+ [ address>> ] [ code-heap-node? ] bi
+ ] [
+ header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
+ ] bi* ? - ;
-: heap-node>fill-color ( heap-node -- color )
- object>> class-of node-colors at ;
+: 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>node ( heap-node -- node )
- dup address>> <node>
- over heap-node>fill-color =fillcolor
- swap heap-node>label =label
- "filled" =style ;
+: heap-node-edges ( heap heap-node -- seq )
+ [ collect-pointers ] keep address>> '[ _ swap 2array ] map ;
-: add-edges ( graph edges -- graph )
+: 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 ;
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 ;
+++ /dev/null
-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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+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 + ;
{ 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
projects / factor.git / commitdiff