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

   1 ! Copyright (C) 2015 - 2016 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 sets
   5 system tools.image-analyzer.references tools.image-analyzer.utils
   6 tools.image-analyzer.vm vocabs.parser vocabs.platforms ;
   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 ;
  12
  13 USE-X86-64: tools.image-analyzer.vm.64
  14 USE-X86-32: tools.image-analyzer.vm.32
  15
  16 : array>string ( array -- str )
  17     0 suffix >byte-array alien>native-string ;
  18
  19 ! Regular nodes
  20 CONSTANT: node-colors {
  21     { alien "#aa5566" }
  22     { array "#999999" }
  23     { bignum "#cc3311" }
  24     { byte-array "#ffff00" }
  25     { code-block "#ffaaff" }
  26     { string "#aaddff" }
  27     { tuple "#abcdef" }
  28     { quotation "#449900" }
  29     { word "#00ffcc" }
  30     { wrapper "#ffaa77" }
  31 }
  32
  33 : heap-node>color ( heap-node -- color )
  34     object>> class-of node-colors at ;
  35
  36 : relativise-address ( image heap-node -- address )
  37     swap [
  38         [ address>> ] [ code-heap-node? ] bi
  39     ] [
  40         header>> [ code-relocation-base>> ] [ data-relocation-base>> ] bi
  41     ] bi* ? - ;
  42
  43 : heap-node>label ( image heap-node -- label )
  44     dup object>> string? [
  45         nip payload>> array>string
  46     ] [ relativise-address ] if ;
  47
  48 : heap-node>node ( image heap-node -- node )
  49     [ heap-node>label ] [ heap-node>color ] [ address>> ] tri
  50     <node> swap =fillcolor swap =label "filled" =style ;
  51
  52 : add-heap-nodes ( graph image -- graph )
  53     dup heap>> [ heap-node>node add ] with each ;
  54
  55 ! Root nodes
  56 : <root-node> ( id -- node )
  57     <node> "box" =shape ;
  58
  59 : add-root-node ( graph ptr index -- graph )
  60     over 15 mask 1 <= [ 2drop ] [
  61         [ swap untag add-edge ] keep <root-node> add
  62     ] if ;
  63
  64 : add-root-nodes ( graph image -- graph )
  65     0 <cluster> swap
  66     header>> special-objects>> [ add-root-node ] each-index
  67     add ;
  68
  69 ! Edges
  70 : heap-node-edges ( heap heap-node -- seq )
  71     [ collect-pointers ] keep address>> '[ _ swap 2array ] map ;
  72
  73 : image>edges ( image -- edges )
  74     heap>> dup [ heap-node-edges ] with map concat
  75     members [ first2 = ] reject ;
  76
  77 : add-graphviz-edges ( graph edges -- graph )
  78     [ first2 add-edge ] each ;
  79
  80 : add-edges ( graph image -- graph )
  81     image>edges add-graphviz-edges ;
  82
  83 : <heap-graph> ( -- graph )
  84     <digraph>
  85     [graph "dot" =layout ];
  86     <graph-attributes> "false" >>overlap add ;
  87
  88 : image>graph ( image -- graph )
  89     <heap-graph> over add-heap-nodes over add-root-nodes swap add-edges ;