basis/compiler/tree/normalization/normalization.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry namespaces sequences math accessors kernel arrays
   4 combinators sequences.deep assocs
   5 stack-checker.backend
   6 stack-checker.branches
   7 stack-checker.inlining
   8 compiler.tree
   9 compiler.tree.combinators ;
  10 IN: compiler.tree.normalization
  11
  12 ! A transform pass done before optimization can begin to
  13 ! fix up some oddities in the tree output by the stack checker:
  14 !
  15 ! - We rewrite the code so that all #introduce nodes are
  16 ! replaced with a single one, at the beginning of a program.
  17 ! This simplifies subsequent analysis.
  18 !
  19 ! - We collect #return-recursive and #call-recursive nodes and
  20 ! store them in the #recursive's label slot.
  21 !
  22 ! - We normalize #call-recursive as follows. The stack checker
  23 ! says that the inputs of a #call-recursive are the entire stack
  24 ! at the time of the call. This is a conservative estimate; we
  25 ! don't know the exact number of stack values it touches until
  26 ! the #return-recursive node has been visited, because of row
  27 ! polymorphism. So in the normalize pass, we split a
  28 ! #call-recursive into a #copy of the unchanged values and a
  29 ! #call-recursive with trimmed inputs and outputs.
  30
  31 ! Collect introductions
  32 SYMBOL: introductions
  33
  34 GENERIC: count-introductions* ( node -- )
  35
  36 : count-introductions ( nodes -- n )
  37     #! Note: we use each, not each-node, since the #branch
  38     #! method recurses into children directly and we don't
  39     #! recurse into #recursive at all.
  40     [
  41         0 introductions set
  42         [ count-introductions* ] each
  43         introductions get
  44     ] with-scope ;
  45
  46 : introductions+ ( n -- ) introductions [ + ] change ;
  47
  48 M: #introduce count-introductions*
  49     out-d>> length introductions+ ;
  50
  51 M: #branch count-introductions*
  52     children>>
  53     [ count-introductions ] map supremum
  54     introductions+ ;
  55
  56 M: #recursive count-introductions*
  57     [ label>> ] [ child>> count-introductions ] bi
  58     >>introductions
  59     drop ;
  60
  61 M: node count-introductions* drop ;
  62
  63 ! Collect label info
  64 GENERIC: collect-label-info ( node -- )
  65
  66 M: #return-recursive collect-label-info
  67     dup label>> (>>return) ;
  68
  69 M: #call-recursive collect-label-info
  70     dup label>> calls>> push ;
  71
  72 M: #recursive collect-label-info
  73     label>> V{ } clone >>calls drop ;
  74
  75 M: node collect-label-info drop ;
  76
  77 ! Rename
  78 SYMBOL: rename-map
  79
  80 : rename-value ( value -- value' )
  81     [ rename-map get at ] keep or ;
  82
  83 : rename-values ( values -- values' )
  84     rename-map get '[ [ , at ] keep or ] map ;
  85
  86 GENERIC: rename-node-values* ( node -- node )
  87
  88 M: #introduce rename-node-values* ;
  89
  90 M: #shuffle rename-node-values*
  91     [ rename-values ] change-in-d
  92     [ [ rename-value ] assoc-map ] change-mapping ;
  93
  94 M: #push rename-node-values* ;
  95
  96 M: #r> rename-node-values*
  97     [ rename-values ] change-in-r ;
  98
  99 M: #terminate rename-node-values*
 100     [ rename-values ] change-in-d
 101     [ rename-values ] change-in-r ;
 102
 103 M: #phi rename-node-values*
 104     [ [ rename-values ] map ] change-phi-in-d ;
 105
 106 M: #declare rename-node-values*
 107     [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
 108
 109 M: #alien-callback rename-node-values* ;
 110
 111 M: node rename-node-values*
 112     [ rename-values ] change-in-d ;
 113
 114 : rename-node-values ( nodes -- nodes' )
 115     dup [ rename-node-values* drop ] each-node ;
 116
 117 ! Normalize
 118 GENERIC: normalize* ( node -- node' )
 119
 120 SYMBOL: introduction-stack
 121
 122 : pop-introduction ( -- value )
 123     introduction-stack [ unclip-last swap ] change ;
 124
 125 : pop-introductions ( n -- values )
 126     introduction-stack [ swap cut* swap ] change ;
 127
 128 : add-renamings ( old new -- )
 129     [ rename-values ] dip
 130     rename-map get '[ , set-at ] 2each ;
 131
 132 M: #introduce normalize*
 133     out-d>> [ length pop-introductions ] keep add-renamings f ;
 134
 135 SYMBOL: remaining-introductions
 136
 137 M: #branch normalize*
 138     [
 139         [
 140             [
 141                 [ normalize* ] map flatten
 142                 introduction-stack get
 143                 2array
 144             ] with-scope
 145         ] map unzip swap
 146     ] change-children swap
 147     [ remaining-introductions set ]
 148     [ [ length ] map infimum introduction-stack [ swap head ] change ]
 149     bi ;
 150
 151 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
 152     [
 153         [ nip ] [
 154             dup [ +bottom+ eq? ] trim-left
 155             [ [ length ] bi@ - tail* ] keep append
 156         ] if
 157     ] 3map ;
 158
 159 M: #phi normalize*
 160     remaining-introductions get swap dup terminated>>
 161     '[ , eliminate-phi-introductions ] change-phi-in-d ;
 162
 163 : (normalize) ( nodes introductions -- nodes )
 164     introduction-stack [
 165         [ normalize* ] map flatten
 166     ] with-variable ;
 167
 168 M: #recursive normalize*
 169     dup label>> introductions>>
 170     [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
 171     [ make-values '[ , (normalize) ] change-child ]
 172     2bi ;
 173
 174 M: #enter-recursive normalize*
 175     [ introduction-stack get prepend ] change-out-d
 176     dup [ label>> ] keep >>enter-recursive drop
 177     dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
 178
 179 : unchanged-underneath ( #call-recursive -- n )
 180     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 181
 182 : call<return ( #call-recursive n -- nodes )
 183     neg dup make-values [
 184         [ pop-introductions '[ , prepend ] change-in-d ]
 185         [ '[ , prepend ] change-out-d ]
 186         bi*
 187     ] [ introduction-stack [ prepend ] change ] bi ;
 188
 189 : call>return ( #call-recursive n -- #call-recursive )
 190     [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
 191     [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
 192     2bi ;
 193
 194 M: #call-recursive normalize*
 195     dup unchanged-underneath {
 196         { [ dup 0 < ] [ call<return ] }
 197         { [ dup 0 = ] [ drop ] }
 198         { [ dup 0 > ] [ call>return ] }
 199     } cond ;
 200
 201 M: node normalize* ;
 202
 203 : normalize ( nodes -- nodes' )
 204     H{ } clone rename-map set
 205     dup [ collect-label-info ] each-node
 206     dup count-introductions make-values
 207     [ (normalize) ] [ nip ] 2bi
 208     [ #introduce prefix ] unless-empty
 209     rename-node-values ;