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 grouping
   4 sets make combinators dlists deques
   5 compiler.cfg
   6 compiler.cfg.copy-prop
   7 compiler.cfg.def-use
   8 compiler.cfg.instructions
   9 compiler.cfg.registers
  10 compiler.cfg.rpo
  11 compiler.cfg.hats
  12 compiler.cfg.stack-analysis.state
  13 compiler.cfg.stack-analysis.merge
  14 compiler.cfg.utilities ;
  15 IN: compiler.cfg.stack-analysis
  16
  17 SYMBOL: global-optimization?
  18
  19 : redundant-replace? ( vreg loc -- ? )
  20     dup state get untranslate-loc n>> 0 <
  21     [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
  22
  23 : save-changed-locs ( state -- )
  24     [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
  25         dup _ at swap 2dup redundant-replace?
  26         [ 2drop ] [ state get untranslate-loc ##replace ] if
  27     ] each ;
  28
  29 ERROR: poisoned-state state ;
  30
  31 : sync-state ( -- )
  32     state get {
  33         [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
  34         [ ds-height>> save-ds-height ]
  35         [ rs-height>> save-rs-height ]
  36         [ save-changed-locs ]
  37         [ clear-state ]
  38     } cleave ;
  39
  40 : poison-state ( -- ) state get t >>poisoned? drop ;
  41
  42 ! Abstract interpretation
  43 GENERIC: visit ( insn -- )
  44
  45 M: ##inc-d visit
  46     n>> state get [ + ] change-ds-height drop ;
  47
  48 M: ##inc-r visit
  49     n>> state get [ + ] change-rs-height drop ;
  50
  51 ! Instructions which don't have any effect on the stack
  52 UNION: neutral-insn
  53     ##effect
  54     ##flushable
  55     ##no-tco ;
  56
  57 M: neutral-insn visit , ;
  58
  59 UNION: sync-if-back-edge
  60     ##branch
  61     ##conditional-branch
  62     ##compare-imm-branch
  63     ##dispatch
  64     ##loop-entry
  65     ##fixnum-overflow ;
  66
  67 : sync-state? ( -- ? )
  68     basic-block get successors>>
  69     [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
  70
  71 M: sync-if-back-edge visit
  72     global-optimization? get [ sync-state? [ sync-state ] when ] unless
  73     , ;
  74
  75 : eliminate-peek ( dst src -- )
  76     ! the requested stack location is already in 'src'
  77     [ ##copy ] [ swap copies get set-at ] 2bi ;
  78
  79 M: ##peek visit
  80     [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
  81     [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
  82
  83 M: ##replace visit
  84     [ src>> resolve ] [ loc>> state get translate-loc ] bi
  85     record-replace ;
  86
  87 M: ##copy visit
  88     [ call-next-method ] [ record-copy ] bi ;
  89
  90 M: poison-insn visit call-next-method poison-state ;
  91
  92 M: kill-vreg-insn visit sync-state , ;
  93
  94 ! Maps basic-blocks to states
  95 SYMBOL: state-out
  96
  97 : block-in-state ( bb -- states )
  98     dup predecessors>> state-out get '[ _ at ] map merge-states ;
  99
 100 : set-block-out-state ( state bb -- )
 101     [ clone ] dip state-out get set-at ;
 102
 103 : visit-block ( bb -- )
 104     ! block-in-state may add phi nodes at the start of the basic block
 105     ! so we wrap the whole thing with a 'make'
 106     [
 107         dup basic-block set
 108         dup block-in-state
 109         state [
 110             [ instructions>> [ visit ] each ]
 111             [ [ state get ] dip set-block-out-state ]
 112             [ ]
 113             tri
 114         ] with-variable
 115     ] V{ } make >>instructions drop ;
 116
 117 : stack-analysis ( cfg -- cfg' )
 118     [
 119         <hashed-dlist> work-list set
 120         H{ } clone copies set
 121         H{ } clone state-out set
 122         dup [ visit-block ] each-basic-block
 123         global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
 124         cfg-changed
 125     ] with-scope ;