95 lines
2.7 KiB
Factor
95 lines
2.7 KiB
Factor
! Copyright (C) 2015 - 2016 Björn Lindqvist
|
|
! See http://factorcode.org/license.txt for BSD license
|
|
USING: accessors alien.strings assocs classes fry graphviz
|
|
graphviz.attributes graphviz.notation math.bitwise sequences sets
|
|
system tools.image-analyzer.references tools.image-analyzer.utils
|
|
tools.image-analyzer.vm vocabs.parser ;
|
|
IN: tools.image-analyzer.graphviz
|
|
FROM: arrays => 1array 2array ;
|
|
FROM: byte-arrays => >byte-array ;
|
|
FROM: kernel => ? = 2drop bi bi* dup if keep nip object over swap tri with ;
|
|
FROM: math => <= - shift ;
|
|
|
|
<<
|
|
! 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
|
|
>>
|
|
|
|
: array>string ( array -- str )
|
|
0 suffix >byte-array alien>native-string ;
|
|
|
|
! Regular nodes
|
|
CONSTANT: node-colors {
|
|
{ alien "#aa5566" }
|
|
{ array "#999999" }
|
|
{ bignum "#cc3311" }
|
|
{ byte-array "#ffff00" }
|
|
{ code-block "#ffaaff" }
|
|
{ string "#aaddff" }
|
|
{ tuple "#abcdef" }
|
|
{ quotation "#449900" }
|
|
{ word "#00ffcc" }
|
|
{ wrapper "#ffaa77" }
|
|
}
|
|
|
|
: heap-node>color ( heap-node -- color )
|
|
object>> class-of node-colors at ;
|
|
|
|
: relativise-address ( image heap-node -- address )
|
|
swap [
|
|
[ address>> ] [ code-heap-node? ] bi
|
|
] [
|
|
header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
|
|
] bi* ? - ;
|
|
|
|
: 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-heap-nodes ( graph image -- graph )
|
|
dup heap>> [ heap-node>node add ] with each ;
|
|
|
|
! Root nodes
|
|
: <root-node> ( id -- node )
|
|
<node> "box" =shape ;
|
|
|
|
: add-root-node ( graph ptr index -- graph )
|
|
over 15 mask 1 <= [ 2drop ] [
|
|
[ swap untag add-edge ] keep <root-node> add
|
|
] if ;
|
|
|
|
: add-root-nodes ( graph image -- graph )
|
|
0 <cluster> swap
|
|
header>> special-objects>> [ add-root-node ] each-index
|
|
add ;
|
|
|
|
! Edges
|
|
: 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
|
|
members [ first2 = ] reject ;
|
|
|
|
: add-graphviz-edges ( graph edges -- graph )
|
|
[ first2 add-edge ] each ;
|
|
|
|
: add-edges ( graph image -- graph )
|
|
image>edges add-graphviz-edges ;
|
|
|
|
: <heap-graph> ( -- graph )
|
|
<digraph>
|
|
[graph "dot" =layout ];
|
|
<graph-attributes> "false" >>overlap add ;
|
|
|
|
: image>graph ( image -- graph )
|
|
<heap-graph> over add-heap-nodes over add-root-nodes swap add-edges ;
|