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 True
 209     where empty = UniverseMinus emptyRegSet
 210           -- | compute in the Tx monad to track whether anything has changed
 211           add new old =
 212             let join = interAvail new old in
 213             if join `smallerAvail` old then aTx join else noTx join
 214
 215
 216 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
 217 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet`  s')
 218 interAvail (AvailRegs     s) (AvailRegs     s') = AvailRegs (s `timesRegSet` s')
 219 interAvail (AvailRegs     s) (UniverseMinus s') = AvailRegs (s  `minusRegSet` s')
 220 interAvail (UniverseMinus s) (AvailRegs     s') = AvailRegs (s' `minusRegSet` s )
 221
 222 smallerAvail :: AvailRegs -> AvailRegs -> Bool
 223 smallerAvail (AvailRegs     _) (UniverseMinus _)  = True
 224 smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 225 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 226 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 227
 228 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
 229 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
 230 extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 231
 232 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
 233 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
 234 deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 235
 236 elemAvail :: AvailRegs -> LocalReg -> Bool
 237 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 238 elemAvail (AvailRegs     s) r = elemRegSet r s
 239
 240 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
 241 cmmAvailableReloads g = env
 242     where env = runDFA availRegsLattice $
 243                 do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
 244                    allFacts
 245
 246 avail_reloads_transfer :: FAnalysis M Last AvailRegs
 247 avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
 248   where exit avail    = avail
 249         first avail _ = avail
 250         middle        = flip middleAvail
 251         last          = lastAvail
 252
 253
 254 -- | The transfer equations use the traditional 'gen' and 'kill'
 255 -- notations, which should be familiar from the dragon book.
 256 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 257 agen  a live = foldRegsUsed extendAvail     live a
 258 akill a live = foldRegsUsed deleteFromAvail live a
 259
 260 middleAvail :: M -> AvailRegs -> AvailRegs
 261 middleAvail (Spill _) = id
 262 middleAvail (Reload regs) = agen regs
 263 middleAvail (NotSpillOrReload m) = middle m
 264   where middle (MidComment {})                 = id
 265         middle (MidAssign lhs _expr)           = akill lhs
 266         middle (MidStore {})                   = id
 267         middle (MidUnsafeCall _tgt ress _args) = akill ress
 268         middle (MidAddToContext {})             = id
 269         middle (CopyIn _ formals _)            = akill formals
 270         middle (CopyOut {})                    = id
 271
 272 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 273 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 274 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 275
 276 insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
 277 insertLateReloads g = mapM_blocks insertM g
 278     where env = cmmAvailableReloads g
 279           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 280           insertM b = fuelConsumingPass "late reloads" (insert b)
 281           insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
 282           propagate h avail (ZTail m t) fuel =
 283               let (h', fuel') = maybe_add_reload h avail m fuel in
 284               propagate (ZHead h' m) (middleAvail m avail) t fuel'
 285           propagate h avail (ZLast l) fuel =
 286               let (h', fuel') = maybe_add_reload h avail l fuel in
 287               (zipht h' (ZLast l), fuel')
 288           maybe_add_reload h avail node fuel =
 289               let used = filterRegsUsed (elemAvail avail) node
 290               in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel)
 291                   else (ZHead h (Reload used), oneLessFuel fuel)
 292
 293 insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
 294 insertLateReloads' us g =
 295     runDFM us availRegsLattice $
 296     f_shallow_rewrite avail_reloads_transfer insert bot g
 297   where bot = fact_bot availRegsLattice
 298         insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
 299         middle :: AvailRegs -> M -> Maybe (Graph M Last)
 300         last   :: AvailRegs -> Last -> Maybe (Graph M Last)
 301         middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
 302         last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
 303         maybe_reload_before avail node tail =
 304             let used = filterRegsUsed (elemAvail avail) node
 305             in  if isEmptyUniqSet used then Nothing
 306                 else Just $ graphOfZTail $ ZTail (Reload used) tail
 307
 308 _lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
 309 _lateReloadsWithoutFuel g = map_blocks insert g
 310     where env = cmmAvailableReloads g
 311           avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
 312           insert (Block id tail) = propagate (ZFirst id) (avail id) tail
 313           propagate h avail (ZTail m t) =
 314             propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
 315           propagate h avail (ZLast l) =
 316             zipht (maybe_add_reload h avail l) (ZLast l)
 317           maybe_add_reload h avail node =
 318               let used = filterRegsUsed (elemAvail avail) node
 319               in  if isEmptyUniqSet used then h
 320                   else ZHead h (Reload used)
 321
 322
 323 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
 324 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
 325     where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
 326           exit   = Nothing
 327           last   = \_ _ -> Nothing
 328           middle = middleRemoveDeads
 329           first _ _ = Nothing
 330
 331 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 332 middleRemoveDeads _ (Spill _)  = Nothing
 333 middleRemoveDeads live (Reload s) =
 334     if sizeUniqSet worth_reloading < sizeUniqSet s then
 335         Just $ if isEmptyUniqSet worth_reloading then emptyGraph
 336                else graphOfMiddles [Reload worth_reloading]
 337     else
 338         Nothing
 339   where worth_reloading = intersectUniqSets s (in_regs live)
 340 middleRemoveDeads live (NotSpillOrReload m) = middle m
 341   where middle (MidAssign (CmmLocal reg') _)
 342                | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
 343         middle _ = Nothing
 344
 345
 346
 347 ---------------------
 348 -- register usage
 349
 350 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
 351     foldRegsUsed  f z (Spill  regs) = foldRegsUsed f z regs
 352     foldRegsUsed _f z (Reload _)    = z
 353     foldRegsUsed  f z (NotSpillOrReload m) = foldRegsUsed f z m
 354
 355 ---------------------
 356 -- prettyprinting
 357
 358 instance Outputable m => Outputable (ExtendWithSpills m) where
 359     ppr (Spill  regs) = ppr_regs "Spill"  regs
 360     ppr (Reload regs) = ppr_regs "Reload" regs
 361     ppr (NotSpillOrReload m) = ppr m
 362
 363 instance DebugNodes M Last
 364
 365 ppr_regs :: String -> RegSet -> SDoc
 366 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 367   where commafy xs = hsep $ punctuate comma xs
 368
 369 instance Outputable DualLive where
 370   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 371       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 372           text "<nothing-live>"
 373       else
 374           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 375                          else (ppr_regs "live in regs =" regs),
 376                          if isEmptyUniqSet stack then PP.empty
 377                          else (ppr_regs "live on stack =" stack)]
 378
 379 instance Outputable AvailRegs where
 380   ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
 381                           else ppr_regs "available = all but" s
 382   ppr (AvailRegs     s) = if isEmptyUniqSet s then text "<nothing available>"
 383                           else ppr_regs "available = " s
 384
 385 my_trace :: String -> SDoc -> a -> a
 386 my_trace = if False then pprTrace else \_ _ a -> a
 387
 388 f4sep :: [SDoc] -> SDoc
 389 f4sep [] = fsep []
 390 f4sep (d:ds) = fsep (d : map (nest 4) ds)