compiler/cmm/CmmSpillReload.hs

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