--- /dev/null
+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 ;
{ $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."
: 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 ;
--- /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 ;