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 CmmExpr
  19 import CmmTx
  20 import CmmLiveZ
  21 import DFMonad
  22 import MkZipCfg
  23 import OptimizationFuel
  24 import PprCmm()
  25 import StackSlot
  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 Graph
 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 $ graphOfMiddles $ [Reload reloads]
 162             else Nothing
 163               where reloads = in_regs live
 164
 165
 166 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph 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 $ graphOfMiddles [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 $ graphOfMiddles (m : code')
 196         middle _ = Nothing
 197
 198 -- | For conversion back to vanilla C--
 199
 200 elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l)
 201 elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph
 202   where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l)
 203         block (Block id t) z =
 204           do (slots, blocks) <- z
 205              (slots, t)      <- tail t slots
 206              return (slots, Block id t : blocks)
 207         tail (ZLast l)   slots = return (slots, ZLast l)
 208         tail (ZTail m t) slots =
 209           do (slots, t) <- tail t slots
 210              middle m t slots
 211         middle (Spill  regs) t slots = foldUniqSet spill  (return (slots, t)) regs
 212         middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs
 213         middle (NotSpillOrReload m) t slots = return (slots, ZTail m t)
 214         move f r z = do let reg = CmmLocal r
 215                         (slots, t) <- z
 216                         (slots, slot) <- getSlot slots reg
 217                         return (slots, ZTail (f (CmmStack slot) reg) t)
 218         spill  = move (\ slot reg -> MidAssign slot (CmmReg reg))
 219         reload = move (\ slot reg -> MidAssign reg  (CmmReg slot))
 220
 221
 222 ----------------------------------------------------------------
 223 --- sinking reloads
 224
 225 -- The idea is to compute at each point the set of registers such that
 226 -- on every path to the point, the register is defined by a Reload
 227 -- instruction.  Then, if a use appears at such a point, we can safely
 228 -- insert a Reload right before the use.  Finally, we can eliminate
 229 -- the early reloads along with other dead assignments.
 230
 231 data AvailRegs = UniverseMinus RegSet
 232                | AvailRegs     RegSet
 233
 234
 235 availRegsLattice :: DataflowLattice AvailRegs
 236 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
 237                             -- last True <==> debugging on
 238     where empty = UniverseMinus emptyRegSet
 239           -- | compute in the Tx monad to track whether anything has changed
 240           add new old =
 241             let join = interAvail new old in
 242             if join `smallerAvail` old then aTx join else noTx join
 243
 244
 245 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 246 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 247 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 248 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 249 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 250
 251 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 252 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 253 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 254 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 255 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 256
 257 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 258 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 259 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 260
 261 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 262 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 263 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 264
 265 elemAvail :: AvailRegs -> LocalReg -> Bool
 266 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 267 elemAvail (AvailRegs     s) r = elemRegSet r s
 268
 269 type CmmAvail = BlockEnv AvailRegs
 270 type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
 271
 272 cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
 273 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 274     where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
 275                              avail_reloads_transfer empty g
 276           empty = (fact_bot availRegsLattice)
 277
 278 avail_reloads_transfer :: ForwardTransfers M Last AvailRegs
 279 avail_reloads_transfer = ForwardTransfers first middle last id
 280   where first avail _ = avail
 281         middle        = flip middleAvail
 282         last          = lastAvail
 283
 284 -- | The transfer equations use the traditional 'gen' and 'kill'
 285 -- notations, which should be familiar from the dragon book.
 286 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 287 agen  a live = foldRegsUsed extendAvail     live a
 288 akill a live = foldRegsUsed deleteFromAvail live a
 289
 290 -- Note: you can't sink the reload past a use.
 291 middleAvail :: M -> AvailRegs -> AvailRegs
 292 middleAvail (Spill _) = id
 293 middleAvail (Reload regs) = agen regs
 294 middleAvail (NotSpillOrReload m) = middle m
 295   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
 296         middle' (MidComment {})                 = id
 297         middle' (MidAssign lhs _expr)           = akill lhs
 298         middle' (MidStore {})                   = id
 299         middle' (MidUnsafeCall _tgt ress _args) = akill ress
 300         middle' (MidAddToContext {})            = id
 301         middle' (CopyIn _ formals _)            = akill formals
 302         middle' (CopyOut {})                    = id
 303
 304 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 305 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 306 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 307
 308 insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
 309 insertLateReloads g =
 310   do env <- cmmAvailableReloads g
 311      g   <- lGraphOfGraph g
 312      liftM graphOfLGraph $ mapM_blocks (insertM env) g
 313     where insertM env b = fuelConsumingPass "late reloads" (insert b)
 314             where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 315                   insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 316                   propagate h avail (ZTail m t) fuel =
 317                       let (h', fuel') = maybe_add_reload h avail m fuel in
 318                       propagate (ZHead h' m) (middleAvail m avail) t fuel'
 319                   propagate h avail (ZLast l) fuel =
 320                       let (h', fuel') = maybe_add_reload h avail l fuel in
 321                       (zipht h' (ZLast l), fuel')
 322                   maybe_add_reload h avail node fuel =
 323                       let used = filterRegsUsed (elemAvail avail) node
 324                       in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
 325                           then (h,fuel)
 326                           else (ZHead h (Reload used), oneLessFuel fuel)
 327
 328 type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
 329
 330 insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
 331 insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
 332     where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
 333                                availRegsLattice avail_reloads_transfer rewrites bot g
 334           bot = fact_bot availRegsLattice
 335           rewrites = ForwardRewrites first middle last exit
 336           first _ _ = Nothing
 337           middle :: AvailRegs -> M -> Maybe (Graph M Last)
 338           last   :: AvailRegs -> Last -> Maybe (Graph M Last)
 339           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 340           last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
 341           exit _ = Nothing
 342           maybe_reload_before avail node tail =
 343               let used = filterRegsUsed (elemAvail avail) node
 344               in  if isEmptyUniqSet used then Nothing
 345                   else Just $ graphOfZTail $ ZTail (Reload used) tail
 346
 347 removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
 348 removeDeadAssignmentsAndReloads procPoints g =
 349    liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
 350      where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 351                    dualLiveLattice (dualLiveTransfers procPoints)
 352                    rewrites (fact_bot dualLiveLattice) g
 353            rewrites = BackwardRewrites first middle last exit
 354            exit   = Nothing
 355            last   = \_ _ -> Nothing
 356            middle = middleRemoveDeads
 357            first _ _ = Nothing
 358
 359 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 360 middleRemoveDeads _ (Spill _)  = Nothing
 361 middleRemoveDeads live (Reload s) =
 362     if sizeUniqSet worth_reloading < sizeUniqSet s then
 363         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 364                else graphOfMiddles [Reload worth_reloading]
 365     else
 366         Nothing
 367   where worth_reloading = intersectUniqSets s (in_regs live)
 368 middleRemoveDeads live (NotSpillOrReload m) = middle m
 369   where middle (MidAssign (CmmLocal reg') _)
 370                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 371         middle _ = Nothing
 372
 373
 374
 375 ---------------------
 376 -- register usage
 377
 378 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 379     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 380     foldRegsUsed _f z (Reload _)    = z
 381     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 382
 383 ---------------------
 384 -- prettyprinting
 385
 386 instance Outputable m => Outputable (ExtendWithSpills m) where
 387     ppr (Spill  regs) = ppr_regs "Spill"  regs
 388     ppr (Reload regs) = ppr_regs "Reload" regs
 389     ppr (NotSpillOrReload m) = ppr m
 390
 391 instance Outputable m => DebugNodes (ExtendWithSpills m) Last
 392
 393 ppr_regs :: String -> RegSet -> SDoc
 394 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 395   where commafy xs = hsep $ punctuate comma xs
 396
 397 instance Outputable DualLive where
 398   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 399       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 400           text "<nothing-live>"
 401       else
 402           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 403                          else (ppr_regs "live in regs =" regs),
 404                          if isEmptyUniqSet stack then PP.empty
 405                          else (ppr_regs "live on stack =" stack)]
 406
 407 instance Outputable AvailRegs where
 408   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 409                           else ppr_regs "available = all but" s
 410   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 411                           else ppr_regs "available = " s
 412
 413 my_trace :: String -> SDoc -> a -> a
 414 my_trace = if False then pprTrace else \_ _ a -> a
 415
 416 f4sep :: [SDoc] -> SDoc
 417 f4sep [] = fsep []
 418 f4sep (d:ds) = fsep (d : map (nest 4) ds)