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