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

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