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