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   , insertLateReloads'
  14   , removeDeadAssignmentsAndReloads
  15   )
  16 where
  17
  18 import CmmExpr
  19 import CmmTx
  20 import CmmLiveZ
  21 import DFMonad
  22 import MkZipCfg
  23 import PprCmm()
  24 import ZipCfg
  25 import ZipCfgCmmRep
  26 import ZipDataflow0
  27
  28 import FastString
  29 import Maybes
  30 import Outputable hiding (empty)
  31 import qualified Outputable as PP
  32 import Panic
  33 import UniqSet
  34 import UniqSupply
  35
  36 import Maybe
  37 import Prelude hiding (zip)
  38
  39 -- The point of this module is to insert spills and reloads to
  40 -- establish the invariant that at a call (or at any proc point with
  41 -- an established protocol) all live variables not expected in
  42 -- registers are sitting on the stack.  We use a backward analysis to
  43 -- insert spills and reloads.  It should some day be followed by a
  44 -- forward transformation to sink reloads as deeply as possible, so as
  45 -- to reduce register pressure.
  46
  47 data ExtendWithSpills m
  48     = NotSpillOrReload m
  49     | Spill  RegSet
  50     | Reload RegSet
  51
  52 type M = ExtendWithSpills Middle
  53
  54 -- A variable can be expected to be live in a register, live on the
  55 -- stack, or both.  This analysis ensures that spills and reloads are
  56 -- inserted as needed to make sure that every live variable needed
  57 -- after a call is available on the stack.  Spills are pushed back to
  58 -- their reaching definitions, but reloads are dropped wherever needed
  59 -- and will have to be sunk by a later forward transformation.
  60
  61 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
  62
  63 dualUnion :: DualLive -> DualLive -> DualLive
  64 dualUnion (DualLive s r) (DualLive s' r') =
  65     DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
  66
  67 dualUnionList :: [DualLive] -> DualLive
  68 dualUnionList ls = DualLive ss rs
  69     where ss = unionManyUniqSets $ map on_stack ls
  70           rs = unionManyUniqSets $ map in_regs  ls
  71
  72 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
  73 _changeStack f live = live { on_stack = f (on_stack live) }
  74 changeRegs   f live = live { in_regs  = f (in_regs  live) }
  75
  76
  77 dualLiveLattice :: DataflowLattice DualLive
  78 dualLiveLattice =
  79       DataflowLattice "variables live in registers and on stack" empty add False
  80     where empty = DualLive emptyRegSet emptyRegSet
  81           -- | compute in the Tx monad to track whether anything has changed
  82           add new old = do stack <- add1 (on_stack new) (on_stack old)
  83                            regs  <- add1 (in_regs new)  (in_regs old)
  84                            return $ DualLive stack regs
  85           add1 = fact_add_to liveLattice
  86
  87 dualLivenessWithInsertion :: BPass M Last DualLive
  88 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
  89
  90 dualLiveness :: BAnalysis M Last DualLive
  91 dualLiveness = BComp "dual liveness" exit last middle first
  92     where exit   = empty
  93           last   = lastDualLiveness
  94           middle = middleDualLiveness
  95           first live _id = live
  96           empty = fact_bot dualLiveLattice
  97
  98             -- ^ could take a proc-point set and choose to spill here,
  99             -- but it's probably better to run this pass, choose
 100             -- proc-point protocols, insert more CopyIn nodes, and run
 101             -- this pass again
 102
 103 middleDualLiveness :: DualLive -> M -> DualLive
 104 middleDualLiveness live (Spill regs) = live'
 105     -- live-in on-stack requirements are satisfied;
 106     -- live-out in-regs obligations are created
 107     where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
 108                            , in_regs  = in_regs  live `plusRegSet`  regs }
 109
 110 middleDualLiveness live (Reload regs) = live'
 111     -- live-in in-regs requirements are satisfied;
 112     -- live-out on-stack obligations are created
 113     where live' = DualLive { on_stack = on_stack live `plusRegSet`  regs
 114                            , in_regs  = in_regs  live `minusRegSet` regs }
 115
 116 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
 117
 118 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 119 lastDualLiveness env l = last l
 120   where last (LastReturn)            = empty
 121         last (LastJump e)            = changeRegs (gen e) empty
 122         last (LastBranch id)         = env id
 123         last (LastCall tgt Nothing)  = changeRegs (gen tgt) empty
 124         last (LastCall tgt (Just k)) =
 125             -- nothing can be live in registers at this point
 126             let live = env k in
 127             if  isEmptyUniqSet (in_regs live) then
 128                 DualLive (on_stack live) (gen tgt emptyRegSet)
 129             else
 130                 panic "live values in registers at call continuation"
 131         last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
 132         last (LastSwitch e tbl)     = changeRegs (gen e) $ dualUnionList $
 133                                                              map env (catMaybes tbl)
 134         empty = fact_bot dualLiveLattice
 135
 136 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 137 gen  a live = foldRegsUsed extendRegSet      live a
 138 kill a live = foldRegsUsed delOneFromUniqSet live a
 139
 140 insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
 141 insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
 142     where exit   = Nothing
 143           last   = \_ _ -> Nothing
 144           middle = middleInsertSpillsAndReloads
 145           first _ _ = Nothing
 146             -- ^ could take a proc-point set and choose to spill here,
 147             -- but it's probably better to run this pass, choose
 148             -- proc-point protocols, insert more CopyIn nodes, and run
 149             -- this pass again
 150
 151
 152 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
 153 middleInsertSpillsAndReloads _ (Spill _)  = Nothing
 154 middleInsertSpillsAndReloads _ (Reload _) = Nothing
 155 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
 156   where middle (MidAssign (CmmLocal reg) _) =
 157             if reg `elemRegSet` on_stack live then -- must spill
 158                 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 159                                             text "after", ppr m]) $
 160                 Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
 161             else
 162                 Nothing
 163         middle (CopyIn _ formals _) =
 164             -- only 'formals' can be in regs at this point
 165             let regs' = kill formals (in_regs live) -- live in regs; must reload
 166                 is_stack_var r = elemRegSet r (on_stack live)
 167                 needs_spilling = filterRegsUsed is_stack_var formals
 168                    -- a formal that is expected on the stack; must spill
 169             in  if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
 170                     Nothing
 171                 else
 172                     let code  = if isEmptyUniqSet regs' then []
 173                                 else Reload regs' : []
 174                         code' = if isEmptyUniqSet needs_spilling then code
 175                                 else Spill needs_spilling : code
 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 (m : code')
 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 False
 209                             -- last True <==> debugging on
 210     where empty = UniverseMinus emptyRegSet
 211           -- | compute in the Tx monad to track whether anything has changed
 212           add new old =
 213             let join = interAvail new old in
 214             if join `smallerAvail` old then aTx join else noTx join
 215
 216
 217 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 218 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 219 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 220 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 221 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 222
 223 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 224 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 225 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 226 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 227 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 228
 229 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 230 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 231 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 232
 233 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 234 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 235 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 236
 237 elemAvail :: AvailRegs -> LocalReg -> Bool
 238 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 239 elemAvail (AvailRegs     s) r = elemRegSet r s
 240
 241 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
 242 cmmAvailableReloads g = env
 243     where env = runDFA availRegsLattice $
 244                 do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
 245                    getAllFacts
 246
 247 avail_reloads_transfer :: FAnalysis M Last AvailRegs
 248 avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
 249   where exit avail    = avail
 250         first avail _ = avail
 251         middle        = flip middleAvail
 252         last          = lastAvail
 253
 254
 255 -- | The transfer equations use the traditional 'gen' and 'kill'
 256 -- notations, which should be familiar from the dragon book.
 257 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 258 agen  a live = foldRegsUsed extendAvail     live a
 259 akill a live = foldRegsUsed deleteFromAvail live a
 260
 261 middleAvail :: M -> AvailRegs -> AvailRegs
 262 middleAvail (Spill _) = id
 263 middleAvail (Reload regs) = agen regs
 264 middleAvail (NotSpillOrReload m) = middle m
 265   where middle (MidComment {})                 = id
 266         middle (MidAssign lhs _expr)           = akill lhs
 267         middle (MidStore {})                   = id
 268         middle (MidUnsafeCall _tgt ress _args) = akill ress
 269         middle (MidAddToContext {})             = id
 270         middle (CopyIn _ formals _)            = akill formals
 271         middle (CopyOut {})                    = id
 272
 273 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 274 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 275 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 276
 277 insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
 278 insertLateReloads g = mapM_blocks insertM g
 279     where env = cmmAvailableReloads g
 280           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 281           insertM b = fuelConsumingPass "late reloads" (insert b)
 282           insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 283           propagate h avail (ZTail m t) fuel =
 284               let (h', fuel') = maybe_add_reload h avail m fuel in
 285               propagate (ZHead h' m) (middleAvail m avail) t fuel'
 286           propagate h avail (ZLast l) fuel =
 287               let (h', fuel') = maybe_add_reload h avail l fuel in
 288               (zipht h' (ZLast l), fuel')
 289           maybe_add_reload h avail node fuel =
 290               let used = filterRegsUsed (elemAvail avail) node
 291               in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel)
 292                   else (ZHead h (Reload used), oneLessFuel fuel)
 293
 294 insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
 295 insertLateReloads' us g =
 296     runDFM us availRegsLattice $
 297     f_shallow_rewrite avail_reloads_transfer insert bot g
 298   where bot = fact_bot availRegsLattice
 299         insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
 300         middle :: AvailRegs -> M -> Maybe (Graph M Last)
 301         last   :: AvailRegs -> Last -> Maybe (Graph M Last)
 302         middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 303         last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
 304         maybe_reload_before avail node tail =
 305             let used = filterRegsUsed (elemAvail avail) node
 306             in  if isEmptyUniqSet used then Nothing
 307                 else Just $ graphOfZTail $ ZTail (Reload used) tail
 308
 309 _lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
 310 _lateReloadsWithoutFuel g = map_blocks insert g
 311     where env = cmmAvailableReloads g
 312           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 313           insert (Block id tail) = propagate (ZFirst id) (avail id) tail
 314           propagate h avail (ZTail m t) =
 315             propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
 316           propagate h avail (ZLast l) =
 317             zipht (maybe_add_reload h avail l) (ZLast l)
 318           maybe_add_reload h avail node =
 319               let used = filterRegsUsed (elemAvail avail) node
 320               in  if isEmptyUniqSet used then h
 321                   else ZHead h (Reload used)
 322
 323
 324 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
 325 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
 326     where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
 327           exit   = Nothing
 328           last   = \_ _ -> Nothing
 329           middle = middleRemoveDeads
 330           first _ _ = Nothing
 331
 332 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 333 middleRemoveDeads _ (Spill _)  = Nothing
 334 middleRemoveDeads live (Reload s) =
 335     if sizeUniqSet worth_reloading < sizeUniqSet s then
 336         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 337                else graphOfMiddles [Reload worth_reloading]
 338     else
 339         Nothing
 340   where worth_reloading = intersectUniqSets s (in_regs live)
 341 middleRemoveDeads live (NotSpillOrReload m) = middle m
 342   where middle (MidAssign (CmmLocal reg') _)
 343                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 344         middle _ = Nothing
 345
 346
 347
 348 ---------------------
 349 -- register usage
 350
 351 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 352     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 353     foldRegsUsed _f z (Reload _)    = z
 354     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 355
 356 ---------------------
 357 -- prettyprinting
 358
 359 instance Outputable m => Outputable (ExtendWithSpills m) where
 360     ppr (Spill  regs) = ppr_regs "Spill"  regs
 361     ppr (Reload regs) = ppr_regs "Reload" regs
 362     ppr (NotSpillOrReload m) = ppr m
 363
 364 instance Outputable m => DebugNodes (ExtendWithSpills m) Last
 365
 366 ppr_regs :: String -> RegSet -> SDoc
 367 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 368   where commafy xs = hsep $ punctuate comma xs
 369
 370 instance Outputable DualLive where
 371   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 372       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 373           text "<nothing-live>"
 374       else
 375           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 376                          else (ppr_regs "live in regs =" regs),
 377                          if isEmptyUniqSet stack then PP.empty
 378                          else (ppr_regs "live on stack =" stack)]
 379
 380 instance Outputable AvailRegs where
 381   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 382                           else ppr_regs "available = all but" s
 383   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 384                           else ppr_regs "available = " s
 385
 386 my_trace :: String -> SDoc -> a -> a
 387 my_trace = if False then pprTrace else \_ _ a -> a
 388
 389 f4sep :: [SDoc] -> SDoc
 390 f4sep [] = fsep []
 391 f4sep (d:ds) = fsep (d : map (nest 4) ds)