extra/optimizer/debugger/debugger.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes inference inference.dataflow io kernel
   4 kernel.private math.parser namespaces optimizer prettyprint
   5 prettyprint.backend sequences words arrays match macros
   6 assocs sequences.private optimizer.specializers generic
   7 combinators sorting math quotations accessors ;
   8 IN: optimizer.debugger
   9
  10 ! A simple tool for turning dataflow IR into quotations, for
  11 ! debugging purposes.
  12
  13 GENERIC: node>quot ( ? node -- )
  14
  15 TUPLE: comment node text ;
  16
  17 M: comment pprint*
  18     "( " over comment-text " )" 3append
  19     swap comment-node present-text ;
  20
  21 : comment, ( ? node text -- )
  22     rot [ \ comment boa , ] [ 2drop ] if ;
  23
  24 : values% ( prefix values -- )
  25     swap [
  26         %
  27         dup value? [
  28             value-literal unparse %
  29         ] [
  30             "@" % unparse %
  31         ] if
  32     ] curry each ;
  33
  34 : effect-str ( node -- str )
  35     [
  36         " " over in-d>> values%
  37         " r: " over in-r>> values%
  38         " --" %
  39         " " over out-d>> values%
  40         " r: " swap out-r>> values%
  41     ] "" make rest ;
  42
  43 MACRO: match-choose ( alist -- )
  44     [ [ ] curry ] assoc-map [ match-cond ] curry ;
  45
  46 MATCH-VARS: ?a ?b ?c ;
  47
  48 : pretty-shuffle ( in out -- word/f )
  49     2array {
  50         { { { ?a } { } } drop }
  51         { { { ?a ?b } { } } 2drop }
  52         { { { ?a ?b ?c } { } } 3drop }
  53         { { { ?a } { ?a ?a } } dup }
  54         { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
  55         { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
  56         { { { ?a ?b } { ?a ?b ?a } } over }
  57         { { { ?b ?a } { ?a ?b } } swap }
  58         { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
  59         { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
  60         { { { ?a ?b ?c } { ?b ?c ?a } } rot }
  61         { { { ?a ?b } { ?b } } nip }
  62         { _ f }
  63     } match-choose ;
  64
  65 M: #shuffle node>quot
  66     dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
  67     [ , ] [ >r drop t r> ] if*
  68     dup effect-str "#shuffle: " prepend comment, ;
  69
  70 : pushed-literals ( node -- seq )
  71     out-d>> [ value-literal literalize ] map ;
  72
  73 M: #push node>quot nip pushed-literals % ;
  74
  75 DEFER: dataflow>quot
  76
  77 : #call>quot ( ? node -- )
  78     dup param>> dup ,
  79     [ dup effect-str ] [ "empty call" ] if comment, ;
  80
  81 M: #call node>quot #call>quot ;
  82
  83 M: #call-label node>quot #call>quot ;
  84
  85 M: #label node>quot
  86     [
  87         dup param>> literalize ,
  88         dup #label-loop? "#loop: " "#label: " ?
  89         over param>> name>> append comment,
  90     ] 2keep
  91     node-child swap dataflow>quot , \ call ,  ;
  92
  93 M: #if node>quot
  94     [ "#if" comment, ] 2keep
  95     children>> swap [ dataflow>quot ] curry map %
  96     \ if , ;
  97
  98 M: #dispatch node>quot
  99     [ "#dispatch" comment, ] 2keep
 100     children>> swap [ dataflow>quot ] curry map ,
 101     \ dispatch , ;
 102
 103 M: #>r node>quot nip in-d>> length \ >r <array> % ;
 104
 105 M: #r> node>quot nip out-d>> length \ r> <array> % ;
 106
 107 M: object node>quot
 108     [
 109         dup class name>> %
 110         " " %
 111         dup param>> unparse %
 112         " " %
 113         dup effect-str %
 114     ] "" make comment, ;
 115
 116 : (dataflow>quot) ( ? node -- )
 117     dup [
 118         2dup node>quot successor>> (dataflow>quot)
 119     ] [
 120         2drop
 121     ] if ;
 122
 123 : dataflow>quot ( node ? -- quot )
 124     [ swap (dataflow>quot) ] [ ] make ;
 125
 126 : optimized-quot. ( quot ? -- )
 127     #! Print dataflow IR for a quotation. Flag indicates if
 128     #! annotations should be printed or not.
 129     >r dataflow optimize r> dataflow>quot pprint nl ;
 130
 131 : optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
 132
 133 SYMBOL: words-called
 134 SYMBOL: generics-called
 135 SYMBOL: methods-called
 136 SYMBOL: intrinsics-called
 137 SYMBOL: node-count
 138
 139 : dataflow>report ( node -- alist )
 140     [
 141         H{ } clone words-called set
 142         H{ } clone generics-called set
 143         H{ } clone methods-called set
 144         H{ } clone intrinsics-called set
 145
 146         0 swap [
 147             >r 1+ r>
 148             dup #call? [
 149                 param>> {
 150                     { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
 151                     { [ dup generic? ] [ generics-called ] }
 152                     { [ dup method-body? ] [ methods-called ] }
 153                     [ words-called ]
 154                 } cond 1 -rot get at+
 155             ] [
 156                 drop
 157             ] if
 158         ] each-node
 159         node-count set
 160     ] H{ } make-assoc ;
 161
 162 : quot-optimize-report ( quot -- report )
 163     dataflow optimize dataflow>report ;
 164
 165 : word-optimize-report ( word -- report )
 166     def>> quot-optimize-report ;
 167
 168 : report. ( report -- )
 169     [
 170         "==== Total number of dataflow nodes:" print
 171         node-count get .
 172
 173         {
 174             { generics-called "==== Generic word calls:" }
 175             { words-called "==== Ordinary word calls:" }
 176             { methods-called "==== Non-inlined method calls:" }
 177             { intrinsics-called "==== Open-coded intrinsic calls:" }
 178         } [
 179             nl print get keys natural-sort stack.
 180         ] assoc-each
 181     ] bind ;
 182
 183 : optimizer-report. ( word -- )
 184     word-optimize-report report. ;