basis/compiler/tree/debugger/debugger.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit compiler.tree compiler.tree.builder
   5 compiler.tree.checker compiler.tree.cleanup
   6 compiler.tree.combinators compiler.tree.dead-code
   7 compiler.tree.def-use compiler.tree.escape-analysis
   8 compiler.tree.identities compiler.tree.modular-arithmetic
   9 compiler.tree.normalization compiler.tree.optimizer
  10 compiler.tree.propagation compiler.tree.propagation.info
  11 compiler.tree.recursive compiler.tree.tuple-unboxing effects fry
  12 generic hints io kernel macros make match math namespaces
  13 prettyprint prettyprint.config prettyprint.custom
  14 prettyprint.sections quotations sequences sequences.private sets
  15 sorting words ;
  16 FROM: syntax => _ ;
  17 RENAME: _ match => __
  18 IN: compiler.tree.debugger
  19
  20 ! A simple tool for turning tree IR into quotations and
  21 ! printing reports, for debugging purposes.
  22
  23 GENERIC: node>quot ( node -- )
  24
  25 MACRO: match-choose ( alist -- quot )
  26     [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
  27
  28 MATCH-VARS: ?a ?b ?c ;
  29
  30 : pretty-shuffle ( effect -- word/f )
  31     [ in>> ] [ out>> ] bi 2array {
  32         { { { } { } } [ ] }
  33         { { { ?a } { ?a } } [ ] }
  34         { { { ?a ?b } { ?a ?b } } [ ] }
  35         { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
  36         { { { ?a } { } } [ drop ] }
  37         { { { ?a ?b } { } } [ 2drop ] }
  38         { { { ?a ?b ?c } { } } [ 3drop ] }
  39         { { { ?a } { ?a ?a } } [ dup ] }
  40         { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
  41         { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
  42         { { { ?a ?b } { ?a ?b ?a } } [ over ] }
  43         { { { ?b ?a } { ?a ?b } } [ swap ] }
  44         { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
  45         { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
  46         { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
  47         { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
  48         { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
  49         { { { ?a ?b } { ?b } } [ nip ] }
  50         { { { ?a ?b ?c } { ?c } } [ 2nip ] }
  51         { __ f }
  52     } match-choose ;
  53
  54 TUPLE: shuffle-node { effect effect } ;
  55
  56 M: shuffle-node pprint* effect>> effect>string text ;
  57
  58 : (shuffle-effect) ( in out #shuffle -- effect )
  59     mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
  60
  61 : shuffle-effect ( #shuffle -- effect )
  62     [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
  63
  64 : #>r? ( #shuffle -- ? )
  65     {
  66         [ in-d>> length 1 = ]
  67         [ out-r>> length 1 = ]
  68         [ in-r>> empty? ]
  69         [ out-d>> empty? ]
  70     } 1&& ;
  71
  72 : #r>? ( #shuffle -- ? )
  73     {
  74         [ in-d>> empty? ]
  75         [ out-r>> empty? ]
  76         [ in-r>> length 1 = ]
  77         [ out-d>> length 1 = ]
  78     } 1&& ;
  79
  80 SYMBOLS: >R R> ;
  81
  82 M: #shuffle node>quot
  83     {
  84         { [ dup #>r? ] [ drop \ >R , ] }
  85         { [ dup #r>? ] [ drop \ R> , ] }
  86         {
  87             [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
  88             [
  89                 shuffle-effect dup pretty-shuffle
  90                 [ % ] [ shuffle-node boa , ] ?if
  91             ]
  92         }
  93         [ drop "COMPLEX SHUFFLE" , ]
  94     } cond ;
  95
  96 M: #push node>quot literal>> literalize , ;
  97
  98 M: #call node>quot word>> , ;
  99
 100 M: #call-recursive node>quot label>> id>> , ;
 101
 102 DEFER: nodes>quot
 103
 104 DEFER: label
 105
 106 M: #recursive node>quot
 107     [ label>> id>> literalize , ]
 108     [ child>> nodes>quot , \ label , ]
 109     bi ;
 110
 111 M: #if node>quot
 112     children>> [ nodes>quot ] map % \ if , ;
 113
 114 M: #dispatch node>quot
 115     children>> [ nodes>quot ] map , \ dispatch , ;
 116
 117 M: #alien-invoke node>quot params>> , #alien-invoke , ;
 118
 119 M: #alien-indirect node>quot params>> , #alien-indirect , ;
 120
 121 M: #alien-assembly node>quot params>> , #alien-assembly , ;
 122
 123 M: #alien-callback node>quot
 124     [ params>> , ] [ child>> nodes>quot , ] bi #alien-callback , ;
 125
 126 M: node node>quot drop ;
 127
 128 : nodes>quot ( node -- quot )
 129     [ [ node>quot ] each ] [ ] make ;
 130
 131 GENERIC: optimized. ( quot/word -- )
 132
 133 M: word optimized. specialized-def optimized. ;
 134
 135 M: callable optimized.
 136     build-tree optimize-tree nodes>quot
 137     f length-limit [ . ] with-variable ;
 138
 139 SYMBOL: words-called
 140 SYMBOL: generics-called
 141 SYMBOL: methods-called
 142 SYMBOL: intrinsics-called
 143 SYMBOL: node-count
 144
 145 : make-report ( word/quot -- assoc )
 146     [
 147         build-tree optimize-tree
 148
 149         H{ } clone words-called ,,
 150         H{ } clone generics-called ,,
 151         H{ } clone methods-called ,,
 152         H{ } clone intrinsics-called ,,
 153
 154         0 swap [
 155             [ 1 + ] dip
 156             dup #call? [
 157                 word>> {
 158                     { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
 159                     { [ dup generic? ] [ generics-called ] }
 160                     { [ dup method? ] [ methods-called ] }
 161                     [ words-called ]
 162                 } cond building get at inc-at
 163             ] [ drop ] if
 164         ] each-node
 165         node-count ,,
 166     ] H{ } make ;
 167
 168 : report. ( report -- )
 169     [
 170         "==== Total number of IR 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     ] with-variables ;
 182
 183 : optimizer-report. ( word -- )
 184     make-report report. ;
 185
 186 ! More utilities
 187 : cleaned-up-tree ( quot -- nodes )
 188     [
 189         build-tree
 190         analyze-recursive
 191         normalize
 192         propagate
 193         cleanup-tree
 194         escape-analysis
 195         unbox-tuples
 196         apply-identities
 197         compute-def-use
 198         remove-dead-code
 199         compute-def-use
 200         optimize-modular-arithmetic
 201     ] with-scope ;
 202
 203 : inlined? ( quot seq/word -- ? )
 204     dup word? [ 1array ] when swap
 205     [ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make
 206     intersect empty? ;