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