compiler/cmm/CmmSpillReload.hs

   1 #if __GLASGOW_HASKELL__ >= 611
   2 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
   3 #endif
   4 -- Norman likes local bindings
   5 -- If this module lives on I'd like to get rid of this flag in due course
   6
   7 module CmmSpillReload
   8   ( DualLive(..)
   9   , dualLiveLattice, dualLiveTransfers, dualLiveness
  10   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
  11   , dualLivenessWithInsertion
  12
  13   , availRegsLattice
  14   , cmmAvailableReloads
  15   , insertLateReloads
  16   , removeDeadAssignmentsAndReloads
  17   )
  18 where
  19
  20 import BlockId
  21 import CmmExpr
  22 import CmmTx
  23 import CmmLiveZ
  24 import DFMonad
  25 import MkZipCfg
  26 import PprCmm()
  27 import ZipCfg
  28 import ZipCfgCmmRep
  29 import ZipDataflow
  30
  31 import Control.Monad
  32 import Outputable hiding (empty)
  33 import qualified Outputable as PP
  34 import UniqSet
  35
  36 import Data.Maybe
  37 import Prelude hiding (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 =
  75       DataflowLattice "variables live in registers and on stack" empty add False
  76     where empty = DualLive emptyRegSet emptyRegSet
  77           -- | compute in the Tx monad to track whether anything has changed
  78           add new old = do stack <- add1 (on_stack new) (on_stack old)
  79                            regs  <- add1 (in_regs new)  (in_regs old)
  80                            return $ DualLive stack regs
  81           add1 = fact_add_to liveLattice
  82
  83 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
  84
  85 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
  86 dualLivenessWithInsertion procPoints g@(LGraph entry _) =
  87   liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
  88     where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
  89                                  dualLiveLattice (dualLiveTransfers entry procPoints)
  90                                  (insertSpillAndReloadRewrites entry procPoints) empty g
  91           empty = fact_bot dualLiveLattice
  92
  93 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
  94 dualLiveness procPoints g@(LGraph entry _) =
  95   liftM zdfFpFacts $ (res :: LiveReloadFix ())
  96     where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
  97                               (dualLiveTransfers entry procPoints) empty g
  98           empty = fact_bot dualLiveLattice
  99
 100 dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
 101 dualLiveTransfers entry procPoints = BackwardTransfers first middle last
 102     where last   = lastDualLiveness
 103           middle = middleDualLiveness
 104           first id live = check live id $  -- live at procPoint => spill
 105             if id /= entry && elemBlockSet id procPoints then
 106               DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 107                        , in_regs  = emptyRegSet }
 108             else live
 109           check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 110
 111 middleDualLiveness :: Middle -> DualLive -> DualLive
 112 middleDualLiveness m live =
 113   changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
 114     where regs_in live = case m of MidForeignCall {} -> emptyRegSet
 115                                    _ -> live
 116           updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 117           spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 118           spill  live _ = live
 119           reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 120           reload live _ = live
 121           check (RegSlot (LocalReg _ ty), o, w) x
 122              | o == w && w == widthInBytes (typeWidth ty) = x
 123           check _ _ = panic "middleDualLiveness unsupported: slices"
 124
 125 lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
 126 lastDualLiveness l env = last l
 127   where last (LastBranch id)          = env id
 128         last l@(LastCall _ Nothing  _ _ _) = changeRegs (gen l . kill l) empty
 129         last l@(LastCall _ (Just k) _ _ _) =
 130             -- nothing can be live in registers at this point, unless safe foreign call
 131             let live = env k
 132                 live_in = DualLive (on_stack live) (gen l emptyRegSet)
 133             in if isEmptyUniqSet (in_regs live) then live_in
 134                else pprTrace "Offending party:" (ppr k <+> ppr live) $
 135                     panic "live values in registers at call continuation"
 136         last l@(LastCondBranch _ t f)   =
 137             changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
 138         last l@(LastSwitch _ tbl)       = changeRegs (gen l . kill l) $ dualUnionList $
 139                                                              map env (catMaybes tbl)
 140         empty = fact_bot dualLiveLattice
 141
 142 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 143 gen  a live = foldRegsUsed extendRegSet     live a
 144 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 145 kill a live = foldRegsDefd deleteFromRegSet live a
 146
 147 insertSpillAndReloadRewrites ::
 148   BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
 149 insertSpillAndReloadRewrites entry procPoints =
 150   BackwardRewrites first middle last exit
 151     where middle = middleInsertSpillsAndReloads
 152           last _ _ = Nothing
 153           exit     = Nothing
 154           first id live =
 155             if id /= entry && elemBlockSet id procPoints then
 156               case map reload (uniqSetToList (in_regs live)) of
 157                 [] -> Nothing
 158                 is -> Just (mkMiddles is)
 159             else Nothing
 160
 161 middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
 162 middleInsertSpillsAndReloads m live = middle m
 163   where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
 164           | reg == reg' = Nothing
 165         middle (MidAssign (CmmLocal reg) _) =
 166             if reg `elemRegSet` on_stack live then -- must spill
 167                  my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 168                                              text "after", ppr m]) $
 169                  Just $ mkMiddles $ [m, spill reg]
 170             else Nothing
 171         middle (MidForeignCall _ _ fs _) =
 172           case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
 173                map reload (uniqSetToList (kill fs (in_regs live))) of
 174             []      -> Nothing
 175             reloads -> Just (mkMiddles (m : reloads))
 176         middle _ = Nothing
 177
 178 -- Generating spill and reload code
 179 regSlot :: LocalReg -> CmmExpr
 180 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 181
 182 spill, reload :: LocalReg -> Middle
 183 spill  r = MidStore  (regSlot r) (CmmReg $ CmmLocal r)
 184 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 185
 186 ----------------------------------------------------------------
 187 --- sinking reloads
 188
 189 -- The idea is to compute at each point the set of registers such that
 190 -- on every path to the point, the register is defined by a Reload
 191 -- instruction.  Then, if a use appears at such a point, we can safely
 192 -- insert a Reload right before the use.  Finally, we can eliminate
 193 -- the early reloads along with other dead assignments.
 194
 195 data AvailRegs = UniverseMinus RegSet
 196                | AvailRegs     RegSet
 197
 198
 199 availRegsLattice :: DataflowLattice AvailRegs
 200 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
 201     where empty = UniverseMinus emptyRegSet
 202           -- | compute in the Tx monad to track whether anything has changed
 203           add new old =
 204             let join = interAvail new old in
 205             if join `smallerAvail` old then aTx join else noTx join
 206
 207
 208 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 209 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 210 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 211 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 212 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 213
 214 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 215 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 216 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 217 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 218 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 219
 220 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 221 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 222 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 223
 224 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 225 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 226 delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 227
 228 elemAvail :: AvailRegs -> LocalReg -> Bool
 229 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 230 elemAvail (AvailRegs     s) r = elemRegSet r s
 231
 232 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
 233
 234 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
 235 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 236     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
 237                               avail_reloads_transfer empty g
 238           empty = fact_bot availRegsLattice
 239
 240 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
 241 avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
 242
 243 middleAvail :: Middle -> AvailRegs -> AvailRegs
 244 middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
 245                | l `isStackSlotOf` r = extendAvail avail r
 246 middleAvail (MidAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
 247 middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
 248                | l `isStackSlotOf` r = avail
 249 middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
 250 middleAvail (MidStore {})            avail = avail
 251 middleAvail (MidForeignCall {})      _     = AvailRegs emptyRegSet
 252 middleAvail (MidComment {})          avail = avail
 253
 254 lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
 255 lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
 256 lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 257
 258 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
 259
 260 availRewrites :: ForwardRewrites Middle Last AvailRegs
 261 availRewrites = ForwardRewrites first middle last exit
 262   where first _ _ = Nothing
 263         middle m avail = maybe_reload_before avail m (mkMiddle m)
 264         last   l avail = maybe_reload_before avail l (mkLast l)
 265         exit _ = Nothing
 266         maybe_reload_before avail node tail =
 267             let used = filterRegsUsed (elemAvail avail) node
 268             in  if isEmptyUniqSet used then Nothing
 269                 else Just $ reloadTail used tail
 270         reloadTail regset t = foldl rel t $ uniqSetToList regset
 271           where rel t r = mkMiddle (reload r) <*> t
 272
 273
 274 insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 275 insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
 276     where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
 277                                  availRegsLattice avail_reloads_transfer availRewrites bot g
 278           bot = fact_bot availRegsLattice
 279
 280 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 281 removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
 282    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
 283      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 284                    dualLiveLattice (dualLiveTransfers entry procPoints)
 285                    rewrites (fact_bot dualLiveLattice) g
 286            rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
 287            nothing _ _ = Nothing
 288
 289 middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
 290 middleRemoveDeads  (MidAssign (CmmLocal reg') _) live
 291        | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
 292 middleRemoveDeads  _ _ = Nothing
 293
 294
 295
 296 ---------------------
 297 -- prettyprinting
 298
 299 ppr_regs :: String -> RegSet -> SDoc
 300 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 301   where commafy xs = hsep $ punctuate comma xs
 302
 303 instance Outputable DualLive where
 304   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 305       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 306           text "<nothing-live>"
 307       else
 308           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 309                          else (ppr_regs "live in regs =" regs),
 310                          if isEmptyUniqSet stack then PP.empty
 311                          else (ppr_regs "live on stack =" stack)]
 312
 313 instance Outputable AvailRegs where
 314   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 315                           else ppr_regs "available = all but" s
 316   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 317                           else ppr_regs "available = " s
 318
 319 my_trace :: String -> SDoc -> a -> a
 320 my_trace = if False then pprTrace else \_ _ a -> a
 321
 322 f4sep :: [SDoc] -> SDoc
 323 f4sep [] = fsep []
 324 f4sep (d:ds) = fsep (d : map (nest 4) ds)