compiler/cmm/CmmSpillReload.hs

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