tools.image-analyzer: now relocation pointers are decoded too -> nicer graphs

extra/tools/image-analyzer/graphviz/graphviz.factor

@@ -1,12 +1,11 @@
-USING: accessors alien.strings assocs classes graphviz
+USING: accessors alien.strings assocs classes fry graphviz
-graphviz.attributes graphviz.notation kernel math.parser sequences
+graphviz.attributes graphviz.notation kernel sequences system
-slots.syntax system tools.image-analyzer
+tools.image-analyzer.references tools.image-analyzer.vm vocabs.parser ;
-tools.image-analyzer.ref-fixer 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 )
+: array>string ( array -- str )
-
+    0 suffix >byte-array alien>native-string ;
-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 ;
 
 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 )
+: heap-node>color ( heap-node -- color )
-    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 )
     object>> class-of node-colors at ;
 
-: heap-node>node ( heap-node -- node )
+: relativise-address ( image heap-node -- address )
-    dup address>> <node>
+    swap [
-    over heap-node>fill-color =fillcolor
+        [ address>> ] [ code-heap-node? ] bi
-    swap heap-node>label =label
+    ] [
-    "filled" =style ;
+        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 )
+: image>graph ( image -- graph )
-    dup <digraph> setup-graph
+    <heap-graph> over add-nodes swap add-edges ;
-    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 ;

extra/tools/image-analyzer/image-analyzer.factor

@@ -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 ;

extra/tools/image-analyzer/ref-fixer/ref-fixer.factor

@@ -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 ;

extra/tools/image-analyzer/references/references.factor

@@ -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 ;

extra/tools/image-analyzer/relocations/relocations.factor

@@ -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 + ;

extra/tools/image-analyzer/vm/vm.factor

@@ -9,10 +9,10 @@ STRUCT: image-header
     { data-size cell_t }
     { code-relocation-base cell_t }
     { code-size cell_t }
-    { true-object cell_t }
+    { reserved-1 cell_t }
-    { bignum-zero cell_t }
+    { reserved-2 cell_t }
-    { bignum-pos-one cell_t }
+    { reserved-3 cell_t }
-    { bignum-neg-one cell_t }
+    { reserved-4 cell_t }
     { special-objects cell_t[special-object-count] } ;
 
 ! These structs and words correspond to vm/layouts.hpp