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