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 fry match accessors namespaces make effects
   4 sequences sequences.private quotations generic macros arrays
   5 prettyprint prettyprint.backend prettyprint.sections math words
   6 combinators io sorting hints
   7 compiler.tree
   8 compiler.tree.builder
   9 compiler.tree.optimizer
  10 compiler.tree.combinators ;
  11 IN: compiler.tree.debugger
  12
  13 ! A simple tool for turning tree IR into quotations and
  14 ! printing reports, for debugging purposes.
  15
  16 GENERIC: node>quot ( node -- )
  17
  18 MACRO: match-choose ( alist -- )
  19     [ '[ , ] ] assoc-map '[ , match-cond ] ;
  20
  21 MATCH-VARS: ?a ?b ?c ;
  22
  23 : pretty-shuffle ( effect -- word/f )
  24     [ in>> ] [ out>> ] bi 2array {
  25         { { { } { } } [ ] }
  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 ] }
  45         { _ f }
  46     } match-choose ;
  47
  48 TUPLE: shuffle-node { effect effect } ;
  49
  50 M: shuffle-node pprint* effect>> effect>string text ;
  51
  52 M: #shuffle node>quot
  53     shuffle-effect dup pretty-shuffle
  54     [ % ] [ shuffle-node boa , ] ?if ;
  55
  56 M: #push node>quot literal>> , ;
  57
  58 M: #call node>quot word>> , ;
  59
  60 M: #call-recursive node>quot label>> id>> , ;
  61
  62 DEFER: nodes>quot
  63
  64 DEFER: label
  65
  66 M: #recursive node>quot
  67     [ label>> id>> literalize , ]
  68     [ child>> nodes>quot , \ label , ]
  69     bi ;
  70
  71 M: #if node>quot
  72     children>> [ nodes>quot ] map % \ if , ;
  73
  74 M: #dispatch node>quot
  75     children>> [ nodes>quot ] map , \ dispatch , ;
  76
  77 M: #>r node>quot
  78     [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
  79     <repetition> % ;
  80
  81 DEFER: rdrop
  82
  83 M: #r> node>quot
  84     [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
  85     <repetition> % ;
  86
  87 M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
  88
  89 M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
  90
  91 M: #alien-callback node>quot params>> , \ #alien-callback , ;
  92
  93 M: node node>quot drop ;
  94
  95 : nodes>quot ( node -- quot )
  96     [ [ node>quot ] each ] [ ] make ;
  97
  98 : optimized. ( quot/word -- )
  99     dup word? [ specialized-def ] when
 100     build-tree optimize-tree nodes>quot . ;
 101
 102 SYMBOL: words-called
 103 SYMBOL: generics-called
 104 SYMBOL: methods-called
 105 SYMBOL: intrinsics-called
 106 SYMBOL: node-count
 107
 108 : make-report ( word/quot -- assoc )
 109     [
 110         dup word? [ build-tree-from-word nip ] [ build-tree ] if
 111         optimize-tree
 112
 113         H{ } clone words-called set
 114         H{ } clone generics-called set
 115         H{ } clone methods-called set
 116         H{ } clone intrinsics-called set
 117
 118         0 swap [
 119             >r 1+ r>
 120             dup #call? [
 121                 word>> {
 122                     { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
 123                     { [ dup generic? ] [ generics-called ] }
 124                     { [ dup method-body? ] [ methods-called ] }
 125                     [ words-called ]
 126                 } cond 1 -rot get at+
 127             ] [ drop ] if
 128         ] each-node
 129         node-count set
 130     ] H{ } make-assoc ;
 131
 132 : report. ( report -- )
 133     [
 134         "==== Total number of IR nodes:" print
 135         node-count get .
 136
 137         {
 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:" }
 142         } [
 143             nl print get keys natural-sort stack.
 144         ] assoc-each
 145     ] bind ;
 146
 147 : optimizer-report. ( word -- )
 148     make-report report. ;