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   , insertLateReloads'
  12   , removeDeadAssignmentsAndReloads
  13   )
  14 where
  15
  16 import BlockId
  17 import CmmExpr
  18 import CmmTx
  19 import CmmLiveZ
  20 import DFMonad
  21 import MkZipCfg
  22 import OptimizationFuel
  23 import PprCmm()
  24 import ZipCfg
  25 import ZipCfgCmmRep
  26 import ZipDataflow
  27
  28 import Maybes
  29 import Monad
  30 import Outputable hiding (empty)
  31 import qualified Outputable as PP
  32 import Panic
  33 import UniqSet
  34
  35 import Maybe
  36 import Prelude hiding (zip)
  37
  38 -- The point of this module is to insert spills and reloads to
  39 -- establish the invariant that at a call (or at any proc point with
  40 -- an established protocol) all live variables not expected in
  41 -- registers are sitting on the stack.  We use a backward analysis to
  42 -- insert spills and reloads.  It should be followed by a
  43 -- forward transformation to sink reloads as deeply as possible, so as
  44 -- to reduce register pressure.
  45
  46 -- A variable can be expected to be live in a register, live on the
  47 -- stack, or both.  This analysis ensures that spills and reloads are
  48 -- inserted as needed to make sure that every live variable needed
  49 -- after a call is available on the stack.  Spills are pushed back to
  50 -- their reaching definitions, but reloads are dropped wherever needed
  51 -- and will have to be sunk by a later forward transformation.
  52
  53 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  54
  55 dualUnion :: DualLive -> DualLive -> DualLive
  56 dualUnion (DualLive s r) (DualLive s' r') =
  57     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  58
  59 dualUnionList :: [DualLive] -> DualLive
  60 dualUnionList ls = DualLive ss rs
  61     where ss = unionManyUniqSets $ map on_stack ls
  62           rs = unionManyUniqSets $ map in_regs  ls
  63
  64 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  65 changeStack f live = live { on_stack = f (on_stack live) }
  66 changeRegs   f live = live { in_regs  = f (in_regs  live) }
  67
  68
  69 dualLiveLattice :: DataflowLattice DualLive
  70 dualLiveLattice =
  71       DataflowLattice "variables live in registers and on stack" empty add True
  72     where empty = DualLive emptyRegSet emptyRegSet
  73           -- | compute in the Tx monad to track whether anything has changed
  74           add new old = do stack <- add1 (on_stack new) (on_stack old)
  75                            regs  <- add1 (in_regs new)  (in_regs old)
  76                            return $ DualLive stack regs
  77           add1 = fact_add_to liveLattice
  78
  79 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
  80
  81 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
  82 dualLivenessWithInsertion procPoints g =
  83   liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
  84     where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
  85                                  dualLiveLattice (dualLiveTransfers procPoints)
  86                                  (insertSpillAndReloadRewrites procPoints) empty g
  87           empty = fact_bot dualLiveLattice
  88
  89 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
  90 dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
  91     where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
  92                               (dualLiveTransfers procPoints) empty g
  93           empty = fact_bot dualLiveLattice
  94
  95 dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive
  96 dualLiveTransfers procPoints = BackwardTransfers first middle last
  97     where last   = lastDualLiveness
  98           middle = middleDualLiveness
  99           first live _id =
 100             if elemBlockSet _id procPoints then -- live at procPoint => spill
 101               DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 102                        , in_regs  = emptyRegSet }
 103             else live
 104
 105 middleDualLiveness :: DualLive -> Middle -> DualLive
 106 middleDualLiveness live m =
 107   changeStack updSlots $ changeRegs (middleLiveness m) live
 108     where 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 :: (BlockId -> DualLive) -> Last -> DualLive
 118 lastDualLiveness env l = last l
 119   where last (LastReturn _)            = empty
 120         last (LastJump e _)            = changeRegs (gen e) empty
 121         last (LastBranch id)           = env id
 122         last (LastCall tgt Nothing _)  = changeRegs (gen tgt) empty
 123         last (LastCall tgt (Just k) _) =
 124             -- nothing can be live in registers at this point
 125             let live = env k in
 126             if  isEmptyUniqSet (in_regs live) then
 127                 DualLive (on_stack live) (gen tgt emptyRegSet)
 128             else
 129                 pprTrace "Offending party:" (ppr k <+> ppr live) $
 130                 panic "live values in registers at call continuation"
 131         last (LastCondBranch e t f)   = changeRegs (gen e) $ dualUnion (env t) (env f)
 132         last (LastSwitch e tbl)       = changeRegs (gen e) $ dualUnionList $
 133                                                              map env (catMaybes tbl)
 134         empty = fact_bot dualLiveLattice
 135
 136 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
 137 gen a live = foldRegsUsed extendRegSet      live a
 138
 139 insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive
 140 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
 141     where middle = middleInsertSpillsAndReloads
 142           last   = \_ _ -> Nothing
 143           exit = Nothing
 144           first live id =
 145             if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
 146               Just $ mkMiddles $ map reload $ uniqSetToList reloads
 147             else Nothing
 148             where reloads = in_regs live
 149
 150
 151 middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
 152 middleInsertSpillsAndReloads live m = middle m
 153   where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
 154           | reg == reg' = Nothing
 155         middle (MidAssign (CmmLocal reg) _) =
 156             if reg `elemRegSet` on_stack live then -- must spill
 157                  my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 158                                              text "after", ppr m]) $
 159                  Just $ mkMiddles $ [m, spill reg]
 160             else Nothing
 161         middle _ = Nothing
 162
 163 -- Generating spill and reload code
 164 regSlot :: LocalReg -> CmmExpr
 165 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 166
 167 spill, reload :: LocalReg -> Middle
 168 spill  r = MidStore  (regSlot r) (CmmReg $ CmmLocal r)
 169 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 170
 171 spillHead  :: ZHead Middle -> RegSet            -> ZHead Middle
 172 reloadTail :: RegSet       -> ZTail Middle Last -> ZTail Middle Last
 173 spillHead h regset = foldl spl h $ uniqSetToList regset
 174   where spl h r = ZHead h $ spill r
 175 reloadTail regset t = foldl rel t $ uniqSetToList regset
 176   where rel t r = ZTail (reload r) t
 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                             -- last True <==> debugging on
 194     where empty = UniverseMinus emptyRegSet
 195           -- | compute in the Tx monad to track whether anything has changed
 196           add new old =
 197             let join = interAvail new old in
 198             if join `smallerAvail` old then aTx join else noTx join
 199
 200
 201 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 202 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 203 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 204 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 205 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 206
 207 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 208 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 209 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 210 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 211 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 212
 213 --extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 214 --extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 215 --extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 216
 217 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 218 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 219 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 220
 221 elemAvail :: AvailRegs -> LocalReg -> Bool
 222 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 223 elemAvail (AvailRegs     s) r = elemRegSet r s
 224
 225 type CmmAvail = BlockEnv AvailRegs
 226 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
 227
 228 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
 229 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 230     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
 231                               avail_reloads_transfer empty g
 232           empty = (fact_bot availRegsLattice)
 233
 234 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
 235 avail_reloads_transfer = ForwardTransfers first middle last id
 236   where first avail _ = avail
 237         middle        = flip middleAvail
 238         last          = lastAvail
 239
 240 -- | The transfer equations use the traditional 'gen' and 'kill'
 241 -- notations, which should be familiar from the dragon book.
 242 --agen,
 243 akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 244 --agen  a live = foldRegsUsed extendAvail     live a
 245 akill a live = foldRegsUsed deleteFromAvail live a
 246
 247 -- Note: you can't sink the reload past a use.
 248 middleAvail :: Middle -> AvailRegs -> AvailRegs
 249 middleAvail m = middle m
 250   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
 251         middle' (MidComment {})                 = id
 252         middle' (MidAssign lhs _expr)           = akill lhs
 253         middle' (MidStore {})                   = id
 254         middle' (MidUnsafeCall _tgt ress _args) = akill ress
 255         middle' (MidAddToContext {})            = id
 256
 257 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 258 lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 259 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 260
 261 insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last)
 262 insertLateReloads g =
 263   do env <- cmmAvailableReloads g
 264      mapM_blocks (insertM env) g
 265     where insertM env b = fuelConsumingPass "late reloads" (insert b)
 266             where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 267                   insert (Block id off tail) fuel =
 268                     propagate (ZFirst id off) (avail id) tail fuel
 269                   propagate h avail (ZTail m t) fuel =
 270                       let (h', fuel') = maybe_add_reload h avail m fuel in
 271                       propagate (ZHead h' m) (middleAvail m avail) t fuel'
 272                   propagate h avail (ZLast l) fuel =
 273                       let (h', fuel') = maybe_add_reload h avail l fuel in
 274                       (zipht h' (ZLast l), fuel')
 275                   maybe_add_reload h avail node fuel =
 276                       let used = filterRegsUsed (elemAvail avail) node
 277                       in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
 278                           then (h,fuel)
 279                           else (spillHead h used, oneLessFuel fuel)
 280
 281 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last))
 282
 283 insertLateReloads' :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 284 insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
 285     where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
 286                                  availRegsLattice avail_reloads_transfer rewrites bot g
 287           bot = fact_bot availRegsLattice
 288           rewrites = ForwardRewrites first middle last exit
 289           first _ _ = Nothing
 290           middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
 291           last   :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
 292           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 293           last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
 294           exit _ = Nothing
 295           maybe_reload_before avail node tail =
 296               let used = filterRegsUsed (elemAvail avail) node
 297               in  if isEmptyUniqSet used then Nothing
 298                   else Just $ mkZTail $ reloadTail used tail
 299
 300 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 301 removeDeadAssignmentsAndReloads procPoints g =
 302    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
 303      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 304                    dualLiveLattice (dualLiveTransfers procPoints)
 305                    rewrites (fact_bot dualLiveLattice) g
 306            rewrites = BackwardRewrites first middle last exit
 307            exit   = Nothing
 308            last   = \_ _ -> Nothing
 309            middle = middleRemoveDeads
 310            first _ _ = Nothing
 311
 312 middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
 313 middleRemoveDeads live m = middle m
 314   where middle (MidAssign (CmmLocal reg') _)
 315                | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
 316         middle _ = Nothing
 317
 318
 319
 320 ---------------------
 321 -- prettyprinting
 322
 323 ppr_regs :: String -> RegSet -> SDoc
 324 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 325   where commafy xs = hsep $ punctuate comma xs
 326
 327 instance Outputable DualLive where
 328   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 329       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 330           text "<nothing-live>"
 331       else
 332           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 333                          else (ppr_regs "live in regs =" regs),
 334                          if isEmptyUniqSet stack then PP.empty
 335                          else (ppr_regs "live on stack =" stack)]
 336
 337 instance Outputable AvailRegs where
 338   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 339                           else ppr_regs "available = all but" s
 340   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 341                           else ppr_regs "available = " s
 342
 343 my_trace :: String -> SDoc -> a -> a
 344 my_trace = if False then pprTrace else \_ _ a -> a
 345
 346 f4sep :: [SDoc] -> SDoc
 347 f4sep [] = fsep []
 348 f4sep (d:ds) = fsep (d : map (nest 4) ds)