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   , insertLateReloads
  13   , removeDeadAssignmentsAndReloads
  14   )
  15 where
  16
  17 import CmmExpr
  18 import CmmTx
  19 import CmmLiveZ
  20 import DFMonad
  21 import MkZipCfg
  22 import PprCmm()
  23 import ZipCfg
  24 import ZipCfgCmmRep
  25 import ZipDataflow
  26
  27 import FastString
  28 import Maybes
  29 import Outputable hiding (empty)
  30 import qualified Outputable as PP
  31 import Panic
  32 import UniqSet
  33
  34 import Maybe
  35 import Prelude hiding (zip)
  36
  37 -- The point of this module is to insert spills and reloads to
  38 -- establish the invariant that at a call (or at any proc point with
  39 -- an established protocol) all live variables not expected in
  40 -- registers are sitting on the stack.  We use a backward analysis to
  41 -- insert spills and reloads.  It should some day be followed by a
  42 -- forward transformation to sink reloads as deeply as possible, so as
  43 -- to reduce register pressure.
  44
  45 data ExtendWithSpills m
  46     = NotSpillOrReload m
  47     | Spill  RegSet
  48     | Reload RegSet
  49
  50 type M = ExtendWithSpills Middle
  51
  52 -- A variable can be expected to be live in a register, live on the
  53 -- stack, or both.  This analysis ensures that spills and reloads are
  54 -- inserted as needed to make sure that every live variable needed
  55 -- after a call is available on the stack.  Spills are pushed back to
  56 -- their reaching definitions, but reloads are dropped wherever needed
  57 -- and will have to be sunk by a later forward transformation.
  58
  59 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  60
  61 dualUnion :: DualLive -> DualLive -> DualLive
  62 dualUnion (DualLive s r) (DualLive s' r') =
  63     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  64
  65 dualUnionList :: [DualLive] -> DualLive
  66 dualUnionList ls = DualLive ss rs
  67     where ss = unionManyUniqSets $ map on_stack ls
  68           rs = unionManyUniqSets $ map in_regs  ls
  69
  70 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  71 _changeStack f live = live { on_stack = f (on_stack live) }
  72 changeRegs   f live = live { in_regs  = f (in_regs  live) }
  73
  74
  75 dualLiveLattice :: DataflowLattice DualLive
  76 dualLiveLattice =
  77       DataflowLattice "variables live in registers and on stack" empty add False
  78     where empty = DualLive emptyRegSet emptyRegSet
  79           -- | compute in the Tx monad to track whether anything has changed
  80           add new old = do stack <- add1 (on_stack new) (on_stack old)
  81                            regs  <- add1 (in_regs new)  (in_regs old)
  82                            return $ DualLive stack regs
  83           add1 = fact_add_to liveLattice
  84
  85 dualLivenessWithInsertion :: BPass M Last DualLive
  86 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
  87
  88 dualLiveness :: BAnalysis M Last DualLive
  89 dualLiveness = BComp "dual liveness" exit last middle first
  90     where exit   = empty
  91           last   = lastDualLiveness
  92           middle = middleDualLiveness
  93           first live _id = live
  94           empty = fact_bot dualLiveLattice
  95
  96             -- ^ could take a proc-point set and choose to spill here,
  97             -- but it's probably better to run this pass, choose
  98             -- proc-point protocols, insert more CopyIn nodes, and run
  99             -- this pass again
 100
 101 middleDualLiveness :: DualLive -> M -> DualLive
 102 middleDualLiveness live (Spill regs) = live'
 103     -- live-in on-stack requirements are satisfied;
 104     -- live-out in-regs obligations are created
 105     where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
 106                            , in_regs  = in_regs  live `plusRegSet`  regs }
 107
 108 middleDualLiveness live (Reload regs) = live'
 109     -- live-in in-regs requirements are satisfied;
 110     -- live-out on-stack obligations are created
 111     where live' = DualLive { on_stack = on_stack live `plusRegSet`  regs
 112                            , in_regs  = in_regs  live `minusRegSet` regs }
 113
 114 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
 115
 116 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 117 lastDualLiveness env l = last l
 118   where last (LastReturn)            = empty
 119         last (LastJump e)            = changeRegs (gen e) empty
 120         last (LastBranch id)         = env id
 121         last (LastCall tgt Nothing)  = changeRegs (gen tgt) empty
 122         last (LastCall tgt (Just k)) =
 123             -- nothing can be live in registers 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 elemAvail :: AvailRegs -> LocalReg -> Bool
 237 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 238 elemAvail (AvailRegs     s) r = elemRegSet r s
 239
 240 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
 241 cmmAvailableReloads g = env
 242     where env = runDFA availRegsLattice $
 243                 do run_f_anal transfer (fact_bot availRegsLattice) g
 244                    allFacts
 245           transfer :: FAnalysis M Last AvailRegs
 246           transfer = FComp "available-reloads analysis" first middle last exit
 247           exit _ = LastOutFacts []
 248           first avail _ = avail
 249           middle       = flip middleAvail
 250           last         = lastAvail
 251
 252
 253 -- | The transfer equations use the traditional 'gen' and 'kill'
 254 -- notations, which should be familiar from the dragon book.
 255 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 256 agen  a live = foldRegsUsed extendAvail     live a
 257 akill a live = foldRegsUsed deleteFromAvail live a
 258
 259 middleAvail :: M -> AvailRegs -> AvailRegs
 260 middleAvail (Spill _) = id
 261 middleAvail (Reload regs) = agen regs
 262 middleAvail (NotSpillOrReload m) = middle m
 263   where middle (MidComment {})                 = id
 264         middle (MidAssign lhs _expr)           = akill lhs
 265         middle (MidStore {})                   = id
 266         middle (MidUnsafeCall _tgt ress _args) = akill ress
 267         middle (CopyIn _ formals _)            = akill formals
 268         middle (CopyOut {})                    = id
 269
 270 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 271 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 272 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 273
 274 insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
 275 insertLateReloads g = mapM_blocks insertM g
 276     where env = cmmAvailableReloads g
 277           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 278           insertM b = functionalDFTx "late reloads" (insert b)
 279           insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 280           propagate h avail (ZTail m t) fuel =
 281               let (h', fuel') = maybe_add_reload h avail m fuel in
 282               propagate (ZHead h' m) (middleAvail m avail) t fuel'
 283           propagate h avail (ZLast l) fuel =
 284               let (h', fuel') = maybe_add_reload h avail l fuel in
 285               (zipht h' (ZLast l), fuel')
 286           maybe_add_reload h avail node fuel =
 287               let used = foldRegsUsed
 288                          (\u r -> if elemAvail avail r then extendRegSet u r else u)
 289                          emptyRegSet node
 290               in  if fuel == 0 || isEmptyUniqSet used then (h, fuel)
 291                   else (ZHead h (Reload used), fuel-1)
 292
 293
 294 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
 295 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
 296     where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
 297           exit   = Nothing
 298           last   = \_ _ -> Nothing
 299           middle = middleRemoveDeads
 300           first _ _ = Nothing
 301
 302 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 303 middleRemoveDeads _ (Spill _)  = Nothing
 304 middleRemoveDeads live (Reload s) =
 305     if sizeUniqSet worth_reloading < sizeUniqSet s then
 306         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 307                else graphOfMiddles [Reload worth_reloading]
 308     else
 309         Nothing
 310   where worth_reloading = intersectUniqSets s (in_regs live)
 311 middleRemoveDeads live (NotSpillOrReload m) = middle m
 312   where middle (MidAssign (CmmLocal reg') _)
 313                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 314         middle _ = Nothing
 315
 316
 317
 318 ---------------------
 319 -- register usage
 320
 321 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 322     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 323     foldRegsUsed _f z (Reload _)    = z
 324     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 325
 326 ---------------------
 327 -- prettyprinting
 328
 329 instance Outputable m => Outputable (ExtendWithSpills m) where
 330     ppr (Spill  regs) = ppr_regs "Spill"  regs
 331     ppr (Reload regs) = ppr_regs "Reload" regs
 332     ppr (NotSpillOrReload m) = ppr m
 333
 334 instance Outputable (LGraph M Last) where
 335     ppr = pprLgraph
 336
 337 instance DebugNodes M Last
 338
 339 ppr_regs :: String -> RegSet -> SDoc
 340 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 341   where commafy xs = hsep $ punctuate comma xs
 342
 343 instance Outputable DualLive where
 344   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 345       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 346           text "<nothing-live>"
 347       else
 348           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 349                          else (ppr_regs "live in regs =" regs),
 350                          if isEmptyUniqSet stack then PP.empty
 351                          else (ppr_regs "live on stack =" stack)]
 352
 353 instance Outputable AvailRegs where
 354   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 355                           else ppr_regs "available = all but" s
 356   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 357                           else ppr_regs "available = " s
 358
 359 my_trace :: String -> SDoc -> a -> a
 360 my_trace = if False then pprTrace else \_ _ a -> a
 361
 362 f4sep :: [SDoc] -> SDoc
 363 f4sep [] = fsep []
 364 f4sep (d:ds) = fsep (d : map (nest 4) ds)