compiler/cmm/CmmSpillReload.hs

   1
   2 module CmmSpillReload
   3   ( ExtendWithSpills(..)
   4   , DualLive(..)
   5   , dualLiveLattice, dualLiveTransfers, dualLiveness
   6   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   7   , dualLivenessWithInsertion
   8   , elimSpillAndReload
   9
  10   , availRegsLattice
  11   , cmmAvailableReloads
  12   , insertLateReloads
  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 OptimizationFuel
  25 import PprCmm()
  26 import ZipCfg
  27 import ZipCfgCmmRep
  28 import ZipDataflow
  29
  30 import Maybes
  31 import Monad
  32 import Outputable hiding (empty)
  33 import qualified Outputable as PP
  34 import Panic
  35 import UniqSet
  36
  37 import Maybe
  38 import Prelude hiding (zip)
  39
  40 -- The point of this module is to insert spills and reloads to
  41 -- establish the invariant that at a call (or at any proc point with
  42 -- an established protocol) all live variables not expected in
  43 -- registers are sitting on the stack.  We use a backward analysis to
  44 -- insert spills and reloads.  It should some day be followed by a
  45 -- forward transformation to sink reloads as deeply as possible, so as
  46 -- to reduce register pressure.
  47
  48 data ExtendWithSpills m
  49     = NotSpillOrReload m
  50     | Spill  RegSet
  51     | Reload RegSet
  52
  53 type M = ExtendWithSpills Middle
  54
  55 -- A variable can be expected to be live in a register, live on the
  56 -- stack, or both.  This analysis ensures that spills and reloads are
  57 -- inserted as needed to make sure that every live variable needed
  58 -- after a call is available on the stack.  Spills are pushed back to
  59 -- their reaching definitions, but reloads are dropped wherever needed
  60 -- and will have to be sunk by a later forward transformation.
  61
  62 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  63
  64 dualUnion :: DualLive -> DualLive -> DualLive
  65 dualUnion (DualLive s r) (DualLive s' r') =
  66     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  67
  68 dualUnionList :: [DualLive] -> DualLive
  69 dualUnionList ls = DualLive ss rs
  70     where ss = unionManyUniqSets $ map on_stack ls
  71           rs = unionManyUniqSets $ map in_regs  ls
  72
  73 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  74 _changeStack f live = live { on_stack = f (on_stack live) }
  75 changeRegs   f live = live { in_regs  = f (in_regs  live) }
  76
  77
  78 dualLiveLattice :: DataflowLattice DualLive
  79 dualLiveLattice =
  80       DataflowLattice "variables live in registers and on stack" empty add True
  81     where empty = DualLive emptyRegSet emptyRegSet
  82           -- | compute in the Tx monad to track whether anything has changed
  83           add new old = do stack <- add1 (on_stack new) (on_stack old)
  84                            regs  <- add1 (in_regs new)  (in_regs old)
  85                            return $ DualLive stack regs
  86           add1 = fact_add_to liveLattice
  87
  88 type LiveReloadFix a = FuelMonad (BackwardFixedPoint M Last DualLive a)
  89
  90 dualLivenessWithInsertion :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
  91 dualLivenessWithInsertion procPoints g =
  92   liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
  93     where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion"
  94                                dualLiveLattice (dualLiveTransfers procPoints)
  95                                (insertSpillAndReloadRewrites procPoints) empty g
  96           empty = fact_bot dualLiveLattice
  97 -- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
  98
  99 dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive)
 100 dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
 101     where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice
 102                              (dualLiveTransfers procPoints) empty g
 103           empty = fact_bot dualLiveLattice
 104
 105 dualLiveTransfers :: BlockSet -> BackwardTransfers M Last DualLive
 106 dualLiveTransfers procPoints = BackwardTransfers first middle last
 107     where last   = lastDualLiveness
 108           middle = middleDualLiveness
 109           first live _id =
 110             if elemBlockSet _id procPoints then -- live at procPoint => spill
 111               DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 112                        , in_regs  = emptyRegSet }
 113             else live
 114
 115
 116 middleDualLiveness :: DualLive -> M -> DualLive
 117 middleDualLiveness live (Spill regs) = live'
 118     -- live-in on-stack requirements are satisfied;
 119     -- live-out in-regs obligations are created
 120     where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
 121                            , in_regs  = in_regs  live `plusRegSet`  regs }
 122
 123 middleDualLiveness live (Reload regs) = live'
 124     -- live-in in-regs requirements are satisfied;
 125     -- live-out on-stack obligations are created
 126     where live' = DualLive { on_stack = on_stack live `plusRegSet`  regs
 127                            , in_regs  = in_regs  live `minusRegSet` regs }
 128
 129 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
 130
 131 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 132 lastDualLiveness env l = last l
 133   where last (LastReturn)            = empty
 134         last (LastJump e)            = changeRegs (gen e) empty
 135         last (LastBranch id)         = env id
 136         last (LastCall tgt Nothing)  = changeRegs (gen tgt) empty
 137         last (LastCall tgt (Just k)) =
 138             -- nothing can be live in registers at this point
 139             let live = env k in
 140             if  isEmptyUniqSet (in_regs live) then
 141                 DualLive (on_stack live) (gen tgt emptyRegSet)
 142             else
 143                 pprTrace "Offending party:" (ppr k <+> ppr live) $
 144                 panic "live values in registers at call continuation"
 145         last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
 146         last (LastSwitch e tbl)     = changeRegs (gen e) $ dualUnionList $
 147                                                              map env (catMaybes tbl)
 148         empty = fact_bot dualLiveLattice
 149
 150 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 151 gen  a live = foldRegsUsed extendRegSet      live a
 152 kill a live = foldRegsUsed delOneFromUniqSet live a
 153
 154 insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive
 155 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
 156     where middle = middleInsertSpillsAndReloads
 157           last   = \_ _ -> Nothing
 158           exit = Nothing
 159           first live id =
 160             if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
 161               Just $ mkMiddles $ [Reload reloads]
 162             else Nothing
 163               where reloads = in_regs live
 164
 165
 166 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (AGraph M Last)
 167 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 168 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 169 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
 170   where middle (MidAssign (CmmLocal reg) _) =
 171             if reg `elemRegSet` on_stack live then -- must spill
 172                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 173                                             text "after", ppr m]) $
 174                 Just $ mkMiddles [m, Spill $ mkRegSet [reg]]
 175             else
 176                 Nothing
 177         middle (CopyIn _ formals _) =
 178             -- only 'formals' can be in regs at this point
 179             let regs' = kill formals (in_regs live) -- live in regs; must reload
 180                 is_stack_var r = elemRegSet r (on_stack live)
 181                 needs_spilling = filterRegsUsed is_stack_var formals
 182                    -- a formal that is expected on the stack; must spill
 183             in  if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
 184                     Nothing
 185                 else
 186                     let code  = if isEmptyUniqSet regs' then []
 187                                 else Reload regs' : []
 188                         code' = if isEmptyUniqSet needs_spilling then code
 189                                 else Spill needs_spilling : code
 190                     in
 191                     my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
 192                                                  ppr (Reload regs' :: M),
 193                                                  ppr (Spill needs_spilling :: M),
 194                                                  text "after", ppr m]) $
 195                     Just $ mkMiddles (m : code')
 196         middle _ = Nothing
 197
 198 -- | For conversion back to vanilla C--
 199
 200 elimSpillAndReload :: StackSlotMap -> LGraph M l -> (StackSlotMap, LGraph Middle l)
 201 elimSpillAndReload slots g = toGraph $ fold_blocks block ((slots, [])) g
 202   where toGraph (slots, l) = (slots, of_block_list (lg_entry g) l)
 203         block (Block id t) (slots, blocks) =
 204           lift (\ t' -> Block id t' : blocks) $ tail t slots
 205         tail (ZLast l)   slots = (slots, ZLast l)
 206         tail (ZTail m t) slots = middle m $ tail t slots
 207         middle (NotSpillOrReload m) (slots, t) = (slots, ZTail m t)
 208         middle (Spill  regs)        z          = foldUniqSet spill  z regs
 209         middle (Reload regs)        z          = foldUniqSet reload z regs
 210         move f r (slots, t) =
 211           lift (\ slot -> ZTail (f slot (CmmLocal r)) t) $ getSlot slots r
 212         spill  = move (\ slot reg -> MidStore  slot (CmmReg reg))
 213         reload = move (\ slot reg -> MidAssign reg slot)
 214         lift f (slots, x) = (slots, f x)
 215
 216
 217 ----------------------------------------------------------------
 218 --- sinking reloads
 219
 220 -- The idea is to compute at each point the set of registers such that
 221 -- on every path to the point, the register is defined by a Reload
 222 -- instruction.  Then, if a use appears at such a point, we can safely
 223 -- insert a Reload right before the use.  Finally, we can eliminate
 224 -- the early reloads along with other dead assignments.
 225
 226 data AvailRegs = UniverseMinus RegSet
 227                | AvailRegs     RegSet
 228
 229
 230 availRegsLattice :: DataflowLattice AvailRegs
 231 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
 232                             -- last True <==> debugging on
 233     where empty = UniverseMinus emptyRegSet
 234           -- | compute in the Tx monad to track whether anything has changed
 235           add new old =
 236             let join = interAvail new old in
 237             if join `smallerAvail` old then aTx join else noTx join
 238
 239
 240 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 241 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 242 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 243 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 244 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 245
 246 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 247 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 248 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 249 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 250 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 251
 252 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 253 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 254 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 255
 256 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 257 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 258 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 259
 260 elemAvail :: AvailRegs -> LocalReg -> Bool
 261 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 262 elemAvail (AvailRegs     s) r = elemRegSet r s
 263
 264 type CmmAvail = BlockEnv AvailRegs
 265 type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
 266
 267 cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
 268 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 269     where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
 270                              avail_reloads_transfer empty g
 271           empty = (fact_bot availRegsLattice)
 272
 273 avail_reloads_transfer :: ForwardTransfers M Last AvailRegs
 274 avail_reloads_transfer = ForwardTransfers first middle last id
 275   where first avail _ = avail
 276         middle        = flip middleAvail
 277         last          = lastAvail
 278
 279 -- | The transfer equations use the traditional 'gen' and 'kill'
 280 -- notations, which should be familiar from the dragon book.
 281 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 282 agen  a live = foldRegsUsed extendAvail     live a
 283 akill a live = foldRegsUsed deleteFromAvail live a
 284
 285 -- Note: you can't sink the reload past a use.
 286 middleAvail :: M -> AvailRegs -> AvailRegs
 287 middleAvail (Spill _) = id
 288 middleAvail (Reload regs) = agen regs
 289 middleAvail (NotSpillOrReload m) = middle m
 290   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
 291         middle' (MidComment {})                 = id
 292         middle' (MidAssign lhs _expr)           = akill lhs
 293         middle' (MidStore {})                   = id
 294         middle' (MidUnsafeCall _tgt ress _args) = akill ress
 295         middle' (MidAddToContext {})            = id
 296         middle' (CopyIn _ formals _)            = akill formals
 297         middle' (CopyOut {})                    = id
 298
 299 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 300 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 301 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 302
 303 insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
 304 insertLateReloads g =
 305   do env <- cmmAvailableReloads g
 306      g   <- lGraphOfGraph g
 307      liftM graphOfLGraph $ mapM_blocks (insertM env) g
 308     where insertM env b = fuelConsumingPass "late reloads" (insert b)
 309             where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 310                   insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 311                   propagate h avail (ZTail m t) fuel =
 312                       let (h', fuel') = maybe_add_reload h avail m fuel in
 313                       propagate (ZHead h' m) (middleAvail m avail) t fuel'
 314                   propagate h avail (ZLast l) fuel =
 315                       let (h', fuel') = maybe_add_reload h avail l fuel in
 316                       (zipht h' (ZLast l), fuel')
 317                   maybe_add_reload h avail node fuel =
 318                       let used = filterRegsUsed (elemAvail avail) node
 319                       in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
 320                           then (h,fuel)
 321                           else (ZHead h (Reload used), oneLessFuel fuel)
 322
 323 type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
 324
 325 insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
 326 insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
 327     where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
 328                                availRegsLattice avail_reloads_transfer rewrites bot g
 329           bot = fact_bot availRegsLattice
 330           rewrites = ForwardRewrites first middle last exit
 331           first _ _ = Nothing
 332           middle :: AvailRegs -> M -> Maybe (AGraph M Last)
 333           last   :: AvailRegs -> Last -> Maybe (AGraph M Last)
 334           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 335           last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
 336           exit _ = Nothing
 337           maybe_reload_before avail node tail =
 338               let used = filterRegsUsed (elemAvail avail) node
 339               in  if isEmptyUniqSet used then Nothing
 340                   else Just $ mkZTail $ ZTail (Reload used) tail
 341
 342 removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
 343 removeDeadAssignmentsAndReloads procPoints g =
 344    liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
 345      where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 346                    dualLiveLattice (dualLiveTransfers procPoints)
 347                    rewrites (fact_bot dualLiveLattice) g
 348            rewrites = BackwardRewrites first middle last exit
 349            exit   = Nothing
 350            last   = \_ _ -> Nothing
 351            middle = middleRemoveDeads
 352            first _ _ = Nothing
 353
 354 middleRemoveDeads :: DualLive -> M -> Maybe (AGraph M Last)
 355 middleRemoveDeads _ (Spill _)  = Nothing
 356 middleRemoveDeads live (Reload s) =
 357     if sizeUniqSet worth_reloading < sizeUniqSet s then
 358         Just $ if isEmptyUniqSet worth_reloading then emptyAGraph
 359                else mkMiddles [Reload worth_reloading]
 360     else
 361         Nothing
 362   where worth_reloading = intersectUniqSets s (in_regs live)
 363 middleRemoveDeads live (NotSpillOrReload m) = middle m
 364   where middle (MidAssign (CmmLocal reg') _)
 365                | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
 366         middle _ = Nothing
 367
 368
 369
 370 ---------------------
 371 -- register usage
 372
 373 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 374     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 375     foldRegsUsed _f z (Reload _)    = z
 376     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 377
 378 ---------------------
 379 -- prettyprinting
 380
 381 instance Outputable m => Outputable (ExtendWithSpills m) where
 382     ppr (Spill  regs) = ppr_regs "Spill"  regs
 383     ppr (Reload regs) = ppr_regs "Reload" regs
 384     ppr (NotSpillOrReload m) = ppr m
 385
 386 instance Outputable m => DebugNodes (ExtendWithSpills m) Last
 387
 388 ppr_regs :: String -> RegSet -> SDoc
 389 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 390   where commafy xs = hsep $ punctuate comma xs
 391
 392 instance Outputable DualLive where
 393   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 394       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 395           text "<nothing-live>"
 396       else
 397           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 398                          else (ppr_regs "live in regs =" regs),
 399                          if isEmptyUniqSet stack then PP.empty
 400                          else (ppr_regs "live on stack =" stack)]
 401
 402 instance Outputable AvailRegs where
 403   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 404                           else ppr_regs "available = all but" s
 405   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 406                           else ppr_regs "available = " s
 407
 408 my_trace :: String -> SDoc -> a -> a
 409 my_trace = if False then pprTrace else \_ _ a -> a
 410
 411 f4sep :: [SDoc] -> SDoc
 412 f4sep [] = fsep []
 413 f4sep (d:ds) = fsep (d : map (nest 4) ds)