compiler/cmm/CmmSpillReload.hs

   1
   2 module CmmSpillReload
   3   ( DualLive(..)
   4   , dualLiveLattice, dualLiveTransfers, dualLiveness
   5   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   6   , dualLivenessWithInsertion
   7
   8   , availRegsLattice
   9   , cmmAvailableReloads
  10   , insertLateReloads
  11   , removeDeadAssignmentsAndReloads
  12   )
  13 where
  14
  15 import BlockId
  16 import CmmExpr
  17 import CmmTx
  18 import CmmLiveZ
  19 import DFMonad
  20 import MkZipCfg
  21 import PprCmm()
  22 import ZipCfg
  23 import ZipCfgCmmRep
  24 import ZipDataflow
  25
  26 import Control.Monad
  27 import Outputable hiding (empty)
  28 import qualified Outputable as PP
  29 import UniqSet
  30
  31 import Data.Maybe
  32 import Prelude hiding (zip)
  33
  34 {- Note [Overview of spill/reload]
  35 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  36 The point of this module is to insert spills and reloads to
  37 establish the invariant that at a call (or at any proc point with
  38 an established protocol) all live variables not expected in
  39 registers are sitting on the stack.  We use a backward analysis to
  40 insert spills and reloads.  It should be followed by a
  41 forward transformation to sink reloads as deeply as possible, so as
  42 to reduce register pressure.
  43
  44 A variable can be expected to be live in a register, live on the
  45 stack, or both.  This analysis ensures that spills and reloads are
  46 inserted as needed to make sure that every live variable needed
  47 after a call is available on the stack.  Spills are pushed back to
  48 their reaching definitions, but reloads are dropped wherever needed
  49 and will have to be sunk by a later forward transformation.
  50 -}
  51
  52 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  53
  54 dualUnion :: DualLive -> DualLive -> DualLive
  55 dualUnion (DualLive s r) (DualLive s' r') =
  56     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  57
  58 dualUnionList :: [DualLive] -> DualLive
  59 dualUnionList ls = DualLive ss rs
  60     where ss = unionManyUniqSets $ map on_stack ls
  61           rs = unionManyUniqSets $ map in_regs  ls
  62
  63 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  64 changeStack f live = live { on_stack = f (on_stack live) }
  65 changeRegs  f live = live { in_regs  = f (in_regs  live) }
  66
  67
  68 dualLiveLattice :: DataflowLattice DualLive
  69 dualLiveLattice =
  70       DataflowLattice "variables live in registers and on stack" empty add False
  71     where empty = DualLive emptyRegSet emptyRegSet
  72           -- | compute in the Tx monad to track whether anything has changed
  73           add new old = do stack <- add1 (on_stack new) (on_stack old)
  74                            regs  <- add1 (in_regs new)  (in_regs old)
  75                            return $ DualLive stack regs
  76           add1 = fact_add_to liveLattice
  77
  78 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
  79
  80 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
  81 dualLivenessWithInsertion procPoints g@(LGraph entry _) =
  82   liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
  83     where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
  84                                  dualLiveLattice (dualLiveTransfers entry procPoints)
  85                                  (insertSpillAndReloadRewrites entry procPoints) empty g
  86           empty = fact_bot dualLiveLattice
  87
  88 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
  89 dualLiveness procPoints g@(LGraph entry _) =
  90   liftM zdfFpFacts $ (res :: LiveReloadFix ())
  91     where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
  92                               (dualLiveTransfers entry procPoints) empty g
  93           empty = fact_bot dualLiveLattice
  94
  95 dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
  96 dualLiveTransfers entry procPoints = BackwardTransfers first middle last
  97     where last   = lastDualLiveness
  98           middle = middleDualLiveness
  99           first id live = check live id $  -- live at procPoint => spill
 100             if id /= entry && elemBlockSet id procPoints then
 101               DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 102                        , in_regs  = emptyRegSet }
 103             else live
 104           check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 105
 106 middleDualLiveness :: Middle -> DualLive -> DualLive
 107 middleDualLiveness m live =
 108   changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
 109     where regs_in live = case m of MidForeignCall {} -> emptyRegSet
 110                                    _ -> live
 111           updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 112           spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 113           spill  live _ = live
 114           reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 115           reload live _ = live
 116           check (RegSlot (LocalReg _ ty), o, w) x
 117              | o == w && w == widthInBytes (typeWidth ty) = x
 118           check _ _ = panic "middleDualLiveness unsupported: slices"
 119
 120 lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
 121 lastDualLiveness l env = last l
 122   where last (LastBranch id)          = env id
 123         last l@(LastCall _ Nothing  _ _ _) = changeRegs (gen l . kill l) empty
 124         last l@(LastCall _ (Just k) _ _ _) =
 125             -- nothing can be live in registers at this point, unless safe foreign call
 126             let live = env k
 127                 live_in = DualLive (on_stack live) (gen l emptyRegSet)
 128             in if isEmptyUniqSet (in_regs live) then live_in
 129                else pprTrace "Offending party:" (ppr k <+> ppr live) $
 130                     panic "live values in registers at call continuation"
 131         last l@(LastCondBranch _ t f)   =
 132             changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
 133         last l@(LastSwitch _ tbl)       = changeRegs (gen l . kill l) $ dualUnionList $
 134                                                              map env (catMaybes tbl)
 135         empty = fact_bot dualLiveLattice
 136
 137 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 138 gen  a live = foldRegsUsed extendRegSet     live a
 139 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 140 kill a live = foldRegsDefd deleteFromRegSet live a
 141
 142 insertSpillAndReloadRewrites ::
 143   BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
 144 insertSpillAndReloadRewrites entry procPoints =
 145   BackwardRewrites first middle last exit
 146     where middle = middleInsertSpillsAndReloads
 147           last _ _ = Nothing
 148           exit     = Nothing
 149           first id live =
 150             if id /= entry && elemBlockSet id procPoints then
 151               case map reload (uniqSetToList (in_regs live)) of
 152                 [] -> Nothing
 153                 is -> Just (mkMiddles is)
 154             else Nothing
 155
 156 middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
 157 middleInsertSpillsAndReloads m live = middle m
 158   where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
 159           | reg == reg' = Nothing
 160         middle (MidAssign (CmmLocal reg) _) =
 161             if reg `elemRegSet` on_stack live then -- must spill
 162                  my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 163                                              text "after", ppr m]) $
 164                  Just $ mkMiddles $ [m, spill reg]
 165             else Nothing
 166         middle (MidForeignCall _ _ fs _) =
 167           case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
 168                map reload (uniqSetToList (kill fs (in_regs live))) of
 169             []      -> Nothing
 170             reloads -> Just (mkMiddles (m : reloads))
 171         middle _ = Nothing
 172
 173 -- Generating spill and reload code
 174 regSlot :: LocalReg -> CmmExpr
 175 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 176
 177 spill, reload :: LocalReg -> Middle
 178 spill  r = MidStore  (regSlot r) (CmmReg $ CmmLocal r)
 179 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 180
 181 ----------------------------------------------------------------
 182 --- sinking reloads
 183
 184 -- The idea is to compute at each point the set of registers such that
 185 -- on every path to the point, the register is defined by a Reload
 186 -- instruction.  Then, if a use appears at such a point, we can safely
 187 -- insert a Reload right before the use.  Finally, we can eliminate
 188 -- the early reloads along with other dead assignments.
 189
 190 data AvailRegs = UniverseMinus RegSet
 191                | AvailRegs     RegSet
 192
 193
 194 availRegsLattice :: DataflowLattice AvailRegs
 195 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
 196     where empty = UniverseMinus emptyRegSet
 197           -- | compute in the Tx monad to track whether anything has changed
 198           add new old =
 199             let join = interAvail new old in
 200             if join `smallerAvail` old then aTx join else noTx join
 201
 202
 203 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 204 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 205 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 206 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 207 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 208
 209 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 210 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 211 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 212 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 213 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 214
 215 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 216 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 217 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 218
 219 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 220 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 221 delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 222
 223 elemAvail :: AvailRegs -> LocalReg -> Bool
 224 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 225 elemAvail (AvailRegs     s) r = elemRegSet r s
 226
 227 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
 228
 229 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
 230 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 231     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
 232                               avail_reloads_transfer empty g
 233           empty = fact_bot availRegsLattice
 234
 235 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
 236 avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
 237
 238 middleAvail :: Middle -> AvailRegs -> AvailRegs
 239 middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
 240                | l `isStackSlotOf` r = extendAvail avail r
 241 middleAvail (MidAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
 242 middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
 243                | l `isStackSlotOf` r = avail
 244 middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
 245 middleAvail (MidStore {})            avail = avail
 246 middleAvail (MidForeignCall {})      _     = AvailRegs emptyRegSet
 247 middleAvail (MidComment {})          avail = avail
 248
 249 lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
 250 lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
 251 lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 252
 253 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
 254
 255 availRewrites :: ForwardRewrites Middle Last AvailRegs
 256 availRewrites = ForwardRewrites first middle last exit
 257   where first _ _ = Nothing
 258         middle m avail = maybe_reload_before avail m (mkMiddle m)
 259         last   l avail = maybe_reload_before avail l (mkLast l)
 260         exit _ = Nothing
 261         maybe_reload_before avail node tail =
 262             let used = filterRegsUsed (elemAvail avail) node
 263             in  if isEmptyUniqSet used then Nothing
 264                 else Just $ reloadTail used tail
 265         reloadTail regset t = foldl rel t $ uniqSetToList regset
 266           where rel t r = mkMiddle (reload r) <*> t
 267
 268
 269 insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 270 insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
 271     where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
 272                                  availRegsLattice avail_reloads_transfer availRewrites bot g
 273           bot = fact_bot availRegsLattice
 274
 275 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 276 removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
 277    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
 278      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 279                    dualLiveLattice (dualLiveTransfers entry procPoints)
 280                    rewrites (fact_bot dualLiveLattice) g
 281            rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
 282            nothing _ _ = Nothing
 283
 284 middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
 285 middleRemoveDeads  (MidAssign (CmmLocal reg') _) live
 286        | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
 287 middleRemoveDeads  _ _ = Nothing
 288
 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)