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

   1 USING: accessors alien.strings assocs classes fry graphviz
   2 graphviz.attributes graphviz.notation kernel sequences system
   3 tools.image-analyzer.references tools.image-analyzer.vm vocabs.parser ;
   4 IN: tools.image-analyzer.graphviz
   5 FROM: arrays => 1array 2array ;
   6 FROM: byte-arrays => >byte-array ;
   7 FROM: kernel => object ;
   8 FROM: math => <= - shift ;
   9
  10 <<
  11 ! For the two annoying structs that differ on 32 and 64 bit.
  12 cpu x86.32?
  13 "tools.image-analyzer.vm.32"
  14 "tools.image-analyzer.vm.64"
  15 ? use-vocab
  16 >>
  17
  18 : array>string ( array -- str )
  19     0 suffix >byte-array alien>native-string ;
  20
  21 CONSTANT: node-colors {
  22     { array "#999999" }
  23     { bignum "#cc3311" }
  24     { byte-array "#ffff00" }
  25     { code-block "#ffaaff" }
  26     { string "#aaddff" }
  27     { quotation "#449900" }
  28     { word "#00ffcc" }
  29 }
  30
  31 : heap-node>color ( heap-node -- color )
  32     object>> class-of node-colors at ;
  33
  34 : relativise-address ( image heap-node -- address )
  35     swap [
  36         [ address>> ] [ code-heap-node? ] bi
  37     ] [
  38         header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
  39     ] bi* ? - ;
  40
  41 : heap-node>label ( image heap-node -- label )
  42     dup object>> string? [
  43         nip payload>> array>string
  44     ] [ relativise-address ] if ;
  45
  46 : heap-node>node ( image heap-node -- node )
  47     [ heap-node>label ] [ heap-node>color ] [ address>> ] tri
  48     <node> swap =fillcolor swap =label "filled" =style ;
  49
  50 : add-nodes ( graph image -- graph )
  51     dup heap>> [ heap-node>node add ] with each ;
  52
  53 : heap-node-edges ( heap heap-node -- seq )
  54     [ collect-pointers ] keep address>> '[ _ swap 2array ] map ;
  55
  56 : image>edges ( image -- edges )
  57     heap>> dup [ heap-node-edges ] with map concat ;
  58
  59 : add-graphviz-edges ( graph edges -- graph )
  60     [ first2 add-edge ] each ;
  61
  62 : add-edges ( graph image -- graph )
  63     image>edges add-graphviz-edges ;
  64
  65 : <heap-graph> ( -- graph )
  66     <digraph>
  67     [graph "neato" =layout ];
  68     <graph-attributes> "false" >>overlap add ;
  69
  70 : image>graph ( image -- graph )
  71     <heap-graph> over add-nodes swap add-edges ;