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.cleanup compiler.tree.combinators
6 compiler.tree.dead-code compiler.tree.def-use
7 compiler.tree.escape-analysis compiler.tree.identities
8 compiler.tree.modular-arithmetic compiler.tree.normalization
9 compiler.tree.optimizer compiler.tree.propagation
10 compiler.tree.recursive compiler.tree.tuple-unboxing effects
11 generic hints io kernel make match math namespaces prettyprint
12 prettyprint.config prettyprint.custom prettyprint.sections
13 quotations sequences sequences.private sets sorting words ;
16 IN: compiler.tree.debugger
18 ! A simple tool for turning tree IR into quotations and
19 ! printing reports, for debugging purposes.
21 GENERIC: node>quot ( node -- )
23 MACRO: match-choose ( alist -- quot )
24 [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
26 MATCH-VARS: ?a ?b ?c ;
28 : pretty-shuffle ( effect -- word/f )
29 [ in>> ] [ out>> ] bi 2array {
31 { { { ?a } { ?a } } [ ] }
32 { { { ?a ?b } { ?a ?b } } [ ] }
33 { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
34 { { { ?a } { } } [ drop ] }
35 { { { ?a ?b } { } } [ 2drop ] }
36 { { { ?a ?b ?c } { } } [ 3drop ] }
37 { { { ?a } { ?a ?a } } [ dup ] }
38 { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
39 { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
40 { { { ?a ?b } { ?a ?b ?a } } [ over ] }
41 { { { ?b ?a } { ?a ?b } } [ swap ] }
42 { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
43 { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
44 { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
45 { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
46 { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
47 { { { ?a ?b } { ?b } } [ nip ] }
48 { { { ?a ?b ?c } { ?c } } [ 2nip ] }
52 TUPLE: shuffle-node { effect effect } ;
54 M: shuffle-node pprint* effect>> effect>string text ;
56 : (shuffle-effect) ( in out #shuffle -- effect )
57 mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
59 : shuffle-effect ( #shuffle -- effect )
60 [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
62 : #>r? ( #shuffle -- ? )
65 [ out-r>> length 1 = ]
70 : #r>? ( #shuffle -- ? )
75 [ out-d>> length 1 = ]
82 { [ dup #>r? ] [ drop \ >R , ] }
83 { [ dup #r>? ] [ drop \ R> , ] }
85 [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
87 shuffle-effect dup pretty-shuffle
88 [ % ] [ shuffle-node boa , ] ?if
91 [ drop "COMPLEX SHUFFLE" , ]
94 M: #push node>quot literal>> literalize , ;
96 M: #call node>quot word>> , ;
98 M: #call-recursive node>quot label>> id>> , ;
104 M: #recursive node>quot
105 [ label>> id>> literalize , ]
106 [ child>> nodes>quot , \ label , ]
110 children>> [ nodes>quot ] map % \ if , ;
112 M: #dispatch node>quot
113 children>> [ nodes>quot ] map , \ dispatch , ;
115 M: #alien-invoke node>quot params>> , #alien-invoke , ;
117 M: #alien-indirect node>quot params>> , #alien-indirect , ;
119 M: #alien-assembly node>quot params>> , #alien-assembly , ;
121 M: #alien-callback node>quot
122 [ params>> , ] [ child>> nodes>quot , ] bi #alien-callback , ;
124 M: node node>quot drop ;
126 : nodes>quot ( node -- quot )
127 [ [ node>quot ] each ] [ ] make ;
129 GENERIC: optimized. ( quot/word -- )
131 M: word optimized. specialized-def optimized. ;
133 M: callable optimized.
134 build-tree optimize-tree nodes>quot
135 f length-limit [ . ] with-variable ;
138 SYMBOL: generics-called
139 SYMBOL: methods-called
140 SYMBOL: intrinsics-called
143 : make-report ( word/quot -- assoc )
145 build-tree optimize-tree
147 H{ } clone words-called ,,
148 H{ } clone generics-called ,,
149 H{ } clone methods-called ,,
150 H{ } clone intrinsics-called ,,
156 { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
157 { [ dup generic? ] [ generics-called ] }
158 { [ dup method? ] [ methods-called ] }
160 } cond building get at inc-at
166 : report. ( report -- )
168 "==== Total number of IR nodes:" print
172 { generics-called "==== Generic word calls:" }
173 { words-called "==== Ordinary word calls:" }
174 { methods-called "==== Non-inlined method calls:" }
175 { intrinsics-called "==== Open-coded intrinsic calls:" }
177 nl print get keys natural-sort stack.
181 : optimizer-report. ( word -- )
182 make-report report. ;
185 : cleaned-up-tree ( quot -- nodes )
198 optimize-modular-arithmetic
201 : inlined? ( quot seq/word -- ? )
202 dup word? [ 1array ] when swap
203 [ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make