CmmSink.hs 10.3 KB
Newer Older
1 2
{-# LANGUAGE GADTs #-}
module CmmSink (
3
     cmmSink
4 5 6 7 8 9 10 11 12
  ) where

import Cmm
import BlockId
import CmmLive
import CmmUtils
import Hoopl

import UniqFM
Simon Marlow's avatar
Simon Marlow committed
13
-- import Outputable
14

15
import Data.List (partition)
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
import qualified Data.Set as Set

-- -----------------------------------------------------------------------------
-- Sinking

-- This is an optimisation pass that
--  (a) moves assignments closer to their uses, to reduce register pressure
--  (b) pushes assignments into a single branch of a conditional if possible

-- It is particularly helpful in the Cmm generated by the Stg->Cmm
-- code generator, in which every function starts with a copyIn
-- sequence like:
--
--    x1 = R1
--    x2 = Sp[8]
--    x3 = Sp[16]
--    if (Sp - 32 < SpLim) then L1 else L2
--
-- we really want to push the x1..x3 assignments into the L2 branch.
--
-- Algorithm:
--
--  * Start by doing liveness analysis.
--  * Keep a list of assignments; earlier ones may refer to later ones
--  * Walk forwards through the graph;
--    * At an assignment:
--      * pick up the assignment and add it to the list
--    * At a store:
--      * drop any assignments that the store refers to
--      * drop any assignments that refer to memory that may be written
--        by the store
--      * do this recursively, dropping dependent assignments
--    * At a multi-way branch:
--      * drop any assignments that are live on more than one branch
--      * if any successor has more than one predecessor, drop everything
--        live in that successor
-- 
-- As a side-effect we'll delete some dead assignments (transitively,
-- even).  Maybe we could do without removeDeadAssignments?

-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
--
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.

type Assignment = (LocalReg, CmmExpr, AbsAddr)

64 65
cmmSink :: CmmGraph -> CmmGraph
cmmSink graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
66 67
  where

68
  liveness = cmmLiveness graph
Simon Marlow's avatar
Simon Marlow committed
69
  getLive l = mapFindWithDefault Set.empty l liveness
70 71 72 73 74 75 76 77

  blocks = postorderDfs graph

  all_succs = concatMap successors blocks
  succ_counts :: BlockEnv Int
  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
  join_pts = mapFilter (>1) succ_counts

Simon Marlow's avatar
Simon Marlow committed
78

79 80 81
  sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock]
  sink _ [] = []
  sink sunk (b:bs) =
Simon Marlow's avatar
Simon Marlow committed
82
    -- pprTrace "sink" (ppr lbl) $
83 84 85 86
    blockJoin first final_middle last : sink sunk' bs
    where
      lbl = entryLabel b
      (first, middle, last) = blockSplit b
