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