tools.image-analyzer.graphviz: new vocab for making graphs of the loaded heaps

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

@@ -0,0 +1,77 @@
+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 ;
+IN: tools.image-analyzer.graphviz
+FROM: arrays => 1array 2array ;
+FROM: byte-arrays => >byte-array ;
+FROM: kernel => object ;
+FROM: math => - ;
+
+<<
+! For the two annoying structs that differ on 32 and 64 bit.
+cpu x86.32?
+"tools.image-analyzer.vm.32"
+"tools.image-analyzer.vm.64"
+? 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 ;
+
+CONSTANT: node-colors {
+    { array "#999999" }
+    { bignum "#cc3311" }
+    { byte-array "#ffff00" }
+    { code-block "#ffaaff" }
+    { string "#aaddff" }
+    { quotation "#449900" }
+    { word "#00ff99" }
+}
+
+: 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 )
+    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 ;
+
+: add-edges ( graph edges -- graph )
+    [ first2 add-edge ] each ;
+
+: setup-graph ( graph -- graph )
+    [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 ;

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

@@ -6,10 +6,9 @@ HELP: load-image
 { $values
   { "image" string }
   { "header" image-header }
-  { "data-heap" sequence }
-  { "code-heap" sequence }
+  { "heap-nodes" sequence }
 }
-{ $description "Loads and decodes Factor image." } ;
+{ $description "Loads and decodes Factor image. The images header and a sequence of all Factor objects found in its data and code heaps are put on the stack." } ;
 
 ARTICLE: "tools.image-analyzer" "Loader for Factor images"
 "The " { $vocab-link "tools.image-analyzer" } " loads and decodes Factor images."

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

@@ -11,11 +11,11 @@ IN: tools.image-analyzer
 : data-heap>objects ( data-relocation-base data-heap -- seq )
     binary [ '[ _ read-object ] consume-stream>sequence ] with-byte-reader ;
 
-: load-image ( image -- header data-heap code-heap )
+: load-image ( image -- header heap-nodes )
     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 ;
+    ] with-file-reader append ;

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

@@ -0,0 +1,68 @@
+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 ;