87
      (middle', assigs) = walk ann_middles emptyBlock
88 89
                               (mapFindWithDefault [] lbl sunk)

Simon Marlow's avatar
Simon Marlow committed
90
      succs = successors last
91

Simon Marlow's avatar
Simon Marlow committed
92 93 94 95 96
      -- Annotate the middle nodes with the registers live *after*
      -- the node.  This will help us decide whether we can inline
      -- an assignment in the current node or not.
      live = Set.unions (map getLive succs)
      live_middle = gen_kill last live
97 98
      ann_middles = annotate live_middle (blockToList middle)

Simon Marlow's avatar
Simon Marlow committed
99 100 101
      -- We cannot sink into join points (successors with more than
      -- one predecessor), so identify the join points and the set
      -- of registers live in them.
102
      (joins, nonjoins) = partition (`mapMember` join_pts) succs
Simon Marlow's avatar
Simon Marlow committed
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
      live_in_joins = Set.unions (map getLive joins)

      -- We do not want to sink an assignment into multiple branches,
      -- so identify the set of registers live in multiple successors.
      -- This is made more complicated because when we sink an assignment
      -- into one branch, this might change the set of registers that are
      -- now live in multiple branches.
      init_live_sets = map getLive nonjoins
      live_in_multi live_sets r =
         case filter (Set.member r) live_sets of
           (_one:_two:_) -> True
           _ -> False

      -- Now, drop any assignments that we will not sink any further.
      (dropped_last, assigs') = dropAssignments drop_if init_live_sets assigs

      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
          where
            should_drop =  a `conflicts` last
                        || {- not (isTiny rhs) && -} live_in_multi live_sets r
                        || r `Set.member` live_in_joins
124

Simon Marlow's avatar
Simon Marlow committed
125 126
            live_sets' | should_drop = live_sets
                       | otherwise   = map upd live_sets
127

Simon Marlow's avatar
Simon Marlow committed
128 129
            upd set | r `Set.member` set = set `Set.union` live_rhs
                    | otherwise          = set
130

Simon Marlow's avatar
Simon Marlow committed
131
            live_rhs = foldRegsUsed extendRegSet emptyRegSet rhs
132 133 134 135 136

      final_middle = foldl blockSnoc middle' dropped_last

      sunk' = mapUnion sunk $
                 mapFromList [ (l, filterAssignments (getLive l) assigs')
137 138
                             | l <- succs ]

Simon Marlow's avatar
Simon Marlow committed
139 140 141 142 143
-- tiny: an expression we don't mind duplicating
isTiny :: CmmExpr -> Bool
isTiny (CmmReg _) = True
isTiny (CmmLit _) = True
isTiny _other     = False
144

145 146 147
-- annotate each node with the set of registers live *after* the node
annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)]
annotate live nodes = snd $ foldr (\n (live,nodes) -> (gen_kill n live, (live,n) : nodes)) (live,[]) nodes
148 149 150 151 152 153 154 155 156 157

filterAssignments :: RegSet -> [Assignment] -> [Assignment]
filterAssignments live assigs = reverse (go assigs [])
  where go []           kept = kept
        go (a@(r,_,_):as) kept | needed    = go as (a:kept)
                               | otherwise = go as kept
           where
              needed = r `Set.member` live || any (a `conflicts`) (map toNode kept)


158
walk :: [(RegSet, CmmNode O O)] -> Block CmmNode O O -> [Assignment]
159 160
     -> (Block CmmNode O O, [Assignment])

161 162 163 164
walk []               block as = (block, as)
walk ((live,node):ns) block as
  | Just a <- shouldSink node1 = walk ns block (a : as1)
  | otherwise                  = walk ns block' as'
165
  where
166 167 168 169
    (node1, as1) = tryToInline live usages node as
       where usages :: UniqFM Int
             usages = foldRegsUsed addUsage emptyUFM node

Simon Marlow's avatar
Simon Marlow committed
170
    (dropped, as') = dropAssignmentsSimple (`conflicts` node1) as1
171 172 173 174
    block' = foldl blockSnoc block dropped `blockSnoc` node1

tryToInline :: RegSet -> UniqFM Int -> CmmNode O x -> [Assignment]
            -> (CmmNode O x, [Assignment])
Simon Marlow's avatar
Simon Marlow committed
175
tryToInline _live _usages node []
176
  = (node, [])
Simon Marlow's avatar
Simon Marlow committed
177 178 179 180
tryToInline live usages node (a@(l,rhs,_) : rest)
  | occurs_once_in_this_node  = inline_and_discard
  | False {- isTiny rhs -}    = inline_and_keep
    -- ^^ seems to make things slightly worse
181
  where
Simon Marlow's avatar
Simon Marlow committed
182 183 184 185 186 187 188 189
        inline_and_discard = tryToInline live' usages' node' rest

        inline_and_keep = (node'', a : rest')
          where (node'',rest') = inline_and_discard

        occurs_once_in_this_node =
         not (l `elemRegSet` live) &&  lookupUFM usages l == Just 1

190 191 192 193 194 195 196
        live'   = foldRegsUsed extendRegSet live rhs
        usages' = foldRegsUsed addUsage usages rhs

        node' = mapExpDeep inline node
           where inline (CmmReg    (CmmLocal l'))     | l == l' = rhs
                 inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset rhs off
                 inline other = other
Simon Marlow's avatar
Simon Marlow committed
197
tryToInline live usages node (assig@(_,rhs,_) : rest)
198
  = (node', assig : rest')
Simon Marlow's avatar
Simon Marlow committed
199 200
  where (node', rest') = tryToInline live usages' node rest
        usages' = foldRegsUsed addUsage usages rhs
201

202 203 204 205
addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
addUsage m r = addToUFM_C (+) m r 1

shouldSink :: CmmNode e x -> Maybe Assignment
206
shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprAddr e)
Simon Marlow's avatar
Simon Marlow committed
207
  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
208 209 210 211 212
shouldSink _other = Nothing

toNode :: Assignment -> CmmNode O O
toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs

Simon Marlow's avatar
Simon Marlow committed
213 214 215 216 217
dropAssignmentsSimple :: (Assignment -> Bool) -> [Assignment] -> ([CmmNode O O], [Assignment])
dropAssignmentsSimple f = dropAssignments (\a _ -> (f a, ())) ()

dropAssignments :: (Assignment -> s -> (Bool, s)) -> s -> [Assignment] -> ([CmmNode O O], [Assignment])
dropAssignments should_drop state assigs
218 219
 = (dropped, reverse kept)
 where
Simon Marlow's avatar
Simon Marlow committed
220
   (dropped,kept) = go state assigs [] []
221

Simon Marlow's avatar
Simon Marlow committed
222 223 224 225
   go _ []             dropped kept = (dropped, kept)
   go state (assig : rest) dropped kept
      | conflict  = go state' rest (toNode assig : dropped) kept
      | otherwise = go state' rest dropped (assig:kept)
226
      where
Simon Marlow's avatar
Simon Marlow committed
227 228 229 230
        (dropit, state') = should_drop assig state
        conflict = dropit || any (assig `conflicts`) dropped

-- -----------------------------------------------------------------------------
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285

-- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment
-- @r = e@ can be safely commuted past @stmt@.
--
-- We only sink "r = G" assignments right now, so conflicts is very simple:
--
conflicts :: Assignment -> CmmNode O x -> Bool
(_, rhs, _   ) `conflicts` CmmAssign reg  _ | reg `regUsedIn` rhs = True
(_, _,   addr) `conflicts` CmmStore addr' _ | addrConflicts addr (loadAddr addr') = True
(r, _,   _)    `conflicts` node
  = foldRegsUsed (\b r' -> r == r' || b) False node

-- An abstraction of the addresses read or written.
data AbsAddr = NoAddr | HeapAddr | StackAddr | AnyAddr

bothAddrs :: AbsAddr -> AbsAddr -> AbsAddr
bothAddrs NoAddr    x         = x
bothAddrs x         NoAddr    = x
bothAddrs HeapAddr  HeapAddr  = HeapAddr
bothAddrs StackAddr StackAddr = StackAddr
bothAddrs _         _         = AnyAddr

addrConflicts :: AbsAddr -> AbsAddr -> Bool
addrConflicts NoAddr    _         = False
addrConflicts _         NoAddr    = False
addrConflicts HeapAddr  StackAddr = False
addrConflicts StackAddr HeapAddr  = False
addrConflicts _         _         = True

exprAddr :: CmmExpr -> AbsAddr -- here NoAddr means "no reads"
exprAddr (CmmLoad addr _)  = loadAddr addr
exprAddr (CmmMachOp _ es)  = foldr bothAddrs NoAddr (map exprAddr es)
exprAddr _                 = NoAddr

absAddr :: CmmExpr -> AbsAddr -- here NoAddr means "don't know"
absAddr (CmmLoad addr _)  = bothAddrs HeapAddr (loadAddr addr) -- (1)
absAddr (CmmMachOp _ es)  = foldr bothAddrs NoAddr (map absAddr es)
absAddr (CmmReg r)        = regAddr r
absAddr (CmmRegOff r _)   = regAddr r
absAddr _ = NoAddr

loadAddr :: CmmExpr -> AbsAddr
loadAddr e = case absAddr e of
               NoAddr -> HeapAddr -- (2)
               a      -> a

-- (1) we assume that an address read from memory is a heap address.
-- We never read a stack address from memory.
--
-- (2) loading from an unknown address is assumed to be a heap load.

regAddr :: CmmReg -> AbsAddr
regAddr (CmmGlobal Sp) = StackAddr
regAddr (CmmGlobal Hp) = HeapAddr
regAddr _              = NoAddr