compiler/cmm/CmmSpillReload.hs

   1 {-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
   2 -- Norman likes local bindings
   3 -- If this module lives on I'd like to get rid of this flag in due course
   4
   5 module CmmSpillReload
   6   ( DualLive(..)
   7   , dualLiveLattice, dualLiveTransfers, dualLiveness
   8   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   9   , dualLivenessWithInsertion
  10
  11   , availRegsLattice
  12   , cmmAvailableReloads
  13   , insertLateReloads
  14   , removeDeadAssignmentsAndReloads
  15   )
  16 where
  17
  18 import BlockId
  19 import Cmm
  20 import CmmExpr
  21 import CmmLive
  22 import OptimizationFuel
  23
  24 import Control.Monad
  25 import Outputable hiding (empty)
  26 import qualified Outputable as PP
  27 import UniqSet
  28
  29 import Compiler.Hoopl
  30 import Data.Maybe
  31 import Prelude hiding (succ, zip)
  32
  33 {- Note [Overview of spill/reload]
  34 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  35 The point of this module is to insert spills and reloads to
  36 establish the invariant that at a call (or at any proc point with
  37 an established protocol) all live variables not expected in
  38 registers are sitting on the stack.  We use a backward analysis to
  39 insert spills and reloads.  It should be followed by a
  40 forward transformation to sink reloads as deeply as possible, so as
  41 to reduce register pressure.
  42
  43 A variable can be expected to be live in a register, live on the
  44 stack, or both.  This analysis ensures that spills and reloads are
  45 inserted as needed to make sure that every live variable needed
  46 after a call is available on the stack.  Spills are pushed back to
  47 their reaching definitions, but reloads are dropped wherever needed
  48 and will have to be sunk by a later forward transformation.
  49 -}
  50
  51 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  52
  53 dualUnion :: DualLive -> DualLive -> DualLive
  54 dualUnion (DualLive s r) (DualLive s' r') =
  55     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  56
  57 dualUnionList :: [DualLive] -> DualLive
  58 dualUnionList ls = DualLive ss rs
  59     where ss = unionManyUniqSets $ map on_stack ls
  60           rs = unionManyUniqSets $ map in_regs  ls
  61
  62 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  63 changeStack f live = live { on_stack = f (on_stack live) }
  64 changeRegs  f live = live { in_regs  = f (in_regs  live) }
  65
  66
  67 dualLiveLattice :: DataflowLattice DualLive
  68 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
  69     where empty = DualLive emptyRegSet emptyRegSet
  70           add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
  71             where (change1, stack) = add1 (on_stack old) (on_stack new)
  72                   (change2, regs)  = add1 (in_regs old)  (in_regs new)
  73           add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
  74             where join = unionUniqSets old new
  75
  76 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
  77 dualLivenessWithInsertion procPoints g =
  78   liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
  79                                                 (dualLiveTransfers (g_entry g) procPoints)
  80                                                 (insertSpillAndReloadRewrites g procPoints)
  81
  82 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
  83 dualLiveness procPoints g =
  84   liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
  85
  86 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
  87 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
  88     where first :: CmmNode C O -> DualLive -> DualLive
  89           first (CmmEntry id) live = check live id $  -- live at procPoint => spill
  90             if id /= entry && setMember id procPoints
  91                then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
  92                              , in_regs  = emptyRegSet }
  93                else live
  94             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
  95
  96           middle :: CmmNode O O -> DualLive -> DualLive
  97           middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live)
  98             where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle
  99                   regs_in :: RegSet -> RegSet
 100                   regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet
 101                                            _ -> live
 102                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 103                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 104                   spill  live _ = live
 105                   reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 106                   reload live _ = live
 107                   check (RegSlot (LocalReg _ ty), o, w) x
 108                      | o == w && w == widthInBytes (typeWidth ty) = x
 109                   check _ _ = panic "middleDualLiveness unsupported: slices"
 110           last :: CmmNode O C -> FactBase DualLive -> DualLive
 111           last l fb = case l of
 112             CmmBranch id                   -> lkp id
 113             l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
 114             l@(CmmCall {cml_cont=Just k})  -> call l k
 115             l@(CmmForeignCall {succ=k})    -> call l k
 116             l@(CmmCondBranch _ t f)        -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
 117             l@(CmmSwitch _ tbl)            -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
 118             where empty = fact_bot dualLiveLattice
 119                   lkp id = empty `fromMaybe` lookupFact id fb
 120                   call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
 121
 122 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 123 gen  a live = foldRegsUsed extendRegSet     live a
 124 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 125 kill a live = foldRegsDefd deleteFromRegSet live a
 126
 127 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
 128 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
 129   -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 130   -- but GHC miscompiles it, see bug #4044.
 131     where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
 132           first e@(CmmEntry id) live = return $
 133             if id /= (g_entry graph) && setMember id procPoints then
 134               case map reload (uniqSetToList spill_regs) of
 135                 [] -> Nothing
 136                 is -> Just $ mkFirst e <*> mkMiddles is
 137             else Nothing
 138               where
 139                 -- If we are splitting procedures, we need the LastForeignCall
 140                 -- to spill its results to the stack because they will only
 141                 -- be used by a separate procedure (so they can't stay in LocalRegs).
 142                 splitting = True
 143                 spill_regs = if splitting then in_regs live
 144                              else in_regs live `minusRegSet` defs
 145                 defs = case mapLookup id firstDefs of
 146                            Just defs -> defs
 147                            Nothing   -> emptyRegSet
 148                 -- A LastForeignCall may contain some definitions, which take place
 149                 -- on return from the function call. Therefore, we build a map (firstDefs)
 150                 -- from BlockId to the set of variables defined on return to the BlockId.
 151                 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
 152                 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
 153                 addLive b env = case lastNode b of
 154                                   CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
 155                                   _                                 -> env
 156                 add bid defs env = mapInsert bid defs'' env
 157                   where defs'' = case mapLookup bid env of
 158                                    Just defs' -> timesRegSet defs defs'
 159                                    Nothing    -> defs
 160
 161           middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 162           middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
 163           middle m@(CmmAssign (CmmLocal reg) _) live = return $
 164               if reg `elemRegSet` on_stack live then -- must spill
 165                    my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 166                                                text "after"{-, ppr m-}]) $
 167                    Just $ mkMiddles $ [m, spill reg]
 168               else Nothing
 169           middle m@(CmmUnsafeForeignCall _ fs _) live = return $
 170             case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
 171                  map reload (uniqSetToList (kill fs (in_regs live))) of
 172               []      -> Nothing
 173               reloads -> Just $ mkMiddles (m : reloads)
 174           middle _ _ = return Nothing
 175
 176           nothing _ _ = return Nothing
 177
 178 regSlot :: LocalReg -> CmmExpr
 179 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 180
 181 spill, reload :: LocalReg -> CmmNode O O
 182 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 183 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 184
 185 ----------------------------------------------------------------
 186 --- sinking reloads
 187
 188 -- The idea is to compute at each point the set of registers such that
 189 -- on every path to the point, the register is defined by a Reload
 190 -- instruction.  Then, if a use appears at such a point, we can safely
 191 -- insert a Reload right before the use.  Finally, we can eliminate
 192 -- the early reloads along with other dead assignments.
 193
 194 data AvailRegs = UniverseMinus RegSet
 195                | AvailRegs     RegSet
 196
 197
 198 availRegsLattice :: DataflowLattice AvailRegs
 199 availRegsLattice = DataflowLattice "register gotten from reloads" empty add
 200     where empty = UniverseMinus emptyRegSet
 201           -- | compute in the Tx monad to track whether anything has changed
 202           add _ (OldFact old) (NewFact new) =
 203             if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
 204             where join = interAvail new old
 205
 206
 207 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 208 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 209 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 210 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 211 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 212
 213 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 214 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 215 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 216 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 217 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 218
 219 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 220 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 221 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 222
 223 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 224 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 225 delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 226
 227 elemAvail :: AvailRegs -> LocalReg -> Bool
 228 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 229 elemAvail (AvailRegs     s) r = elemRegSet r s
 230
 231 cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
 232 cmmAvailableReloads g =
 233   liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
 234                               analFwd availRegsLattice availReloadsTransfer
 235
 236 availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
 237 availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
 238
 239 middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
 240 middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
 241                | l `isStackSlotOf` r = extendAvail avail r
 242 middleAvail (CmmAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
 243 middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
 244                | l `isStackSlotOf` r = avail
 245 middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
 246 middleAvail (CmmStore {})            avail = avail
 247 middleAvail (CmmUnsafeForeignCall {}) _    = AvailRegs emptyRegSet
 248 middleAvail (CmmComment {})          avail = avail
 249
 250 lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
 251 lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
 252 lastAvail (CmmForeignCall {succ=k})  _ = [(k, AvailRegs emptyRegSet)]
 253 lastAvail l avail = map (\id -> (id, avail)) $ successors l
 254
 255 insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
 256 insertLateReloads g =
 257   liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
 258                               analRewFwd availRegsLattice availReloadsTransfer rewrites
 259   where rewrites = mkFRewrite3 first middle last
 260         first _ _ = return Nothing
 261         middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
 262         last   l avail = return $ maybe_reload_before avail l (mkLast l)
 263         maybe_reload_before avail node tail =
 264             let used = filterRegsUsed (elemAvail avail) node
 265             in  if isEmptyUniqSet used then Nothing
 266                                        else Just $ reloadTail used tail
 267         reloadTail regset t = foldl rel t $ uniqSetToList regset
 268           where rel t r = mkMiddle (reload r) <*> t
 269
 270 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 271 removeDeadAssignmentsAndReloads procPoints g =
 272    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
 273                                                  (dualLiveTransfers (g_entry g) procPoints)
 274                                                  rewrites
 275    where rewrites = deepBwdRw3 nothing middle nothing
 276          -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 277          -- but GHC panics while compiling, see bug #4045.
 278          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 279          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
 280          middle _ _ = return Nothing
 281
 282          nothing _ _ = return Nothing
 283
 284
 285 ---------------------
 286 -- prettyprinting
 287
 288 ppr_regs :: String -> RegSet -> SDoc
 289 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 290   where commafy xs = hsep $ punctuate comma xs
 291
 292 instance Outputable DualLive where
 293   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 294       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 295           text "<nothing-live>"
 296       else
 297           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 298                          else (ppr_regs "live in regs =" regs),
 299                          if isEmptyUniqSet stack then PP.empty
 300                          else (ppr_regs "live on stack =" stack)]
 301
 302 instance Outputable AvailRegs where
 303   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 304                           else ppr_regs "available = all but" s
 305   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 306                           else ppr_regs "available = " s
 307
 308 my_trace :: String -> SDoc -> a -> a
 309 my_trace = if False then pprTrace else \_ _ a -> a
 310
 311 f4sep :: [SDoc] -> SDoc
 312 f4sep [] = fsep []
 313 f4sep (d:ds) = fsep (d : map (nest 4) ds)