compiler/cmm/CmmSpillReload.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2
   3 module CmmSpillReload
   4   ( ExtendWithSpills(..)
   5   , DualLive(..)
   6   , dualLiveLattice, dualLiveness
   7   , insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   8   , dualLivenessWithInsertion
   9   , spillAndReloadComments
  10
  11   , availRegsLattice
  12   , cmmAvailableReloads
  13   )
  14 where
  15 import CmmExpr
  16 import CmmTx
  17 import CmmLiveZ
  18 import DFMonad
  19 import FastString
  20 import Maybe
  21 import MkZipCfg
  22 import Outputable hiding (empty)
  23 import qualified Outputable as PP
  24 import Panic
  25 import PprCmm()
  26 import UniqSet
  27 import ZipCfg
  28 import ZipCfgCmmRep
  29 import ZipDataflow
  30
  31 -- The point of this module is to insert spills and reloads to
  32 -- establish the invariant that at a call (or at any proc point with
  33 -- an established protocol) all live variables not expected in
  34 -- registers are sitting on the stack.  We use a backward analysis to
  35 -- insert spills and reloads.  It should some day be followed by a
  36 -- forward transformation to sink reloads as deeply as possible, so as
  37 -- to reduce register pressure.
  38
  39 data ExtendWithSpills m
  40     = NotSpillOrReload m
  41     | Spill  RegSet
  42     | Reload RegSet
  43
  44 type M = ExtendWithSpills Middle
  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 False
  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 dualLivenessWithInsertion :: BPass M Last DualLive
  80 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
  81
  82
  83 dualLiveness :: BAnalysis M Last DualLive
  84 dualLiveness = BComp "dual liveness" exit last middle first
  85     where exit   = empty
  86           last   = lastDualLiveness
  87           middle = middleDualLiveness
  88           first live _id = live
  89           empty = fact_bot dualLiveLattice
  90
  91             -- ^ could take a proc-point set and choose to spill here,
  92             -- but it's probably better to run this pass, choose
  93             -- proc-point protocols, insert more CopyIn nodes, and run
  94             -- this pass again
  95
  96 middleDualLiveness :: DualLive -> M -> DualLive
  97 middleDualLiveness live m@(Spill regs) =
  98     -- live-in on-stack requirements are satisfied;
  99     -- live-out in-regs obligations are created
 100       my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
 101       live'
 102     where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
 103                            , in_regs = in_regs live `plusRegSet` regs }
 104
 105 middleDualLiveness live m@(Reload regs) =
 106     -- live-in in-regs requirements are satisfied;
 107     -- live-out on-stack obligations are created
 108       my_trace "before" (f4sep [ppr m, text "liveness is", ppr live']) $
 109       live'
 110     where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
 111                            , in_regs = in_regs live `minusRegSet` regs }
 112
 113 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
 114
 115 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 116 lastDualLiveness env l = last l
 117   where last (LastReturn ress)       = changeRegs (gen ress) empty
 118         last (LastJump e args)       = changeRegs (gen e . gen args) empty
 119         last (LastBranch id args)    = changeRegs (gen args) $ env id
 120         last (LastCall tgt Nothing)  = changeRegs (gen tgt) empty
 121         last (LastCall tgt (Just k)) =
 122             -- nothing can be live in registers at this point
 123             -- only 'formals' can be in regs at this point
 124             let live = env k in
 125             if  isEmptyUniqSet (in_regs live) then
 126                 DualLive (on_stack live) (gen tgt emptyRegSet)
 127             else
 128                 panic "live values in registers at call continuation"
 129         last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
 130         last (LastSwitch e tbl)     = changeRegs (gen e) $ dualUnionList $
 131                                                              map env (catMaybes tbl)
 132         empty = fact_bot dualLiveLattice
 133
 134 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 135 gen  a live = foldRegsUsed extendRegSet      live a
 136 kill a live = foldRegsUsed delOneFromUniqSet live a
 137
 138 insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
 139 insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
 140     where exit   = Nothing
 141           last   = \_ _ -> Nothing
 142           middle = middleInsertSpillsAndReloads
 143           first _ _ = Nothing
 144             -- ^ could take a proc-point set and choose to spill here,
 145             -- but it's probably better to run this pass, choose
 146             -- proc-point protocols, insert more CopyIn nodes, and run
 147             -- this pass again
 148
 149
 150 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
 151 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 152 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 153 middleInsertSpillsAndReloads live (NotSpillOrReload m) = middle m
 154   where middle (MidAssign (CmmLocal reg') _) =
 155             if reg' `elemRegSet` on_stack live then -- must spill
 156                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg',
 157                                             text "after", ppr m]) $
 158                 Just $ graphOfMiddles [NotSpillOrReload m, Spill $ mkRegSet [reg']]
 159             else
 160                 Nothing
 161         middle (CopyIn _ formals _) =
 162             -- only 'formals' can be in regs at this point
 163             let regs' = kill formals (in_regs live) -- live in regs; must reload
 164                 is_stack_var r = elemRegSet r (on_stack live)
 165                 needs_spilling = -- a formal that is expected on the stack; must spill
 166                    foldRegsUsed (\rs r -> if is_stack_var r then extendRegSet rs r
 167                                           else rs) emptyRegSet formals
 168             in  if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
 169                     Nothing
 170                 else
 171                     let reload = if isEmptyUniqSet regs' then []
 172                                  else [Reload regs']
 173                         spill_reload = if isEmptyUniqSet needs_spilling then reload
 174                                        else Spill needs_spilling : reload
 175                         middles = NotSpillOrReload m : spill_reload
 176                     in
 177                     my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
 178                                                  ppr (Reload regs' :: M),
 179                                                  ppr (Spill needs_spilling :: M),
 180                                                  text "after", ppr m]) $
 181                     Just $ graphOfMiddles middles
 182         middle _ = Nothing
 183
 184 -- | For conversion back to vanilla C--
 185 spillAndReloadComments :: M -> Middle
 186 spillAndReloadComments (NotSpillOrReload m) = m
 187 spillAndReloadComments (Spill  regs) = show_regs "Spill" regs
 188 spillAndReloadComments (Reload regs) = show_regs "Reload" regs
 189
 190 show_regs :: String -> RegSet -> Middle
 191 show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
 192
 193
 194 ----------------------------------------------------------------
 195 --- sinking reloads
 196
 197 -- The idea is to compute at each point the set of registers such that
 198 -- on every path to the point, the register is defined by a Reload
 199 -- instruction.  Then, if a use appears at such a point, we can safely
 200 -- insert a Reload right before the use.  Finally, we can eliminate
 201 -- the early reloads along with other dead assignments.
 202
 203 data AvailRegs = UniverseMinus RegSet
 204                | AvailRegs     RegSet
 205
 206
 207 availRegsLattice :: DataflowLattice AvailRegs
 208 availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
 209     where empty = UniverseMinus emptyRegSet
 210           -- | compute in the Tx monad to track whether anything has changed
 211           add new old =
 212             let join = interAvail new old in
 213             if join `smallerAvail` old then aTx join else noTx join
 214
 215
 216 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 217 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 218 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 219 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 220 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 221
 222 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 223 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 224 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 225 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 226 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 227
 228 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 229 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 230 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 231
 232 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 233 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 234 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 235
 236 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
 237 cmmAvailableReloads g = env
 238     where env = runDFA availRegsLattice $
 239                 do run_f_anal transfer (fact_bot availRegsLattice) g
 240                    allFacts
 241           transfer :: FAnalysis M Last AvailRegs
 242           transfer = FComp "available-reloads analysis" first middle last exit
 243           exit _ = LastOutFacts []
 244           first avail _ = avail
 245           middle       = flip middleAvail
 246           last         = lastAvail
 247
 248
 249 -- | The transfer equations use the traditional 'gen' and 'kill'
 250 -- notations, which should be familiar from the dragon book.
 251 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 252 agen  a live = foldRegsUsed extendAvail     live a
 253 akill a live = foldRegsUsed deleteFromAvail live a
 254
 255 middleAvail :: M -> AvailRegs -> AvailRegs
 256 middleAvail (Spill _) = id
 257 middleAvail (Reload regs) = agen regs
 258 middleAvail (NotSpillOrReload m) = middle m
 259   where middle (MidNop)                        = id
 260         middle (MidComment {})                 = id
 261         middle (MidAssign lhs _expr)           = akill lhs
 262         middle (MidStore {})                   = id
 263         middle (MidUnsafeCall _tgt ress _args) = akill ress
 264         middle (CopyIn _ formals _)            = akill formals
 265         middle (CopyOut {})                    = id
 266
 267 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 268 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 269 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 270
 271
 272 ---------------------
 273 -- prettyprinting
 274
 275 instance Outputable m => Outputable (ExtendWithSpills m) where
 276     ppr (Spill  regs) = ppr_regs "Spill"  regs
 277     ppr (Reload regs) = ppr_regs "Reload" regs
 278     ppr (NotSpillOrReload m) = ppr m
 279
 280 instance Outputable (LGraph M Last) where
 281     ppr = pprLgraph
 282
 283 instance DebugNodes M Last
 284
 285 ppr_regs :: String -> RegSet -> SDoc
 286 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 287   where commafy xs = hsep $ punctuate comma xs
 288
 289 instance Outputable DualLive where
 290   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 291       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 292           text "<nothing-live>"
 293       else
 294           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 295                          else (ppr_regs "live in regs =" regs),
 296                          if isEmptyUniqSet stack then PP.empty
 297                          else (ppr_regs "live on stack =" stack)]
 298
 299 instance Outputable AvailRegs where
 300   ppr (UniverseMinus s) = ppr_regs "available = all but" s
 301   ppr (AvailRegs     s) = ppr_regs "available = " s
 302
 303 my_trace :: String -> SDoc -> a -> a
 304 my_trace = if False then pprTrace else \_ _ a -> a
 305
 306 f4sep :: [SDoc] -> SDoc
 307 f4sep [] = fsep []
 308 f4sep (d:ds) = fsep (d : map (nest 4) ds)