compiler/cmm/CmmSpillReload.hs

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