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