compiler/nativeGen/RegAlloc/Linear/Main.hs

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