basis/compiler/tree/debugger/debugger.factor

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