1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel assocs fry match accessors namespaces effects
4 sequences sequences.private quotations generic macros arrays
5 prettyprint prettyprint.backend prettyprint.sections math words
6 combinators io sorting hints
9 compiler.tree.optimizer
10 compiler.tree.combinators ;
11 IN: compiler.tree.debugger
13 ! A simple tool for turning tree IR into quotations and
14 ! printing reports, for debugging purposes.
16 GENERIC: node>quot ( node -- )
18 MACRO: match-choose ( alist -- )
19 [ '[ , ] ] assoc-map '[ , match-cond ] ;
21 MATCH-VARS: ?a ?b ?c ;
23 : pretty-shuffle ( effect -- word/f )
24 [ in>> ] [ out>> ] bi 2array {
26 { { { ?a } { ?a } } [ ] }
27 { { { ?a ?b } { ?a ?b } } [ ] }
28 { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
29 { { { ?a } { } } [ drop ] }
30 { { { ?a ?b } { } } [ 2drop ] }
31 { { { ?a ?b ?c } { } } [ 3drop ] }
32 { { { ?a } { ?a ?a } } [ dup ] }
33 { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
34 { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
35 { { { ?a ?b } { ?a ?b ?a } } [ over ] }
36 { { { ?b ?a } { ?a ?b } } [ swap ] }
37 { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
38 { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
39 { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
40 { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
41 { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
42 { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
43 { { { ?a ?b } { ?b } } [ nip ] }
44 { { { ?a ?b ?c } { ?c } } [ 2nip ] }
48 TUPLE: shuffle-node { effect effect } ;
50 M: shuffle-node pprint* effect>> effect>string text ;
53 shuffle-effect dup pretty-shuffle
54 [ % ] [ shuffle-node boa , ] ?if ;
56 M: #push node>quot literal>> , ;
58 M: #call node>quot word>> , ;
60 M: #call-recursive node>quot label>> id>> , ;
66 M: #recursive node>quot
67 [ label>> id>> literalize , ]
68 [ child>> nodes>quot , \ label , ]
72 children>> [ nodes>quot ] map % \ if , ;
74 M: #dispatch node>quot
75 children>> [ nodes>quot ] map , \ dispatch , ;
78 [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
84 [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
87 M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
89 M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
91 M: #alien-callback node>quot params>> , \ #alien-callback , ;
93 M: node node>quot drop ;
95 : nodes>quot ( node -- quot )
96 [ [ node>quot ] each ] [ ] make ;
98 : optimized. ( quot/word -- )
99 dup word? [ specialized-def ] when
100 build-tree optimize-tree nodes>quot . ;
103 SYMBOL: generics-called
104 SYMBOL: methods-called
105 SYMBOL: intrinsics-called
108 : make-report ( word/quot -- assoc )
110 dup word? [ build-tree-from-word nip ] [ build-tree ] if
113 H{ } clone words-called set
114 H{ } clone generics-called set
115 H{ } clone methods-called set
116 H{ } clone intrinsics-called set
122 { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
123 { [ dup generic? ] [ generics-called ] }
124 { [ dup method-body? ] [ methods-called ] }
126 } cond 1 -rot get at+
132 : report. ( report -- )
134 "==== Total number of IR nodes:" print
138 { generics-called "==== Generic word calls:" }
139 { words-called "==== Ordinary word calls:" }
140 { methods-called "==== Non-inlined method calls:" }
141 { intrinsics-called "==== Open-coded intrinsic calls:" }
143 nl print get keys natural-sort stack.
147 : optimizer-report. ( word -- )
148 make-report report. ;