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 (MidAddToContext {})             = id
 266         middle (CopyIn _ formals _)            = akill formals
 267         middle (CopyOut {})                    = id
 268
 269 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 270 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 271 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 272
 273 insertLateReloads :: LGraph M Last -> DFTx (LGraph M Last)
 274 insertLateReloads g = mapM_blocks insertM g
 275     where env = cmmAvailableReloads g
 276           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 277           insertM b = functionalDFTx "late reloads" (insert b)
 278           insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 279           propagate h avail (ZTail m t) fuel =
 280               let (h', fuel') = maybe_add_reload h avail m fuel in
 281               propagate (ZHead h' m) (middleAvail m avail) t fuel'
 282           propagate h avail (ZLast l) fuel =
 283               let (h', fuel') = maybe_add_reload h avail l fuel in
 284               (zipht h' (ZLast l), fuel')
 285           maybe_add_reload h avail node fuel =
 286               let used = filterRegsUsed (elemAvail avail) node
 287               in  if fuel == 0 || isEmptyUniqSet used then (h, fuel)
 288                   else (ZHead h (Reload used), fuel-1)
 289
 290
 291 _lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
 292 _lateReloadsWithoutFuel g = map_blocks insert g
 293     where env = cmmAvailableReloads g
 294           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 295           insert (Block id tail) = propagate (ZFirst id) (avail id) tail
 296           propagate h avail (ZTail m t) =
 297             propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
 298           propagate h avail (ZLast l) =
 299             zipht (maybe_add_reload h avail l) (ZLast l)
 300           maybe_add_reload h avail node =
 301               let used = filterRegsUsed (elemAvail avail) node
 302               in  if isEmptyUniqSet used then h
 303                   else ZHead h (Reload used)
 304
 305
 306 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
 307 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
 308     where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
 309           exit   = Nothing
 310           last   = \_ _ -> Nothing
 311           middle = middleRemoveDeads
 312           first _ _ = Nothing
 313
 314 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 315 middleRemoveDeads _ (Spill _)  = Nothing
 316 middleRemoveDeads live (Reload s) =
 317     if sizeUniqSet worth_reloading < sizeUniqSet s then
 318         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 319                else graphOfMiddles [Reload worth_reloading]
 320     else
 321         Nothing
 322   where worth_reloading = intersectUniqSets s (in_regs live)
 323 middleRemoveDeads live (NotSpillOrReload m) = middle m
 324   where middle (MidAssign (CmmLocal reg') _)
 325                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 326         middle _ = Nothing
 327
 328
 329
 330 ---------------------
 331 -- register usage
 332
 333 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 334     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 335     foldRegsUsed _f z (Reload _)    = z
 336     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 337
 338 ---------------------
 339 -- prettyprinting
 340
 341 instance Outputable m => Outputable (ExtendWithSpills m) where
 342     ppr (Spill  regs) = ppr_regs "Spill"  regs
 343     ppr (Reload regs) = ppr_regs "Reload" regs
 344     ppr (NotSpillOrReload m) = ppr m
 345
 346 instance Outputable (LGraph M Last) where
 347     ppr = pprLgraph
 348
 349 instance DebugNodes M Last
 350
 351 ppr_regs :: String -> RegSet -> SDoc
 352 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 353   where commafy xs = hsep $ punctuate comma xs
 354
 355 instance Outputable DualLive where
 356   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 357       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 358           text "<nothing-live>"
 359       else
 360           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 361                          else (ppr_regs "live in regs =" regs),
 362                          if isEmptyUniqSet stack then PP.empty
 363                          else (ppr_regs "live on stack =" stack)]
 364
 365 instance Outputable AvailRegs where
 366   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 367                           else ppr_regs "available = all but" s
 368   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 369                           else ppr_regs "available = " s
 370
 371 my_trace :: String -> SDoc -> a -> a
 372 my_trace = if False then pprTrace else \_ _ a -> a
 373
 374 f4sep :: [SDoc] -> SDoc
 375 f4sep [] = fsep []
 376 f4sep (d:ds) = fsep (d : map (nest 4) ds)