compiler/cmm/CmmSpillReload.hs

   1 {-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
   2 -- Norman likes local bindings
   3 -- If this module lives on I'd like to get rid of this flag in due course
   4
   5 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
   6 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
   7 #if __GLASGOW_HASKELL__ >= 701
   8 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
   9 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
  10 #endif
  11
  12 module CmmSpillReload
  13   ( DualLive(..)
  14   , dualLiveLattice, dualLiveTransfers, dualLiveness
  15   --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
  16   , dualLivenessWithInsertion
  17
  18   , rewriteAssignments
  19   , removeDeadAssignmentsAndReloads
  20   )
  21 where
  22
  23 import BlockId
  24 import Cmm
  25 import CmmExpr
  26 import CmmLive
  27 import OptimizationFuel
  28 import StgCmmUtils
  29
  30 import Control.Monad
  31 import Outputable hiding (empty)
  32 import qualified Outputable as PP
  33 import UniqSet
  34 import UniqFM
  35 import Unique
  36
  37 import Compiler.Hoopl hiding (Unique)
  38 import Data.Maybe
  39 import Prelude hiding (succ, zip)
  40
  41 {- Note [Overview of spill/reload]
  42 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  43 The point of this module is to insert spills and reloads to
  44 establish the invariant that at a call (or at any proc point with
  45 an established protocol) all live variables not expected in
  46 registers are sitting on the stack.  We use a backward analysis to
  47 insert spills and reloads.  It should be followed by a
  48 forward transformation to sink reloads as deeply as possible, so as
  49 to reduce register pressure.
  50
  51 A variable can be expected to be live in a register, live on the
  52 stack, or both.  This analysis ensures that spills and reloads are
  53 inserted as needed to make sure that every live variable needed
  54 after a call is available on the stack.  Spills are pushed back to
  55 their reaching definitions, but reloads are dropped wherever needed
  56 and will have to be sunk by a later forward transformation.
  57 -}
  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 = DataflowLattice "variables live in registers and on stack" empty add
  77     where empty = DualLive emptyRegSet emptyRegSet
  78           add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
  79             where (change1, stack) = add1 (on_stack old) (on_stack new)
  80                   (change2, regs)  = add1 (in_regs old)  (in_regs new)
  81           add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
  82             where join = unionUniqSets old new
  83
  84 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
  85 dualLivenessWithInsertion procPoints g =
  86   liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
  87                                                 (dualLiveTransfers (g_entry g) procPoints)
  88                                                 (insertSpillAndReloadRewrites g procPoints)
  89
  90 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
  91 dualLiveness procPoints g =
  92   liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
  93
  94 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
  95 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
  96     where first :: CmmNode C O -> DualLive -> DualLive
  97           first (CmmEntry id) live = check live id $  -- live at procPoint => spill
  98             if id /= entry && setMember id procPoints
  99                then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
 100                              , in_regs  = emptyRegSet }
 101                else live
 102             where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
 103
 104           middle :: CmmNode O O -> DualLive -> DualLive
 105           middle m = changeStack updSlots
 106                    . changeRegs  updRegs
 107             where -- Reuse middle of liveness analysis from CmmLive
 108                   updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
 109
 110                   updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
 111                   spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
 112                   spill  live _ = live
 113                   reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
 114                   reload live _ = live
 115                   check (RegSlot (LocalReg _ ty), o, w) x
 116                      | o == w && w == widthInBytes (typeWidth ty) = x
 117                   check _ _ = panic "middleDualLiveness unsupported: slices"
 118           last :: CmmNode O C -> FactBase DualLive -> DualLive
 119           last l fb = case l of
 120             CmmBranch id                   -> lkp id
 121             l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
 122             l@(CmmCall {cml_cont=Just k})  -> call l k
 123             l@(CmmForeignCall {succ=k})    -> call l k
 124             l@(CmmCondBranch _ t f)        -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
 125             l@(CmmSwitch _ tbl)            -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
 126             where empty = fact_bot dualLiveLattice
 127                   lkp id = empty `fromMaybe` lookupFact id fb
 128                   call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
 129
 130 gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
 131 gen  a live = foldRegsUsed extendRegSet     live a
 132 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
 133 kill a live = foldRegsDefd deleteFromRegSet live a
 134
 135 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
 136 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
 137   -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 138   -- but GHC miscompiles it, see bug #4044.
 139     where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
 140           first e@(CmmEntry id) live = return $
 141             if id /= (g_entry graph) && setMember id procPoints then
 142               case map reload (uniqSetToList spill_regs) of
 143                 [] -> Nothing
 144                 is -> Just $ mkFirst e <*> mkMiddles is
 145             else Nothing
 146               where
 147                 -- If we are splitting procedures, we need the LastForeignCall
 148                 -- to spill its results to the stack because they will only
 149                 -- be used by a separate procedure (so they can't stay in LocalRegs).
 150                 splitting = True
 151                 spill_regs = if splitting then in_regs live
 152                              else in_regs live `minusRegSet` defs
 153                 defs = case mapLookup id firstDefs of
 154                            Just defs -> defs
 155                            Nothing   -> emptyRegSet
 156                 -- A LastForeignCall may contain some definitions, which take place
 157                 -- on return from the function call. Therefore, we build a map (firstDefs)
 158                 -- from BlockId to the set of variables defined on return to the BlockId.
 159                 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
 160                 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
 161                 addLive b env = case lastNode b of
 162                                   CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
 163                                   _                                 -> env
 164                 add bid defs env = mapInsert bid defs'' env
 165                   where defs'' = case mapLookup bid env of
 166                                    Just defs' -> timesRegSet defs defs'
 167                                    Nothing    -> defs
 168
 169           middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 170           middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
 171           middle m@(CmmAssign (CmmLocal reg) _) live = return $
 172               if reg `elemRegSet` on_stack live then -- must spill
 173                    my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
 174                                                text "after"{-, ppr m-}]) $
 175                    Just $ mkMiddles $ [m, spill reg]
 176               else Nothing
 177           middle _ _ = return Nothing
 178
 179           nothing _ _ = return Nothing
 180
 181 regSlot :: LocalReg -> CmmExpr
 182 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 183
 184 spill, reload :: LocalReg -> CmmNode O O
 185 spill  r = CmmStore  (regSlot r) (CmmReg $ CmmLocal r)
 186 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 187
 188 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
 189 removeDeadAssignmentsAndReloads procPoints g =
 190    liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
 191                                                  (dualLiveTransfers (g_entry g) procPoints)
 192                                                  rewrites
 193    where rewrites = deepBwdRw3 nothing middle nothing
 194          -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
 195          -- but GHC panics while compiling, see bug #4045.
 196          middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
 197          middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
 198          -- XXX maybe this should be somewhere else...
 199          middle (CmmAssign lhs (CmmReg rhs))   _ | lhs == rhs = return $ Just emptyGraph
 200          middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
 201          middle _ _ = return Nothing
 202
 203          nothing _ _ = return Nothing
 204
 205 ----------------------------------------------------------------
 206 --- Usage information
 207
 208 -- We decorate all register assignments with usage information,
 209 -- that is, the maximum number of times the register is referenced
 210 -- while it is live along all outgoing control paths.  There are a few
 211 -- subtleties here:
 212 --
 213 --  - If a register goes dead, and then becomes live again, the usages
 214 --    of the disjoint live range don't count towards the original range.
 215 --
 216 --          a = 1; // used once
 217 --          b = a;
 218 --          a = 2; // used once
 219 --          c = a;
 220 --
 221 --  - A register may be used multiple times, but these all reside in
 222 --    different control paths, such that any given execution only uses
 223 --    it once. In that case, the usage count may still be 1.
 224 --
 225 --          a = 1; // used once
 226 --          if (b) {
 227 --              c = a + 3;
 228 --          } else {
 229 --              c = a + 1;
 230 --          }
 231 --
 232 --    This policy corresponds to an inlining strategy that does not
 233 --    duplicate computation but may increase binary size.
 234 --
 235 --  - If we naively implement a usage count, we have a counting to
 236 --    infinity problem across joins.  Furthermore, knowing that
 237 --    something is used 2 or more times in one runtime execution isn't
 238 --    particularly useful for optimizations (inlining may be beneficial,
 239 --    but there's no way of knowing that without register pressure
 240 --    information.)
 241 --
 242 --          while (...) {
 243 --              // first iteration, b used once
 244 --              // second iteration, b used twice
 245 --              // third iteration ...
 246 --              a = b;
 247 --          }
 248 --          // b used zero times
 249 --
 250 --    There is an orthogonal question, which is that for every runtime
 251 --    execution, the register may be used only once, but if we inline it
 252 --    in every conditional path, the binary size might increase a lot.
 253 --    But tracking this information would be tricky, because it violates
 254 --    the finite lattice restriction Hoopl requires for termination;
 255 --    we'd thus need to supply an alternate proof, which is probably
 256 --    something we should defer until we actually have an optimization
 257 --    that would take advantage of this.  (This might also interact
 258 --    strangely with liveness information.)
 259 --
 260 --          a = ...;
 261 --          // a is used one time, but in X different paths
 262 --          case (b) of
 263 --              1 -> ... a ...
 264 --              2 -> ... a ...
 265 --              3 -> ... a ...
 266 --              ...
 267 --
 268 --  This analysis is very similar to liveness analysis; we just keep a
 269 --  little extra info. (Maybe we should move it to CmmLive, and subsume
 270 --  the old liveness analysis.)
 271
 272 data RegUsage = SingleUse | ManyUse
 273     deriving (Ord, Eq, Show)
 274 -- Absence in map = ZeroUse
 275
 276 {-
 277 -- minBound is bottom, maxBound is top, least-upper-bound is max
 278 -- ToDo: Put this in Hoopl.  Note that this isn't as useful as I
 279 -- originally hoped, because you usually want to leave out the bottom
 280 -- element when you have things like this put in maps.  Maybe f is
 281 -- useful on its own as a combining function.
 282 boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
 283 boundedOrdLattice n = DataflowLattice n minBound f
 284     where f _ (OldFact x) (NewFact y)
 285             | x >= y    = (NoChange,   x)
 286             | otherwise = (SomeChange, y)
 287 -}
 288
 289 -- Custom node type we'll rewrite to.  CmmAssign nodes to local
 290 -- registers are replaced with AssignLocal nodes.
 291 data WithRegUsage n e x where
 292     Plain       :: n e x -> WithRegUsage n e x
 293     AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
 294
 295 instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
 296     foldRegsUsed f z (Plain n) = foldRegsUsed f z n
 297     foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
 298
 299 instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
 300     foldRegsDefd f z (Plain n) = foldRegsDefd f z n
 301     foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
 302
 303 instance NonLocal n => NonLocal (WithRegUsage n) where
 304     entryLabel (Plain n) = entryLabel n
 305     successors (Plain n) = successors n
 306
 307 liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
 308 liftRegUsage = mapGraph Plain
 309
 310 eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
 311 eraseRegUsage = mapGraph f
 312     where f :: WithRegUsage CmmNode e x -> CmmNode e x
 313           f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
 314           f (Plain n) = n
 315
 316 type UsageMap = UniqFM RegUsage
 317
 318 usageLattice :: DataflowLattice UsageMap
 319 usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
 320     where f _ (OldFact x) (NewFact y)
 321             | x >= y    = (NoChange,   x)
 322             | otherwise = (SomeChange, y)
 323
 324 -- We reuse the names 'gen' and 'kill', although we're doing something
 325 -- slightly different from the Dragon Book
 326 usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
 327 usageTransfer = mkBTransfer3 first middle last
 328     where first _ f = f
 329           middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
 330           middle n f = gen_kill n f
 331           last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
 332           -- Checking for CmmCall/CmmForeignCall is unnecessary, because
 333           -- spills/reloads have already occurred by the time we do this
 334           -- analysis.
 335           -- XXX Deprecated warning is puzzling: what label are we
 336           -- supposed to use?
 337           -- ToDo: With a bit more cleverness here, we can avoid
 338           -- disappointment and heartbreak associated with the inability
 339           -- to inline into CmmCall and CmmForeignCall by
 340           -- over-estimating the usage to be ManyUse.
 341           last n f = gen_kill n (joinOutFacts usageLattice n f)
 342           gen_kill a = gen a . kill a
 343           gen  a f = foldRegsUsed increaseUsage f a
 344           kill a f = foldRegsDefd delFromUFM f a
 345           increaseUsage f r = addToUFM_C combine f r SingleUse
 346             where combine _ _ = ManyUse
 347
 348 usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
 349 usageRewrite = mkBRewrite3 first middle last
 350     where first  _ _ = return Nothing
 351           middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
 352           middle (Plain (CmmAssign (CmmLocal l) e)) f
 353                      = return . Just
 354                      $ case lookupUFM f l of
 355                             Nothing    -> emptyGraph
 356                             Just usage -> mkMiddle (AssignLocal l e usage)
 357           middle _ _ = return Nothing
 358           last   _ _ = return Nothing
 359
 360 type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
 361 annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
 362 annotateUsage vanilla_g =
 363     let g = modifyGraph liftRegUsage vanilla_g
 364     in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
 365                                    analRewBwd usageLattice usageTransfer usageRewrite
 366
 367 ----------------------------------------------------------------
 368 --- Assignment tracking
 369
 370 -- The idea is to maintain a map of local registers do expressions,
 371 -- such that the value of that register is the same as the value of that
 372 -- expression at any given time.  We can then do several things,
 373 -- as described by Assignment.
 374
 375 -- Assignment describes the various optimizations that are valid
 376 -- at a given point in the program.
 377 data Assignment =
 378 -- This assignment can always be inlined.  It is cheap or single-use.
 379                   AlwaysInline CmmExpr
 380 -- This assignment should be sunk down to its first use.  (This will
 381 -- increase code size if the register is used in multiple control flow
 382 -- paths, but won't increase execution time, and the reduction of
 383 -- register pressure is worth it.)
 384                 | AlwaysSink CmmExpr
 385 -- We cannot safely optimize occurrences of this local register. (This
 386 -- corresponds to top in the lattice structure.)
 387                 | NeverOptimize
 388
 389 -- Extract the expression that is being assigned to
 390 xassign :: Assignment -> Maybe CmmExpr
 391 xassign (AlwaysInline e) = Just e
 392 xassign (AlwaysSink e)   = Just e
 393 xassign NeverOptimize    = Nothing
 394
 395 -- Extracts the expression, but only if they're the same constructor
 396 xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
 397 xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
 398 xassign2 (AlwaysSink e, AlwaysSink e')     = Just (e, e')
 399 xassign2 _ = Nothing
 400
 401 -- Note: We'd like to make decisions about "not optimizing" as soon as
 402 -- possible, because this will make running the transfer function more
 403 -- efficient.
 404 type AssignmentMap = UniqFM Assignment
 405
 406 assignmentLattice :: DataflowLattice AssignmentMap
 407 assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
 408     where add _ (OldFact old) (NewFact new)
 409             = case (old, new) of
 410                 (NeverOptimize, _) -> (NoChange,   NeverOptimize)
 411                 (_, NeverOptimize) -> (SomeChange, NeverOptimize)
 412                 (xassign2 -> Just (e, e'))
 413                     | e == e'   -> (NoChange, old)
 414                     | otherwise -> (SomeChange, NeverOptimize)
 415                 _ -> (SomeChange, NeverOptimize)
 416
 417 -- Deletes sinks from assignment map, because /this/ is the place
 418 -- where it will be sunk to.
 419 deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
 420 deleteSinks n m = foldRegsUsed (adjustUFM f) m n
 421   where f (AlwaysSink _) = NeverOptimize
 422         f old = old
 423
 424 -- Invalidates any expressions that use a register.
 425 invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
 426 -- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
 427 invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
 428     where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
 429           f _ _ m = m
 430 {- This requires the entire spine of the map to be continually rebuilt,
 431  - which causes crazy memory usage!
 432 invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
 433   where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
 434         invalidateUsers' _ old = old
 435 -}
 436
 437 -- Note [foldUFM performance]
 438 -- These calls to fold UFM no longer leak memory, but they do cause
 439 -- pretty killer amounts of allocation.  So they'll be something to
 440 -- optimize; we need an algorithmic change to prevent us from having to
 441 -- traverse the /entire/ map continually.
 442
 443 middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
 444
 445 -- Algorithm for annotated assignments:
 446 --  1. Delete any sinking assignments that were used by this instruction
 447 --  2. Add the assignment to our list of valid local assignments with
 448 --     the correct optimization policy.
 449 --  3. Look for all assignments that reference that register and
 450 --     invalidate them.
 451 middleAssignment n@(AssignLocal r e usage) assign
 452     = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
 453       where add m = addToUFM m r
 454                   $ case usage of
 455                         SingleUse -> AlwaysInline e
 456                         ManyUse   -> decide e
 457             decide CmmLit{}       = AlwaysInline e
 458             decide CmmReg{}       = AlwaysInline e
 459             decide CmmLoad{}      = AlwaysSink e
 460             decide CmmStackSlot{} = AlwaysSink e
 461             decide CmmMachOp{}    = AlwaysSink e
 462             -- We'll always inline simple operations on the global
 463             -- registers, to reduce register pressure: Sp - 4 or Hp - 8
 464             -- EZY: Justify this optimization more carefully.
 465             decide CmmRegOff{}    = AlwaysInline e
 466
 467 -- Algorithm for unannotated assignments of global registers:
 468 -- 1. Delete any sinking assignments that were used by this instruction
 469 -- 2. Look for all assignments that reference this register and
 470 --    invalidate them.
 471 middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
 472     = invalidateUsersOf reg . deleteSinks n $ assign
 473
 474 -- Algorithm for unannotated assignments of *local* registers: do
 475 -- nothing (it's a reload, so no state should have changed)
 476 middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
 477
 478 -- Algorithm for stores:
 479 --  1. Delete any sinking assignments that were used by this instruction
 480 --  2. Look for all assignments that load from memory locations that
 481 --     were clobbered by this store and invalidate them.
 482 middleAssignment (Plain n@(CmmStore lhs rhs)) assign
 483     = let m = deleteSinks n assign
 484       in foldUFM_Directly f m m -- [foldUFM performance]
 485       where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
 486             f _ _ m = m
 487 {- Also leaky
 488     = mapUFM_Directly p . deleteSinks n $ assign
 489       -- ToDo: There's a missed opportunity here: even if a memory
 490       -- access we're attempting to sink gets clobbered at some
 491       -- location, it's still /better/ to sink it to right before the
 492       -- point where it gets clobbered.  How might we do this?
 493       -- Unfortunately, it's too late to change the assignment...
 494       where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
 495             p _ old = old
 496 -}
 497
 498 -- Assumption: Unsafe foreign calls don't clobber memory
 499 -- Since foreign calls clobber caller saved registers, we need
 500 -- invalidate any assignments that reference those global registers.
 501 -- This is kind of expensive. (One way to optimize this might be to
 502 -- store extra information about expressions that allow this and other
 503 -- checks to be done cheaply.)
 504 middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
 505     = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
 506     where deleteCallerSaves m = foldUFM_Directly f m m
 507           f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
 508           f _ _ m = m
 509           g (CmmReg (CmmGlobal r)) _      | callerSaves r = True
 510           g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
 511           g _ b = b
 512
 513 middleAssignment (Plain (CmmComment {})) assign
 514     = assign
 515
 516 -- Assumptions:
 517 --  * Writes using Hp do not overlap with any other memory locations
 518 --    (An important invariant being relied on here is that we only ever
 519 --    use Hp to allocate values on the heap, which appears to be the
 520 --    case given hpReg usage, and that our heap writing code doesn't
 521 --    do anything stupid like overlapping writes.)
 522 --  * Stack slots do not overlap with any other memory locations
 523 --  * Stack slots for different areas do not overlap
 524 --  * Stack slots within the same area and different offsets may
 525 --    overlap; we need to do a size check (see 'overlaps').
 526 --  * Register slots only overlap with themselves.  (But this shouldn't
 527 --    happen in practice, because we'll fail to inline a reload across
 528 --    the next spill.)
 529 --  * Non stack-slot stores always conflict with each other.  (This is
 530 --    not always the case; we could probably do something special for Hp)
 531 clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
 532          -> (Unique,  CmmExpr) -- (register, expression) that may be clobbered
 533          -> Bool
 534 clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
 535 clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
 536 -- ToDo: Also catch MachOp case
 537 clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
 538     | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
 539 clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
 540     where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
 541             = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
 542           f (CmmLoad e _)    = containsStackSlot e
 543           f (CmmMachOp _ es) = or (map f es)
 544           f _                = False
 545           -- Maybe there's an invariant broken if this actually ever
 546           -- returns True
 547           containsStackSlot (CmmLoad{})      = True -- load of a load, all bets off
 548           containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
 549           containsStackSlot (CmmStackSlot{}) = True
 550           containsStackSlot _ = False
 551 clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
 552     where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
 553           f _ = False
 554 clobbers _ (_, e) = f e
 555     where f (CmmLoad (CmmStackSlot _ _) _) = False
 556           f (CmmLoad{}) = True -- conservative
 557           f (CmmMachOp _ es) = or (map f es)
 558           f _ = False
 559
 560 -- Check for memory overlapping.
 561 -- Diagram:
 562 --      4      8     12
 563 --      s -w-  o
 564 --      [ I32  ]
 565 --      [    F64     ]
 566 --      s'   -w'-    o'
 567 type CallSubArea = (AreaId, Int, Int) -- area, offset, width
 568 overlaps :: CallSubArea -> CallSubArea -> Bool
 569 overlaps (a, _, _) (a', _, _) | a /= a' = False
 570 overlaps (_, o, w) (_, o', w') =
 571     let s  = o  - w
 572         s' = o' - w'
 573     in (s' < o) && (s < o) -- Not LTE, because [ I32  ][ I32  ] is OK
 574
 575 lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
 576 -- Variables are dead across calls, so invalidating all mappings is justified
 577 lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
 578 lastAssignment (Plain (CmmForeignCall {succ=k}))  assign = [(k, mapUFM (const NeverOptimize) assign)]
 579 lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
 580
 581 assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
 582 assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
 583
 584 assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
 585 assignmentRewrite = mkFRewrite3 first middle last
 586     where
 587         first _ _ = return Nothing
 588         middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
 589         middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
 590         middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
 591         last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
 592         -- Tuple is (inline?, reloads)
 593         precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
 594             where f (i, l) r = case lookupUFM assign r of
 595                                 Just (AlwaysSink e)   -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
 596                                 Just (AlwaysInline _) -> (True, l)
 597                                 Just NeverOptimize    -> (i, l)
 598                                 -- This case can show up when we have
 599                                 -- limited optimization fuel.
 600                                 Nothing -> (i, l)
 601         rewrite _ (False, []) _ _ = Nothing
 602         -- Note [CmmCall Inline Hack]
 603         -- Conservative hack: don't do any inlining on what will
 604         -- be translated into an OldCmm CmmCalls, since the code
 605         -- produced here tends to be unproblematic and I need to write
 606         -- lint passes to ensure that we don't put anything in the
 607         -- arguments that could be construed as a global register by
 608         -- some later translation pass.  (For example, slots will turn
 609         -- into dereferences of Sp).  See [Register parameter passing].
 610         -- ToDo: Fix this up to only bug out if all inlines were for
 611         -- CmmExprs with global registers (we can't use the
 612         -- straightforward mapExpDeep call, in this case.) ToDo: We miss
 613         -- an opportunity here, where all possible inlinings should
 614         -- instead be sunk.
 615         rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
 616         rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
 617
 618         rewriteLocal _ (False, []) _ _ _ _ = Nothing
 619         rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
 620             where n' = AssignLocal l e' u
 621                   e' = if i then wrapRecExp (inlineExp assign) e else e
 622             -- inlinable check omitted, since we can always inline into
 623             -- assignments.
 624
 625         inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
 626         inline False _ n = n
 627         inline True  _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
 628         inline True assign n = mapExpDeep (inlineExp assign) n
 629
 630         inlineExp assign old@(CmmReg (CmmLocal r))
 631           = case lookupUFM assign r of
 632               Just (AlwaysInline x) -> x
 633               _ -> old
 634         inlineExp assign old@(CmmRegOff (CmmLocal r) i)
 635           = case lookupUFM assign r of
 636               Just (AlwaysInline x) ->
 637                 case x of
 638                     (CmmRegOff r' i') -> CmmRegOff r' (i + i')
 639                     _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
 640                           where rep = typeWidth (localRegType r)
 641               _ -> old
 642         inlineExp _ old = old
 643
 644         inlinable :: CmmNode e x -> Bool
 645         inlinable (CmmCall{}) = False
 646         inlinable (CmmForeignCall{}) = False
 647         inlinable (CmmUnsafeForeignCall{}) = False
 648         inlinable _ = True
 649
 650 rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
 651 rewriteAssignments g = do
 652   g'  <- annotateUsage g
 653   g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
 654                                      analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
 655   return (modifyGraph eraseRegUsage g'')
 656
 657 ---------------------
 658 -- prettyprinting
 659
 660 ppr_regs :: String -> RegSet -> SDoc
 661 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
 662   where commafy xs = hsep $ punctuate comma xs
 663
 664 instance Outputable DualLive where
 665   ppr (DualLive {in_regs = regs, on_stack = stack}) =
 666       if isEmptyUniqSet regs && isEmptyUniqSet stack then
 667           text "<nothing-live>"
 668       else
 669           nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
 670                          else (ppr_regs "live in regs =" regs),
 671                          if isEmptyUniqSet stack then PP.empty
 672                          else (ppr_regs "live on stack =" stack)]
 673
 674 -- ToDo: Outputable instance for UsageMap and AssignmentMap
 675
 676 my_trace :: String -> SDoc -> a -> a
 677 my_trace = if False then pprTrace else \_ _ a -> a
 678
 679 f4sep :: [SDoc] -> SDoc
 680 f4sep [] = fsep []
 681 f4sep (d:ds) = fsep (d : map (nest 4) ds)