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 True
  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 live id = 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 :: DualLive -> Middle -> DualLive
 106 middleDualLiveness live m =
 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 :: (BlockId -> DualLive) -> Last -> DualLive
 120 lastDualLiveness env l = last l
 121   where last (LastBranch id)          = env id
 122         last l@(LastCall tgt Nothing  _ _) = changeRegs (gen l . kill l) empty
 123         last l@(LastCall tgt (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 e t f)   =
 131             changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
 132         last l@(LastSwitch e 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 live id =
 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 :: DualLive -> Middle -> Maybe (AGraph Middle Last)
 156 middleInsertSpillsAndReloads live m = 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 reloadTail :: RegSet       -> ZTail Middle Last -> ZTail Middle Last
 181 reloadTail regset t = foldl rel t $ uniqSetToList regset
 182   where rel t r = ZTail (reload r) t
 183
 184 ----------------------------------------------------------------
 185 --- sinking reloads
 186
 187 -- The idea is to compute at each point the set of registers such that
 188 -- on every path to the point, the register is defined by a Reload
 189 -- instruction.  Then, if a use appears at such a point, we can safely
 190 -- insert a Reload right before the use.  Finally, we can eliminate
 191 -- the early reloads along with other dead assignments.
 192
 193 data AvailRegs = UniverseMinus RegSet
 194                | AvailRegs     RegSet
 195
 196
 197 availRegsLattice :: DataflowLattice AvailRegs
 198 availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
 199                             -- last True <==> debugging on
 200     where empty = UniverseMinus emptyRegSet
 201           -- | compute in the Tx monad to track whether anything has changed
 202           add new old =
 203             let join = interAvail new old in
 204             if join `smallerAvail` old then aTx join else noTx join
 205
 206
 207 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 208 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 209 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 210 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 211 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 212
 213 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 214 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 215 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 216 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 217 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 218
 219 --extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 220 --extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 221 --extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 222
 223 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 224 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 225 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 226
 227 elemAvail :: AvailRegs -> LocalReg -> Bool
 228 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 229 elemAvail (AvailRegs     s) r = elemRegSet r s
 230
 231 type CmmAvail = BlockEnv AvailRegs
 232 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
 233
 234 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
 235 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
 236     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
 237                               avail_reloads_transfer empty g
 238           empty = fact_bot availRegsLattice
 239
 240 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
 241 avail_reloads_transfer = ForwardTransfers first middle last id
 242   where first avail _ = avail
 243         middle        = flip middleAvail
 244         last          = lastAvail
 245
 246 -- | The transfer equations use the traditional 'gen' and 'kill'
 247 -- notations, which should be familiar from the dragon book.
 248 --agen,
 249 akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 250 --agen  a live = foldRegsUsed extendAvail     live a
 251 akill a live = foldRegsUsed deleteFromAvail live a
 252
 253 -- Note: you can't sink the reload past a use.
 254 middleAvail :: Middle -> AvailRegs -> AvailRegs
 255 middleAvail m = middle m
 256   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
 257         middle' (MidComment {})                 live = live
 258         middle' (MidAssign lhs _expr)           live = akill lhs live
 259         middle' (MidStore {})                   live = live
 260         middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet
 261
 262 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 263 lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 264 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 265
 266 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
 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 rewrites bot g
 272           bot = fact_bot availRegsLattice
 273           rewrites = ForwardRewrites first middle last exit
 274           first _ _ = Nothing
 275           middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
 276           last   :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
 277           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 278           last   avail l = maybe_reload_before avail l (ZLast (LastOther l))
 279           exit _ = Nothing
 280           maybe_reload_before avail node tail =
 281               let used = filterRegsUsed (elemAvail avail) node
 282               in  if isEmptyUniqSet used then Nothing
 283                   else Just $ mkZTail $ reloadTail used tail
 284
 285 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 286 removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
 287    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
 288      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
 289                    dualLiveLattice (dualLiveTransfers entry procPoints)
 290                    rewrites (fact_bot dualLiveLattice) g
 291            rewrites = BackwardRewrites first middle last exit
 292            exit   = Nothing
 293            last   = \_ _ -> Nothing
 294            middle = middleRemoveDeads
 295            first _ _ = Nothing
 296
 297 middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
 298 middleRemoveDeads live m = middle m
 299   where middle (MidAssign (CmmLocal reg') _)
 300                | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
 301         middle _ = Nothing
 302
 303
 304
 305 ---------------------
 306 -- prettyprinting
 307
 308 ppr_regs :: String -> RegSet -> SDoc
 309 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 310   where commafy xs = hsep $ punctuate comma xs
 311
 312 instance Outputable DualLive where
 313   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 314       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 315           text "<nothing-live>"
 316       else
 317           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 318                          else (ppr_regs "live in regs =" regs),
 319                          if isEmptyUniqSet stack then PP.empty
 320                          else (ppr_regs "live on stack =" stack)]
 321
 322 instance Outputable AvailRegs where
 323   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 324                           else ppr_regs "available = all but" s
 325   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 326                           else ppr_regs "available = " s
 327
 328 my_trace :: String -> SDoc -> a -> a
 329 my_trace = if False then pprTrace else \_ _ a -> a
 330
 331 f4sep :: [SDoc] -> SDoc
 332 f4sep [] = fsep []
 333 f4sep (d:ds) = fsep (d : map (nest 4) ds)