1 ! Copyright (C) 2013 Björn Lindqvist
2 ! See http://factorcode.org/license.txt for BSD license
3 USING: accessors alien.strings assocs classes fry graphviz
4 graphviz.attributes graphviz.notation math.bitwise sequences
5 sets system tools.image-analyzer.references tools.image-analyzer.vm
7 IN: tools.image-analyzer.graphviz
8 FROM: arrays => 1array 2array ;
9 FROM: byte-arrays => >byte-array ;
10 FROM: kernel => ? = 2drop bi bi* dup if keep nip object over swap tri with ;
11 FROM: math => <= - shift ;
14 ! For the two annoying structs that differ on 32 and 64 bit.
16 "tools.image-analyzer.vm.32"
17 "tools.image-analyzer.vm.64"
21 : array>string ( array -- str )
22 0 suffix >byte-array alien>native-string ;
25 CONSTANT: node-colors {
29 { byte-array "#ffff00" }
30 { code-block "#ffaaff" }
33 { quotation "#449900" }
38 : heap-node>color ( heap-node -- color )
39 object>> class-of node-colors at ;
41 : relativise-address ( image heap-node -- address )
43 [ address>> ] [ code-heap-node? ] bi
45 header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
48 : heap-node>label ( image heap-node -- label )
49 dup object>> string? [
50 nip payload>> array>string
51 ] [ relativise-address ] if ;
53 : heap-node>node ( image heap-node -- node )
54 [ heap-node>label ] [ heap-node>color ] [ address>> ] tri
55 <node> swap =fillcolor swap =label "filled" =style ;
57 : add-heap-nodes ( graph image -- graph )
58 dup heap>> [ heap-node>node add ] with each ;
61 : <root-node> ( id -- node )
64 : add-root-node ( graph ptr index -- graph )
65 over 15 mask 1 <= [ 2drop ] [
66 [ swap 15 unmask add-edge ] keep <root-node> add
69 : add-root-nodes ( graph image -- graph )
71 header>> special-objects>> [ add-root-node ] each-index
75 : heap-node-edges ( heap heap-node -- seq )
76 [ collect-pointers ] keep address>> '[ _ swap 2array ] map ;
78 : image>edges ( image -- edges )
79 heap>> dup [ heap-node-edges ] with map concat
80 members [ first2 = ] reject ;
82 : add-graphviz-edges ( graph edges -- graph )
83 [ first2 add-edge ] each ;
85 : add-edges ( graph image -- graph )
86 image>edges add-graphviz-edges ;
88 : <heap-graph> ( -- graph )
90 [graph "dot" =layout ];
91 <graph-attributes> "false" >>overlap add ;
93 : image>graph ( image -- graph )
94 <heap-graph> over add-heap-nodes over add-root-nodes swap add-edges ;