basis/optimizer/control/control.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays generic assocs inference inference.class
   4 inference.dataflow inference.backend inference.state io kernel
   5 math namespaces sequences vectors words quotations hashtables
   6 combinators classes classes.algebra generic.math continuations
   7 optimizer.def-use optimizer.backend generic.standard ;
   8 IN: optimizer.control
   9
  10 ! ! ! Rudimentary CFA
  11
  12 ! A LOOP
  13 !
  14 !          #label A
  15 !             |
  16 !            #if ----> #merge ----> #return
  17 !             |
  18 !       -------------
  19 !       |           |
  20 ! #call-label A     |
  21 !       |          ...
  22 !    #values
  23 !
  24 ! NOT A LOOP (call to A not in tail position):
  25 !
  26 !
  27 !          #label A
  28 !             |
  29 !            #if ----> ... ----> #merge ----> #return
  30 !             |
  31 !       -------------
  32 !       |           |
  33 ! #call-label A     |
  34 !       |          ...
  35 !      ...
  36 !       |
  37 !    #values
  38 !
  39 ! NOT A LOOP (call to A nested inside another label which is
  40 ! not a loop):
  41 !
  42 !
  43 !          #label A
  44 !             |
  45 !            #if ----> #merge ----> ... ----> #return
  46 !             |
  47 !       -------------
  48 !       |           |
  49 !      ...      #label B
  50 !                   |
  51 !                  #if -> ...
  52 !                   |
  53 !               ---------
  54 !               |       |
  55 !         #call-label A |
  56 !               |       |
  57 !           #values     |
  58 !                 #call-label B
  59 !                       |
  60 !                      ...
  61
  62 ! Mapping word => { node { nesting tail? }+ height }
  63 ! We record all calls to a label, their control nesting and
  64 ! whether it is a tail call or not
  65 SYMBOL: label-info
  66
  67 GENERIC: collect-label-info* ( node -- )
  68
  69 M: #label collect-label-info*
  70     [ V{ } clone node-stack get length 3array ] keep
  71     node-param label-info get set-at ;
  72
  73 M: #call-label collect-label-info*
  74     node-param label-info get at
  75     node-stack get over third tail
  76     [ [ #label? ] filter [ node-param ] map ] keep
  77     [ node-successor #tail? ] all? 2array
  78     swap second push ;
  79
  80 M: node collect-label-info*
  81     drop ;
  82
  83 : collect-label-info ( node -- )
  84     H{ } clone label-info set
  85     [ collect-label-info* ] each-node ;
  86
  87 ! Mapping word => label
  88 SYMBOL: potential-loops
  89
  90 : remove-non-tail-calls ( -- )
  91     label-info get
  92     [ nip second [ second ] all? ] assoc-filter
  93     [ first ] assoc-map
  94     potential-loops set ;
  95
  96 : remove-non-loop-calls ( -- )
  97     ! Boolean is set to t if something changed.
  98     !  We recurse until a fixed point is reached.
  99     f label-info get [
 100         ! If label X is called from within a label Y that is
 101         ! no longer a potential loop, then X is no longer a
 102         ! potential loop either.
 103         over potential-loops get key? [
 104             second [ first ] map concat
 105             potential-loops get [ key? ] curry all?
 106             [ drop ] [ potential-loops get delete-at t or ] if
 107         ] [ 2drop ] if
 108     ] assoc-each [ remove-non-loop-calls ] when ;
 109
 110 : detect-loops ( node -- node )
 111     [
 112         dup
 113         collect-label-info
 114         remove-non-tail-calls
 115         remove-non-loop-calls
 116         potential-loops get [
 117             nip t swap set-#label-loop?
 118         ] assoc-each
 119     ] with-scope ;
 120
 121 ! ! ! Constant branch folding
 122 !
 123 ! BEFORE
 124 !
 125 !      #if ----> #merge ----> C
 126 !       |
 127 !   ---------
 128 !   |       |
 129 !   A       B
 130 !   |       |
 131 ! #values   |
 132 !        #values
 133 !
 134 ! AFTER
 135 !
 136 !       |
 137 !       A
 138 !       |
 139 !    #values
 140 !       |
 141 !    #merge
 142 !       |
 143 !       C
 144
 145 : fold-branch ( node branch# -- node )
 146     over node-children nth
 147     swap node-successor over splice-node ;
 148
 149 ! #if
 150 : known-boolean-value? ( node value -- value ? )
 151     2dup node-literal? [
 152         node-literal t
 153     ] [
 154         node-class {
 155             { [ dup null class<= ] [ drop f f ] }
 156             { [ dup \ f class-not class<= ] [ drop t t ] }
 157             { [ dup \ f class<= ] [ drop f t ] }
 158             [ drop f f ]
 159         } cond
 160     ] if ;
 161
 162 : fold-if-branch? ( node -- value ? )
 163     dup node-in-d first known-boolean-value? ;
 164
 165 : fold-if-branch ( node value -- node' )
 166     over drop-inputs >r
 167     0 1 ? fold-branch
 168     r> [ set-node-successor ] keep ;
 169
 170 ! ! ! Lifting code after a conditional if one branch throws
 171
 172 ! BEFORE
 173 !
 174 !         #if ----> #merge ----> B ----> #return/#values
 175 !          |
 176 !          |
 177 !      ---------
 178 !      |       |
 179 !      |       A
 180 ! #terminate   |
 181 !           #values
 182 !
 183 ! AFTER
 184 !
 185 !         #if ----> #merge (*) ----> #return/#values (**)
 186 !          |
 187 !          |
 188 !      ---------
 189 !      |       |
 190 !      |       A
 191 ! #terminate   |
 192 !           #values
 193 !              |
 194 !           #merge (***)
 195 !              |
 196 !              B
 197 !              |
 198 !        #return/#values
 199 !
 200 ! (*) has the same outputs as the inputs of (**), and it is not
 201 ! the same node as (***)
 202 !
 203 ! Note: if (**) is #return is is sound to put #terminate there,
 204 ! but not if (**) is #
 205
 206 : only-one ( seq -- elt/f )
 207     dup length 1 = [ first ] [ drop f ] if ;
 208
 209 : lift-throw-tail? ( #if -- tail/? )
 210     dup node-successor #tail?
 211     [ drop f ] [ active-children only-one ] if ;
 212
 213 : clone-node ( node -- newnode )
 214     clone dup [ clone ] modify-values ;
 215
 216 : lift-branch ( node tail -- )
 217     over
 218     last-node clone-node
 219     dup node-in-d \ #merge out-node
 220     [ set-node-successor ] keep -rot
 221     >r dup node-successor r> splice-node
 222     set-node-successor ;
 223
 224 M: #if optimize-node*
 225     dup fold-if-branch? [ fold-if-branch t ] [
 226         drop dup lift-throw-tail? dup [
 227             dupd lift-branch t
 228         ] [
 229             2drop t f
 230         ] if
 231     ] if ;
 232
 233 ! Loop tail hoising: code after a loop can sometimes go in the
 234 ! non-recursive branch of the loop
 235
 236 ! BEFORE:
 237
 238 !   #label -> C -> #return 1
 239 !     |
 240 !     -> #if -> #merge (*) -> #return 2
 241 !         |
 242 !     --------
 243 !     |      |
 244 !     A      B
 245 !     |      |
 246 !  #values   |
 247 !        #call-label
 248 !            |
 249 !            |
 250 !         #values
 251
 252 ! AFTER:
 253
 254 !        #label -> #return 1
 255 !         |
 256 !         -> #if -------> #merge (*) -> #return 2
 257 !             |           \-------------------/
 258 !     ----------------              |
 259 !     |              |              |
 260 !     A              B     unreacachable code needed to
 261 !     |              |         preserve invariants
 262 !  #values           |
 263 !     |          #call-label
 264 !  #merge (*)        |
 265 !     |              |
 266 !     C           #values
 267 !     |
 268 !  #return 1
 269
 270 : find-tail ( node -- tail )
 271     dup #terminate? [
 272         dup node-successor #tail? [
 273             node-successor find-tail
 274         ] unless
 275     ] unless ;
 276
 277 : child-tails ( node -- seq )
 278     node-children [ find-tail ] map ;
 279
 280 GENERIC: add-loop-exit* ( label node -- )
 281
 282 M: #branch add-loop-exit*
 283     child-tails [ add-loop-exit* ] with each ;
 284
 285 M: #call-label add-loop-exit*
 286     tuck node-param eq? [ drop ] [ node-successor , ] if ;
 287
 288 M: #terminate add-loop-exit*
 289     2drop ;
 290
 291 M: node add-loop-exit*
 292     nip node-successor dup #terminate? [ drop ] [ , ] if ;
 293
 294 : find-loop-exits ( label node -- seq )
 295     [ add-loop-exit* ] { } make ;
 296
 297 : find-final-if ( node -- #if/f )
 298     dup [
 299         dup #if? [
 300             dup node-successor #tail? [
 301                 node-successor find-final-if
 302             ] unless
 303         ] [
 304             node-successor find-final-if
 305         ] if
 306     ] when ;
 307
 308 : detach-node-successor ( node -- successor )
 309     dup node-successor #terminate rot set-node-successor ;
 310
 311 : lift-loop-tail? ( #label -- tail/f )
 312     dup node-successor node-successor [
 313         dup node-param swap node-child find-final-if dup [
 314             find-loop-exits only-one
 315         ] [ 2drop f ] if
 316     ] [ drop f ] if ;
 317
 318 M: #loop optimize-node*
 319     dup lift-loop-tail? dup [
 320         last-node "values" set
 321
 322         dup node-successor "tail" set
 323         dup node-successor last-node "return" set
 324         dup node-child find-final-if node-successor "merge" set
 325
 326         ! #label -> #return
 327         "return" get clone-node over set-node-successor
 328         ! #merge -> C
 329         "merge" get clone-node "tail" get over set-node-successor
 330         ! #values -> #merge ->C
 331         "values" get set-node-successor
 332
 333         t
 334     ] [
 335         2drop t f
 336     ] if ;