compiler/nativeGen/RegAlloc/Linear/Main.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- The register allocator
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {-
  10 The algorithm is roughly:
  11
  12   1) Compute strongly connected components of the basic block list.
  13
  14   2) Compute liveness (mapping from pseudo register to
  15      point(s) of death?).
  16
  17   3) Walk instructions in each basic block.  We keep track of
  18         (a) Free real registers (a bitmap?)
  19         (b) Current assignment of temporaries to machine registers and/or
  20             spill slots (call this the "assignment").
  21         (c) Partial mapping from basic block ids to a virt-to-loc mapping.
  22             When we first encounter a branch to a basic block,
  23             we fill in its entry in this table with the current mapping.
  24
  25      For each instruction:
  26         (a) For each real register clobbered by this instruction:
  27             If a temporary resides in it,
  28                 If the temporary is live after this instruction,
  29                     Move the temporary to another (non-clobbered & free) reg,
  30                     or spill it to memory.  Mark the temporary as residing
  31                     in both memory and a register if it was spilled (it might
  32                     need to be read by this instruction).
  33             (ToDo: this is wrong for jump instructions?)
  34
  35         (b) For each temporary *read* by the instruction:
  36             If the temporary does not have a real register allocation:
  37                 - Allocate a real register from the free list.  If
  38                   the list is empty:
  39                   - Find a temporary to spill.  Pick one that is
  40                     not used in this instruction (ToDo: not
  41                     used for a while...)
  42                   - generate a spill instruction
  43                 - If the temporary was previously spilled,
  44                   generate an instruction to read the temp from its spill loc.
  45             (optimisation: if we can see that a real register is going to
  46             be used soon, then don't use it for allocation).
  47
  48         (c) Update the current assignment
  49
  50         (d) If the instruction is a branch:
  51               if the destination block already has a register assignment,
  52                 Generate a new block with fixup code and redirect the
  53                 jump to the new block.
  54               else,
  55                 Update the block id->assignment mapping with the current
  56                 assignment.
  57
  58         (e) Delete all register assignments for temps which are read
  59             (only) and die here.  Update the free register list.
  60
  61         (f) Mark all registers clobbered by this instruction as not free,
  62             and mark temporaries which have been spilled due to clobbering
  63             as in memory (step (a) marks then as in both mem & reg).
  64
  65         (g) For each temporary *written* by this instruction:
  66             Allocate a real register as for (b), spilling something
  67             else if necessary.
  68                 - except when updating the assignment, drop any memory
  69                   locations that the temporary was previously in, since
  70                   they will be no longer valid after this instruction.
  71
  72         (h) Delete all register assignments for temps which are
  73             written and die here (there should rarely be any).  Update
  74             the free register list.
  75
  76         (i) Rewrite the instruction with the new mapping.
  77
  78         (j) For each spilled reg known to be now dead, re-add its stack slot
  79             to the free list.
  80
  81 -}
  82
  83 module RegAlloc.Linear.Main (
  84         regAlloc,
  85         module  RegAlloc.Linear.Base,
  86         module  RegAlloc.Linear.Stats
  87   ) where
  88
  89 #include "HsVersions.h"
  90
  91
  92 import RegAlloc.Linear.State
  93 import RegAlloc.Linear.Base
  94 import RegAlloc.Linear.StackMap
  95 import RegAlloc.Linear.FreeRegs
  96 import RegAlloc.Linear.Stats
  97 import RegAlloc.Linear.JoinToTargets
  98 import qualified RegAlloc.Linear.PPC.FreeRegs   as PPC
  99 import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC
 100 import qualified RegAlloc.Linear.X86.FreeRegs   as X86
 101 import TargetReg
 102 import RegAlloc.Liveness
 103 import Instruction
 104 import Reg
 105
 106 import BlockId
 107 import OldCmm hiding (RegSet)
 108
 109 import Digraph
 110 import DynFlags
 111 import Unique
 112 import UniqSet
 113 import UniqFM
 114 import UniqSupply
 115 import Outputable
 116 import Platform
 117
 118 import Data.Maybe
 119 import Data.List
 120 import Control.Monad
 121
 122 #include "../includes/stg/MachRegs.h"
 123
 124
 125 -- -----------------------------------------------------------------------------
 126 -- Top level of the register allocator
 127
 128 -- Allocate registers
 129 regAlloc
 130         :: (Outputable instr, Instruction instr)
 131         => DynFlags
 132         -> LiveCmmTop instr
 133         -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
 134
 135 regAlloc _ (CmmData sec d)
 136         = return
 137                 ( CmmData sec d
 138                 , Nothing )
 139
 140 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
 141         = return ( CmmProc info lbl (ListGraph [])
 142                  , Nothing )
 143
 144 regAlloc dflags (CmmProc static lbl sccs)
 145         | LiveInfo info (Just first_id) (Just block_live) _     <- static
 146         = do
 147                 -- do register allocation on each component.
 148                 (final_blocks, stats)
 149                         <- linearRegAlloc dflags first_id block_live sccs
 150
 151                 -- make sure the block that was first in the input list
 152                 --      stays at the front of the output
 153                 let ((first':_), rest')
 154                                 = partition ((== first_id) . blockId) final_blocks
 155
 156                 return  ( CmmProc info lbl (ListGraph (first' : rest'))
 157                         , Just stats)
 158
 159 -- bogus. to make non-exhaustive match warning go away.
 160 regAlloc _ (CmmProc _ _ _)
 161         = panic "RegAllocLinear.regAlloc: no match"
 162
 163
 164 -- -----------------------------------------------------------------------------
 165 -- Linear sweep to allocate registers
 166
 167
 168 -- | Do register allocation on some basic blocks.
 169 --   But be careful to allocate a block in an SCC only if it has
 170 --   an entry in the block map or it is the first block.
 171 --
 172 linearRegAlloc
 173         :: (Outputable instr, Instruction instr)
 174         => DynFlags
 175         -> BlockId                      -- ^ the first block
 176         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
 177         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
 178         -> UniqSM ([NatBasicBlock instr], RegAllocStats)
 179
 180 linearRegAlloc dflags first_id block_live sccs
 181  = case platformArch $ targetPlatform dflags of
 182    ArchX86     -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
 183    ArchX86_64  -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
 184    ArchSPARC   -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
 185    ArchPPC     -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs)   first_id block_live sccs
 186    ArchPPC_64  -> panic "linearRegAlloc ArchPPC_64"
 187    ArchUnknown -> panic "linearRegAlloc ArchUnknown"
 188
 189 linearRegAlloc'
 190         :: (FR freeRegs, Outputable instr, Instruction instr)
 191         => freeRegs
 192         -> BlockId                      -- ^ the first block
 193         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
 194         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
 195         -> UniqSM ([NatBasicBlock instr], RegAllocStats)
 196
 197 linearRegAlloc' initFreeRegs first_id block_live sccs
 198  = do   us      <- getUs
 199         let (_, _, stats, blocks) =
 200                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
 201                     $ linearRA_SCCs first_id block_live [] sccs
 202         return  (blocks, stats)
 203
 204
 205 linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
 206               => BlockId
 207               -> BlockMap RegSet
 208               -> [NatBasicBlock instr]
 209               -> [SCC (LiveBasicBlock instr)]
 210               -> RegM freeRegs [NatBasicBlock instr]
 211
 212 linearRA_SCCs _ _ blocksAcc []
 213         = return $ reverse blocksAcc
 214
 215 linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
 216  = do   blocks' <- processBlock block_live block
 217         linearRA_SCCs first_id block_live
 218                 ((reverse blocks') ++ blocksAcc)
 219                 sccs
 220
 221 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
 222  = do
 223         blockss' <- process first_id block_live blocks [] (return []) False
 224         linearRA_SCCs first_id block_live
 225                 (reverse (concat blockss') ++ blocksAcc)
 226                 sccs
 227
 228 {- from John Dias's patch 2008/10/16:
 229    The linear-scan allocator sometimes allocates a block
 230    before allocating one of its predecessors, which could lead to
 231    inconsistent allocations. Make it so a block is only allocated
 232    if a predecessor has set the "incoming" assignments for the block, or
 233    if it's the procedure's entry block.
 234
 235    BL 2009/02: Careful. If the assignment for a block doesn't get set for
 236    some reason then this function will loop. We should probably do some
 237    more sanity checking to guard against this eventuality.
 238 -}
 239
 240 process :: (FR freeRegs, Instruction instr, Outputable instr)
 241         => BlockId
 242         -> BlockMap RegSet
 243         -> [GenBasicBlock (LiveInstr instr)]
 244         -> [GenBasicBlock (LiveInstr instr)]
 245         -> [[NatBasicBlock instr]]
 246         -> Bool
 247         -> RegM freeRegs [[NatBasicBlock instr]]
 248
 249 process _ _ [] []         accum _
 250         = return $ reverse accum
 251
 252 process first_id block_live [] next_round accum madeProgress
 253         | not madeProgress
 254
 255           {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
 256              pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
 257                 (  text "Unreachable blocks:"
 258                 $$ vcat (map ppr next_round)) -}
 259         = return $ reverse accum
 260
 261         | otherwise
 262         = process first_id block_live
 263                   next_round [] accum False
 264
 265 process first_id block_live (b@(BasicBlock id _) : blocks)
 266         next_round accum madeProgress
 267  = do
 268         block_assig <- getBlockAssigR
 269
 270         if isJust (mapLookup id block_assig)
 271              || id == first_id
 272          then do
 273                 b'  <- processBlock block_live b
 274                 process first_id block_live blocks
 275                         next_round (b' : accum) True
 276
 277          else   process first_id block_live blocks
 278                         (b : next_round) accum madeProgress
 279
 280
 281 -- | Do register allocation on this basic block
 282 --
 283 processBlock
 284         :: (FR freeRegs, Outputable instr, Instruction instr)
 285         => BlockMap RegSet              -- ^ live regs on entry to each basic block
 286         -> LiveBasicBlock instr         -- ^ block to do register allocation on
 287         -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
 288
 289 processBlock block_live (BasicBlock id instrs)
 290  = do   initBlock id
 291         (instrs', fixups)
 292                 <- linearRA block_live [] [] id instrs
 293         return  $ BasicBlock id instrs' : fixups
 294
 295
 296 -- | Load the freeregs and current reg assignment into the RegM state
 297 --      for the basic block with this BlockId.
 298 initBlock :: FR freeRegs => BlockId -> RegM freeRegs ()
 299 initBlock id
 300  = do   block_assig     <- getBlockAssigR
 301         case mapLookup id block_assig of
 302                 -- no prior info about this block: assume everything is
 303                 -- free and the assignment is empty.
 304                 Nothing
 305                  -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
 306
 307                         setFreeRegsR    frInitFreeRegs
 308                         setAssigR       emptyRegMap
 309
 310                 -- load info about register assignments leading into this block.
 311                 Just (freeregs, assig)
 312                  -> do  setFreeRegsR    freeregs
 313                         setAssigR       assig
 314
 315
 316 -- | Do allocation for a sequence of instructions.
 317 linearRA
 318         :: (FR freeRegs, Outputable instr, Instruction instr)
 319         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
 320         -> [instr]                              -- ^ accumulator for instructions already processed.
 321         -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
 322         -> BlockId                              -- ^ id of the current block, for debugging.
 323         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 324
 325         -> RegM freeRegs
 326                 ( [instr]                       --   instructions after register allocation
 327                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 328
 329
 330 linearRA _          accInstr accFixup _ []
 331         = return
 332                 ( reverse accInstr              -- instrs need to be returned in the correct order.
 333                 , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.
 334
 335
 336 linearRA block_live accInstr accFixups id (instr:instrs)
 337  = do
 338         (accInstr', new_fixups)
 339                 <- raInsn block_live accInstr id instr
 340
 341         linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
 342
 343
 344 -- | Do allocation for a single instruction.
 345 raInsn
 346         :: (FR freeRegs, Outputable instr, Instruction instr)
 347         => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
 348         -> [instr]                              -- ^ accumulator for instructions already processed.
 349         -> BlockId                              -- ^ the id of the current block, for debugging
 350         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
 351         -> RegM freeRegs
 352                 ( [instr]                       -- new instructions
 353                 , [NatBasicBlock instr])        -- extra fixup blocks
 354
 355 raInsn _     new_instrs _ (LiveInstr ii Nothing)
 356         | Just n        <- takeDeltaInstr ii
 357         = do    setDeltaR n
 358                 return (new_instrs, [])
 359
 360 raInsn _     new_instrs _ (LiveInstr ii Nothing)
 361         | isMetaInstr ii
 362         = return (new_instrs, [])
 363
 364
 365 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
 366  = do
 367     assig    <- getAssigR
 368
 369     -- If we have a reg->reg move between virtual registers, where the
 370     -- src register is not live after this instruction, and the dst
 371     -- register does not already have an assignment,
 372     -- and the source register is assigned to a register, not to a spill slot,
 373     -- then we can eliminate the instruction.
 374     -- (we can't eliminate it if the source register is on the stack, because
 375     --  we do not want to use one spill slot for different virtual registers)
 376     case takeRegRegMoveInstr instr of
 377         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
 378                           isVirtualReg dst,
 379                           not (dst `elemUFM` assig),
 380                           Just (InReg _) <- (lookupUFM assig src) -> do
 381            case src of
 382               (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
 383                 -- if src is a fixed reg, then we just map dest to this
 384                 -- reg in the assignment.  src must be an allocatable reg,
 385                 -- otherwise it wouldn't be in r_dying.
 386               _virt -> case lookupUFM assig src of
 387                          Nothing -> panic "raInsn"
 388                          Just loc ->
 389                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
 390
 391            -- we have eliminated this instruction
 392           {-
 393           freeregs <- getFreeRegsR
 394           assig <- getAssigR
 395           pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
 396                         $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
 397           -}
 398            return (new_instrs, [])
 399
 400         _ -> genRaInsn block_live new_instrs id instr
 401                         (uniqSetToList $ liveDieRead live)
 402                         (uniqSetToList $ liveDieWrite live)
 403
 404
 405 raInsn _ _ _ instr
 406         = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 407
 408
 409 genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
 410           => BlockMap RegSet
 411           -> [instr]
 412           -> BlockId
 413           -> instr
 414           -> [Reg]
 415           -> [Reg]
 416           -> RegM freeRegs ([instr], [NatBasicBlock instr])
 417
 418 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
 419     case regUsageOfInstr instr              of { RU read written ->
 420     do
 421     let real_written    = [ rr  | (RegReal     rr) <- written ]
 422     let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
 423
 424     -- we don't need to do anything with real registers that are
 425     -- only read by this instr.  (the list is typically ~2 elements,
 426     -- so using nub isn't a problem).
 427     let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]
 428
 429     -- (a) save any temporaries which will be clobbered by this instruction
 430     clobber_saves       <- saveClobberedTemps real_written r_dying
 431
 432     -- debugging
 433 {-    freeregs <- getFreeRegsR
 434     assig    <- getAssigR
 435     pprTrace "genRaInsn"
 436         (ppr instr
 437                 $$ text "r_dying      = " <+> ppr r_dying
 438                 $$ text "w_dying      = " <+> ppr w_dying
 439                 $$ text "virt_read    = " <+> ppr virt_read
 440                 $$ text "virt_written = " <+> ppr virt_written
 441                 $$ text "freeregs     = " <+> text (show freeregs)
 442                 $$ text "assig        = " <+> ppr assig)
 443         $ do
 444 -}
 445
 446     -- (b), (c) allocate real regs for all regs read by this instruction.
 447     (r_spills, r_allocd) <-
 448         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 449
 450     -- (d) Update block map for new destinations
 451     -- NB. do this before removing dead regs from the assignment, because
 452     -- these dead regs might in fact be live in the jump targets (they're
 453     -- only dead in the code that follows in the current basic block).
 454     (fixup_blocks, adjusted_instr)
 455         <- joinToTargets block_live block_id instr
 456
 457     -- (e) Delete all register assignments for temps which are read
 458     --     (only) and die here.  Update the free register list.
 459     releaseRegs r_dying
 460
 461     -- (f) Mark regs which are clobbered as unallocatable
 462     clobberRegs real_written
 463
 464     -- (g) Allocate registers for temporaries *written* (only)
 465     (w_spills, w_allocd) <-
 466         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 467
 468     -- (h) Release registers for temps which are written here and not
 469     -- used again.
 470     releaseRegs w_dying
 471
 472     let
 473         -- (i) Patch the instruction
 474         patch_map
 475                 = listToUFM
 476                         [ (t, RegReal r)
 477                                 | (t, r) <- zip virt_read    r_allocd
 478                                          ++ zip virt_written w_allocd ]
 479
 480         patched_instr
 481                 = patchRegsOfInstr adjusted_instr patchLookup
 482
 483         patchLookup x
 484                 = case lookupUFM patch_map x of
 485                         Nothing -> x
 486                         Just y  -> y
 487
 488
 489     -- (j) free up stack slots for dead spilled regs
 490     -- TODO (can't be bothered right now)
 491
 492     -- erase reg->reg moves where the source and destination are the same.
 493     --  If the src temp didn't die in this instr but happened to be allocated
 494     --  to the same real reg as the destination, then we can erase the move anyway.
 495     let squashed_instr  = case takeRegRegMoveInstr patched_instr of
 496                                 Just (src, dst)
 497                                  | src == dst   -> []
 498                                 _               -> [patched_instr]
 499
 500     let code = squashed_instr ++ w_spills ++ reverse r_spills
 501                 ++ clobber_saves ++ new_instrs
 502
 503 --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
 504 --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
 505
 506     return (code, fixup_blocks)
 507
 508   }
 509
 510 -- -----------------------------------------------------------------------------
 511 -- releaseRegs
 512
 513 releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
 514 releaseRegs regs = do
 515   assig <- getAssigR
 516   free <- getFreeRegsR
 517   loop assig free regs
 518  where
 519   loop _     free _ | free `seq` False = undefined
 520   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 521   loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs
 522   loop assig free (r:rs) =
 523      case lookupUFM assig r of
 524         Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
 525         Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs
 526         _other            -> loop (delFromUFM assig r) free rs
 527
 528
 529 -- -----------------------------------------------------------------------------
 530 -- Clobber real registers
 531
 532 -- For each temp in a register that is going to be clobbered:
 533 --      - if the temp dies after this instruction, do nothing
 534 --      - otherwise, put it somewhere safe (another reg if possible,
 535 --              otherwise spill and record InBoth in the assignment).
 536 --      - for allocateRegs on the temps *read*,
 537 --      - clobbered regs are allocatable.
 538 --
 539 --      for allocateRegs on the temps *written*,
 540 --        - clobbered regs are not allocatable.
 541 --
 542 --      TODO:   instead of spilling, try to copy clobbered
 543 --              temps to another register if possible.
 544 --
 545
 546
 547 saveClobberedTemps
 548         :: (Outputable instr, Instruction instr)
 549         => [RealReg]            -- real registers clobbered by this instruction
 550         -> [Reg]                -- registers which are no longer live after this insn
 551         -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
 552                                 -- be clobbered.
 553
 554 saveClobberedTemps [] _
 555         = return []
 556
 557 saveClobberedTemps clobbered dying
 558  = do
 559         assig   <- getAssigR
 560         let to_spill
 561                 = [ (temp,reg)
 562                         | (temp, InReg reg) <- ufmToList assig
 563                         , any (realRegsAlias reg) clobbered
 564                         , temp `notElem` map getUnique dying  ]
 565
 566         (instrs,assig') <- clobber assig [] to_spill
 567         setAssigR assig'
 568         return instrs
 569
 570    where
 571         clobber assig instrs []
 572                 = return (instrs, assig)
 573
 574         clobber assig instrs ((temp, reg) : rest)
 575          = do
 576                 (spill, slot)   <- spillR (RegReal reg) temp
 577
 578                 -- record why this reg was spilled for profiling
 579                 recordSpill (SpillClobber temp)
 580
 581                 let new_assign  = addToUFM assig temp (InBoth reg slot)
 582
 583                 clobber new_assign (spill : instrs) rest
 584
 585
 586
 587 -- | Mark all these real regs as allocated,
 588 --      and kick out their vreg assignments.
 589 --
 590 clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
 591 clobberRegs []
 592         = return ()
 593
 594 clobberRegs clobbered
 595  = do
 596         freeregs        <- getFreeRegsR
 597         setFreeRegsR $! foldr frAllocateReg freeregs clobbered
 598
 599         assig           <- getAssigR
 600         setAssigR $! clobber assig (ufmToList assig)
 601
 602    where
 603         -- if the temp was InReg and clobbered, then we will have
 604         -- saved it in saveClobberedTemps above.  So the only case
 605         -- we have to worry about here is InBoth.  Note that this
 606         -- also catches temps which were loaded up during allocation
 607         -- of read registers, not just those saved in saveClobberedTemps.
 608
 609         clobber assig []
 610                 = assig
 611
 612         clobber assig ((temp, InBoth reg slot) : rest)
 613                 | any (realRegsAlias reg) clobbered
 614                 = clobber (addToUFM assig temp (InMem slot)) rest
 615
 616         clobber assig (_:rest)
 617                 = clobber assig rest
 618
 619 -- -----------------------------------------------------------------------------
 620 -- allocateRegsAndSpill
 621
 622 -- Why are we performing a spill?
 623 data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
 624               | WriteNew           -- writing to a new variable
 625               | WriteMem           -- writing to register only in memory
 626 -- Note that ReadNew is not valid, since you don't want to be reading
 627 -- from an uninitialized register.  We also don't need the location of
 628 -- the register in memory, since that will be invalidated by the write.
 629 -- Technically, we could coalesce WriteNew and WriteMem into a single
 630 -- entry as well. -- EZY
 631
 632 -- This function does several things:
 633 --   For each temporary referred to by this instruction,
 634 --   we allocate a real register (spilling another temporary if necessary).
 635 --   We load the temporary up from memory if necessary.
 636 --   We also update the register assignment in the process, and
 637 --   the list of free registers and free stack slots.
 638
 639 allocateRegsAndSpill
 640         :: (FR freeRegs, Outputable instr, Instruction instr)
 641         => Bool                 -- True <=> reading (load up spilled regs)
 642         -> [VirtualReg]         -- don't push these out
 643         -> [instr]              -- spill insns
 644         -> [RealReg]            -- real registers allocated (accum.)
 645         -> [VirtualReg]         -- temps to allocate
 646         -> RegM freeRegs ( [instr] , [RealReg])
 647
 648 allocateRegsAndSpill _       _    spills alloc []
 649         = return (spills, reverse alloc)
 650
 651 allocateRegsAndSpill reading keep spills alloc (r:rs)
 652  = do   assig <- getAssigR
 653         let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
 654         case lookupUFM assig r of
 655                 -- case (1a): already in a register
 656                 Just (InReg my_reg) ->
 657                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 658
 659                 -- case (1b): already in a register (and memory)
 660                 -- NB1. if we're writing this register, update its assignment to be
 661                 -- InReg, because the memory value is no longer valid.
 662                 -- NB2. This is why we must process written registers here, even if they
 663                 -- are also read by the same instruction.
 664                 Just (InBoth my_reg _)
 665                  -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 666                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 667
 668                 -- Not already in a register, so we need to find a free one...
 669                 Just (InMem slot) | reading   -> doSpill (ReadMem slot)
 670                                   | otherwise -> doSpill WriteMem
 671                 Nothing | reading   ->
 672                    -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
 673                    -- ToDo: This case should be a panic, but we
 674                    -- sometimes see an unreachable basic block which
 675                    -- triggers this because the register allocator
 676                    -- will start with an empty assignment.
 677                    doSpill WriteNew
 678
 679                         | otherwise -> doSpill WriteNew
 680
 681
 682 -- reading is redundant with reason, but we keep it around because it's
 683 -- convenient and it maintains the recursive structure of the allocator. -- EZY
 684 allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
 685                         => Bool
 686                         -> [VirtualReg]
 687                         -> [instr]
 688                         -> [RealReg]
 689                         -> VirtualReg
 690                         -> [VirtualReg]
 691                         -> UniqFM Loc
 692                         -> SpillLoc
 693                         -> RegM freeRegs ([instr], [RealReg])
 694 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
 695  = do
 696         freeRegs                <- getFreeRegsR
 697         let freeRegs_thisClass  = frGetFreeRegs (classOfVirtualReg r) freeRegs
 698
 699         case freeRegs_thisClass of
 700
 701          -- case (2): we have a free register
 702          (my_reg : _) ->
 703            do   spills'   <- loadTemp r spill_loc my_reg spills
 704
 705                 setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
 706                 setFreeRegsR $  frAllocateReg my_reg freeRegs
 707
 708                 allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
 709
 710
 711           -- case (3): we need to push something out to free up a register
 712          [] ->
 713            do   let keep' = map getUnique keep
 714
 715                 -- the vregs we could kick out that are already in a slot
 716                 let candidates_inBoth
 717                         = [ (temp, reg, mem)
 718                                 | (temp, InBoth reg mem) <- ufmToList assig
 719                                 , temp `notElem` keep'
 720                                 , targetClassOfRealReg reg == classOfVirtualReg r ]
 721
 722                 -- the vregs we could kick out that are only in a reg
 723                 --      this would require writing the reg to a new slot before using it.
 724                 let candidates_inReg
 725                         = [ (temp, reg)
 726                                 | (temp, InReg reg)     <- ufmToList assig
 727                                 , temp `notElem` keep'
 728                                 , targetClassOfRealReg reg == classOfVirtualReg r ]
 729
 730                 let result
 731
 732                         -- we have a temporary that is in both register and mem,
 733                         -- just free up its register for use.
 734                         | (temp, my_reg, slot) : _      <- candidates_inBoth
 735                         = do    spills' <- loadTemp r spill_loc my_reg spills
 736                                 let assig1  = addToUFM assig temp (InMem slot)
 737                                 let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg
 738
 739                                 setAssigR assig2
 740                                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 741
 742                         -- otherwise, we need to spill a temporary that currently
 743                         -- resides in a register.
 744                         | (temp_to_push_out, (my_reg :: RealReg)) : _
 745                                         <- candidates_inReg
 746                         = do
 747                                 (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
 748                                 let spill_store  = (if reading then id else reverse)
 749                                                         [ -- COMMENT (fsLit "spill alloc")
 750                                                            spill_insn ]
 751
 752                                 -- record that this temp was spilled
 753                                 recordSpill (SpillAlloc temp_to_push_out)
 754
 755                                 -- update the register assignment
 756                                 let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
 757                                 let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
 758                                 setAssigR assig2
 759
 760                                 -- if need be, load up a spilled temp into the reg we've just freed up.
 761                                 spills' <- loadTemp r spill_loc my_reg spills
 762
 763                                 allocateRegsAndSpill reading keep
 764                                         (spill_store ++ spills')
 765                                         (my_reg:alloc) rs
 766
 767
 768                         -- there wasn't anything to spill, so we're screwed.
 769                         | otherwise
 770                         = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
 771                         $ vcat
 772                                 [ text "allocating vreg:  " <> text (show r)
 773                                 , text "assignment:       " <> text (show $ ufmToList assig)
 774                                 , text "freeRegs:         " <> text (show freeRegs)
 775                                 , text "initFreeRegs:     " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ]
 776
 777                 result
 778
 779
 780 -- | Calculate a new location after a register has been loaded.
 781 newLocation :: SpillLoc -> RealReg -> Loc
 782 -- if the tmp was read from a slot, then now its in a reg as well
 783 newLocation (ReadMem slot) my_reg = InBoth my_reg slot
 784 -- writes will always result in only the register being available
 785 newLocation _ my_reg = InReg my_reg
 786
 787 -- | Load up a spilled temporary if we need to (read from memory).
 788 loadTemp
 789         :: (Outputable instr, Instruction instr)
 790         => VirtualReg   -- the temp being loaded
 791         -> SpillLoc     -- the current location of this temp
 792         -> RealReg      -- the hreg to load the temp into
 793         -> [instr]
 794         -> RegM freeRegs [instr]
 795
 796 loadTemp vreg (ReadMem slot) hreg spills
 797  = do
 798         insn <- loadR (RegReal hreg) slot
 799         recordSpill (SpillLoad $ getUnique vreg)
 800         return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
 801
 802 loadTemp _ _ _ spills =
 803    return spills
 804