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 m@(NotSpillOrReload nsr) = middle nsr
 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 [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 = filterRegsUsed is_stack_var formals
 166                    -- a formal that is expected on the stack; must spill
 167             in  if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
 168                     Nothing
 169                 else
 170                     let code  = if isEmptyUniqSet regs' then []
 171                                 else Reload regs' : []
 172                         code' = if isEmptyUniqSet needs_spilling then code
 173                                 else Spill needs_spilling : code
 174                     in
 175                     my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
 176                                                  ppr (Reload regs' :: M),
 177                                                  ppr (Spill needs_spilling :: M),
 178                                                  text "after", ppr m]) $
 179                     Just $ graphOfMiddles (m : code')
 180         middle _ = Nothing
 181
 182 -- | For conversion back to vanilla C--
 183 spillAndReloadComments :: M -> Middle
 184 spillAndReloadComments (NotSpillOrReload m) = m
 185 spillAndReloadComments (Spill  regs) = show_regs "Spill" regs
 186 spillAndReloadComments (Reload regs) = show_regs "Reload" regs
 187
 188 show_regs :: String -> RegSet -> Middle
 189 show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
 190
 191
 192 ----------------------------------------------------------------
 193 --- sinking reloads
 194
 195 -- The idea is to compute at each point the set of registers such that
 196 -- on every path to the point, the register is defined by a Reload
 197 -- instruction.  Then, if a use appears at such a point, we can safely
 198 -- insert a Reload right before the use.  Finally, we can eliminate
 199 -- the early reloads along with other dead assignments.
 200
 201 data AvailRegs = UniverseMinus RegSet
 202                | AvailRegs     RegSet
 203
 204
 205 availRegsLattice :: DataflowLattice AvailRegs
 206 availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
 207     where empty = UniverseMinus emptyRegSet
 208           -- | compute in the Tx monad to track whether anything has changed
 209           add new old =
 210             let join = interAvail new old in
 211             if join `smallerAvail` old then aTx join else noTx join
 212
 213
 214 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 215 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 216 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 217 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 218 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 219
 220 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 221 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 222 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 223 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 224 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 225
 226 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 227 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 228 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 229
 230 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 231 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 232 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 233
 234 elemAvail :: AvailRegs -> LocalReg -> Bool
 235 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 236 elemAvail (AvailRegs     s) r = elemRegSet r s
 237
 238 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
 239 cmmAvailableReloads g = env
 240     where env = runDFA availRegsLattice $
 241                 do run_f_anal transfer (fact_bot availRegsLattice) g
 242                    allFacts
 243           transfer :: FAnalysis M Last AvailRegs
 244           transfer = FComp "available-reloads analysis" first middle last exit
 245           exit _ = LastOutFacts []
 246           first avail _ = avail
 247           middle       = flip middleAvail
 248           last         = lastAvail
 249
 250
 251 -- | The transfer equations use the traditional 'gen' and 'kill'
 252 -- notations, which should be familiar from the dragon book.
 253 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 254 agen  a live = foldRegsUsed extendAvail     live a
 255 akill a live = foldRegsUsed deleteFromAvail live a
 256
 257 middleAvail :: M -> AvailRegs -> AvailRegs
 258 middleAvail (Spill _) = id
 259 middleAvail (Reload regs) = agen regs
 260 middleAvail (NotSpillOrReload m) = middle m
 261   where middle (MidComment {})                 = id
 262         middle (MidAssign lhs _expr)           = akill lhs
 263         middle (MidStore {})                   = id
 264         middle (MidUnsafeCall _tgt ress _args) = akill ress
 265         middle (CopyIn _ formals _)            = akill formals
 266         middle (CopyOut {})                    = id
 267
 268 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 269 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 270 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 271
 272 insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
 273 insertLateReloads g = mapM_blocks insertM g
 274     where env = cmmAvailableReloads g
 275           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 276           insertM b = functionalDFTx "late reloads" (insert b)
 277           insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 278           propagate h avail (ZTail m t) fuel =
 279               let (h', fuel') = maybe_add_reload h avail m fuel in
 280               propagate (ZHead h' m) (middleAvail m avail) t fuel'
 281           propagate h avail (ZLast l) fuel =
 282               let (h', fuel') = maybe_add_reload h avail l fuel in
 283               (zipht h' (ZLast l), fuel')
 284           maybe_add_reload h avail node fuel =
 285               let used = filterRegsUsed (elemAvail avail) node
 286               in  if fuel == 0 || isEmptyUniqSet used then (h, fuel)
 287                   else (ZHead h (Reload used), fuel-1)
 288
 289
 290 _lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
 291 _lateReloadsWithoutFuel g = map_blocks insert g
 292     where env = cmmAvailableReloads g
 293           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 294           insert (Block id tail) = propagate (ZFirst id) (avail id) tail
 295           propagate h avail (ZTail m t) =
 296             propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
 297           propagate h avail (ZLast l) =
 298             zipht (maybe_add_reload h avail l) (ZLast l)
 299           maybe_add_reload h avail node =
 300               let used = filterRegsUsed (elemAvail avail) node
 301               in  if isEmptyUniqSet used then h
 302                   else ZHead h (Reload used)
 303
 304
 305 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
 306 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
 307     where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
 308           exit   = Nothing
 309           last   = \_ _ -> Nothing
 310           middle = middleRemoveDeads
 311           first _ _ = Nothing
 312
 313 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 314 middleRemoveDeads _ (Spill _)  = Nothing
 315 middleRemoveDeads live (Reload s) =
 316     if sizeUniqSet worth_reloading < sizeUniqSet s then
 317         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 318                else graphOfMiddles [Reload worth_reloading]
 319     else
 320         Nothing
 321   where worth_reloading = intersectUniqSets s (in_regs live)
 322 middleRemoveDeads live (NotSpillOrReload m) = middle m
 323   where middle (MidAssign (CmmLocal reg') _)
 324                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 325         middle _ = Nothing
 326
 327
 328
 329 ---------------------
 330 -- register usage
 331
 332 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 333     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 334     foldRegsUsed _f z (Reload _)    = z
 335     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 336
 337 ---------------------
 338 -- prettyprinting
 339
 340 instance Outputable m => Outputable (ExtendWithSpills m) where
 341     ppr (Spill  regs) = ppr_regs "Spill"  regs
 342     ppr (Reload regs) = ppr_regs "Reload" regs
 343     ppr (NotSpillOrReload m) = ppr m
 344
 345 instance Outputable (LGraph M Last) where
 346     ppr = pprLgraph
 347
 348 instance DebugNodes M Last
 349
 350 ppr_regs :: String -> RegSet -> SDoc
 351 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 352   where commafy xs = hsep $ punctuate comma xs
 353
 354 instance Outputable DualLive where
 355   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 356       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 357           text "<nothing-live>"
 358       else
 359           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 360                          else (ppr_regs "live in regs =" regs),
 361                          if isEmptyUniqSet stack then PP.empty
 362                          else (ppr_regs "live on stack =" stack)]
 363
 364 instance Outputable AvailRegs where
 365   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 366                           else ppr_regs "available = all but" s
 367   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 368                           else ppr_regs "available = " s
 369
 370 my_trace :: String -> SDoc -> a -> a
 371 my_trace = if False then pprTrace else \_ _ a -> a
 372
 373 f4sep :: [SDoc] -> SDoc
 374 f4sep [] = fsep []
 375 f4sep (d:ds) = fsep (d : map (nest 4) ds)