basis/compiler/cfg/stack-analysis/stack-analysis.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs kernel namespaces math sequences fry deques grouping
   4 search-deques dlists sets make combinators compiler.cfg.copy-prop
   5 compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
   6 compiler.cfg.rpo compiler.cfg.hats ;
   7 IN: compiler.cfg.stack-analysis
   8
   9 ! Convert stack operations to register operations
  10
  11 ! If 'poisoned' is set, disregard height information. This is set if we don't have
  12 ! height change information for an instruction.
  13 TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ;
  14
  15 : <state> ( -- state )
  16     state new
  17         H{ } clone >>locs>vregs
  18         H{ } clone >>vregs>locs
  19         H{ } clone >>changed-locs
  20         0 >>d-height
  21         0 >>r-height ;
  22
  23 M: state clone
  24     call-next-method
  25         [ clone ] change-locs>vregs
  26         [ clone ] change-vregs>locs
  27         [ clone ] change-changed-locs ;
  28
  29 : loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
  30
  31 : record-peek ( dst loc -- )
  32     state get
  33     [ locs>vregs>> set-at ]
  34     [ swapd vregs>locs>> set-at ]
  35     3bi ;
  36
  37 : delete-old-vreg ( loc -- )
  38     state get locs>vregs>> at [ state get vregs>locs>> delete-at ] when* ;
  39
  40 : changed-loc ( loc -- )
  41     state get changed-locs>> conjoin ;
  42
  43 : redundant-replace? ( src loc -- ? )
  44     loc>vreg = ;
  45
  46 : record-replace ( src loc -- )
  47     ! Locs are not single assignment, which means we have to forget
  48     ! that the previous vreg, if any, points at this loc. Also, record
  49     ! that the loc changed so that all the right ##replace instructions
  50     ! are emitted at a sync point.
  51     2dup redundant-replace? [ 2drop ] [
  52         dup delete-old-vreg dup changed-loc record-peek
  53     ] if ;
  54
  55 : save-changed-locs ( state -- )
  56     [ changed-locs>> ] [ locs>vregs>> ] bi '[
  57         _ at swap 2dup redundant-replace?
  58         [ 2drop ] [ ##replace ] if
  59     ] assoc-each ;
  60
  61 : clear-state ( state -- )
  62     {
  63         [ 0 >>d-height drop ]
  64         [ 0 >>r-height drop ]
  65         [ changed-locs>> clear-assoc ]
  66         [ locs>vregs>> clear-assoc ]
  67         [ vregs>locs>> clear-assoc ]
  68     } cleave ;
  69
  70 ERROR: poisoned-state state ;
  71
  72 : sync-state ( -- )
  73     state get {
  74         [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
  75         [ save-changed-locs ]
  76         [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ]
  77         [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ]
  78         [ clear-state ]
  79     } cleave ;
  80
  81 : poison-state ( -- ) state get t >>poisoned? drop ;
  82
  83 GENERIC: translate-loc ( loc -- loc' )
  84
  85 M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
  86
  87 M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
  88
  89 ! Abstract interpretation
  90 GENERIC: visit ( insn -- )
  91
  92 ! Instructions which don't have any effect on the stack
  93 UNION: neutral-insn
  94     ##flushable
  95     ##effect
  96     ##branch
  97     ##loop-entry
  98     ##conditional-branch ;
  99
 100 M: neutral-insn visit , ;
 101
 102 : adjust-d ( n -- ) state get [ + ] change-d-height drop ;
 103
 104 M: ##inc-d visit n>> adjust-d ;
 105
 106 : adjust-r ( n -- ) state get [ + ] change-r-height drop ;
 107
 108 M: ##inc-r visit n>> adjust-r ;
 109
 110 : eliminate-peek ( dst src -- )
 111     ! the requested stack location is already in 'src'
 112     [ ##copy ] [ swap copies get set-at ] 2bi ;
 113
 114 M: ##peek visit
 115     dup
 116     [ dst>> ] [ loc>> translate-loc ] bi
 117     dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
 118
 119 M: ##replace visit
 120     [ src>> resolve ] [ loc>> translate-loc ] bi
 121     record-replace ;
 122
 123 M: ##copy visit
 124     [ call-next-method ] [ record-copy ] bi ;
 125
 126 M: ##call visit
 127     [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ;
 128
 129 M: ##fixnum-mul visit
 130     call-next-method -1 adjust-d ;
 131
 132 M: ##fixnum-add visit
 133     call-next-method -1 adjust-d ;
 134
 135 M: ##fixnum-sub visit
 136     call-next-method -1 adjust-d ;
 137
 138 ! Instructions that poison the stack state
 139 UNION: poison-insn
 140     ##jump
 141     ##return
 142     ##dispatch
 143     ##dispatch-label
 144     ##alien-callback
 145     ##callback-return
 146     ##fixnum-mul-tail
 147     ##fixnum-add-tail
 148     ##fixnum-sub-tail ;
 149
 150 M: poison-insn visit call-next-method poison-state ;
 151
 152 ! Instructions that kill all live vregs
 153 UNION: kill-vreg-insn
 154     poison-insn
 155     ##stack-frame
 156     ##call
 157     ##prologue
 158     ##epilogue
 159     ##fixnum-mul
 160     ##fixnum-add
 161     ##fixnum-sub
 162     ##alien-invoke
 163     ##alien-indirect ;
 164
 165 M: kill-vreg-insn visit sync-state , ;
 166
 167 : visit-alien-node ( node -- )
 168     params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
 169
 170 M: ##alien-invoke visit
 171     [ call-next-method ] [ visit-alien-node ] bi ;
 172
 173 M: ##alien-indirect visit
 174     [ call-next-method ] [ visit-alien-node ] bi ;
 175
 176 ! Basic blocks we still need to look at
 177 SYMBOL: work-list
 178
 179 : add-to-work-list ( basic-block -- )
 180     work-list get push-front ;
 181
 182 ! Maps basic-blocks to states
 183 SYMBOLS: state-in state-out ;
 184
 185 : sync-unpoisoned-states ( predecessors states -- )
 186     [
 187         dup poisoned?>> [ 2drop ] [
 188             state [
 189                 instructions>> building set
 190                 sync-state
 191             ] with-variable
 192         ] if
 193     ] 2each ;
 194
 195 ERROR: must-equal-failed seq ;
 196
 197 : must-equal ( seq -- elt )
 198     dup all-equal? [ first ] [ must-equal-failed ] if ;
 199
 200 : merge-heights ( state predecessors states -- state )
 201     nip
 202     [ [ d-height>> ] map must-equal >>d-height ]
 203     [ [ r-height>> ] map must-equal >>r-height ] bi ;
 204
 205 ERROR: inconsistent-vreg>loc states ;
 206
 207 : check-vreg>loc ( states -- )
 208     ! The same vreg should not store different locs in
 209     ! different branches
 210     dup
 211     [ vregs>locs>> ] map
 212     [ [ keys ] map concat prune ] keep
 213     '[ _ [ at ] with map sift all-equal? ] all?
 214     [ drop ] [ inconsistent-vreg>loc ] if ;
 215
 216 : insert-peek ( predecessor loc -- vreg )
 217     ! XXX critical edges
 218     [ instructions>> building ] dip '[ _ ^^peek ] with-variable ;
 219
 220 : merge-loc ( predecessors locs>vregs loc -- vreg )
 221     ! Insert a ##phi in the current block where the input
 222     ! is the vreg storing loc from each predecessor block
 223     [ '[ [ _ ] dip at ] map ] keep
 224     '[ [ ] [ _ insert-peek ] if ] 2map
 225     ^^phi ;
 226
 227 : merge-locs ( state predecessors states -- state )
 228     [ locs>vregs>> ] map dup [ keys ] map prune
 229     [
 230         [ 2nip ] [ merge-loc ] 3bi
 231     ] with with H{ } map>assoc
 232     >>locs>vregs ;
 233
 234 : merge-states ( predecessors states -- state )
 235     ! If any states are poisoned, save all registers
 236     ! to the stack in each branch
 237     [ drop <state> ] [
 238         dup [ poisoned?>> ] any? [
 239             sync-unpoisoned-states <state>
 240         ] [
 241             dup check-vreg>loc
 242             [ state new ] 2dip
 243             [ merge-heights ]
 244             [ merge-locs ] 2bi
 245             ! what about vregs>locs
 246         ] if
 247     ] if-empty ;
 248
 249 : block-in-state ( bb -- states )
 250     predecessors>> dup state-out get '[ _ at ] map merge-states ;
 251
 252 : maybe-set-at ( value key assoc -- changed? )
 253     3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
 254
 255 : set-block-in-state ( state b -- )
 256     state-in get set-at ;
 257
 258 : set-block-out-state ( bb state -- changed? )
 259     swap state-out get maybe-set-at ;
 260
 261 : finish-block ( bb state -- )
 262     [ drop ] [ set-block-out-state ] 2bi
 263     [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
 264
 265 : visit-block ( bb -- )
 266     ! block-in-state may add phi nodes at the start of the basic block
 267     ! so we wrap the whole thing with a 'make'
 268     [
 269         dup block-in-state
 270         [ swap set-block-in-state ] [
 271             state [
 272                 [ instructions>> [ visit ] each ]
 273                 [ state get finish-block ]
 274                 [ ]
 275                 tri
 276             ] with-variable
 277         ] 2bi
 278     ] V{ } make >>instructions drop ;
 279
 280 : visit-blocks ( bb -- )
 281     reverse-post-order work-list get
 282     [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ;
 283
 284 : optimize-stack ( cfg -- cfg )
 285     [
 286         H{ } clone copies set
 287         H{ } clone state-in set
 288         H{ } clone state-out set
 289         <hashed-dlist> work-list set
 290         dup entry>> visit-blocks
 291     ] with-scope ;
 292
 293 ! XXX: what if our height doesn't match
 294 ! a future block we're merging with?
 295 ! - we should only poison tail calls
 296 ! - non-tail poisoning nodes: ##alien-callback, ##call of a non-tail dispatch
 297 ! do we need a distinction between height changes in code and height changes done by the callee