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 intstruction 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 Cmm 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 params [])
 136         = return ( CmmProc info lbl params (ListGraph [])
 137                  , Nothing )
 138
 139 regAlloc (CmmProc static lbl params 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 params (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         = pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
 216                 (  text "Unreachable blocks:"
 217                 $$ vcat (map ppr next_round))
 218         $ return $ reverse accum
 219
 220         | otherwise
 221         = process first_id block_live
 222                   next_round [] accum False
 223
 224 process first_id block_live (b@(BasicBlock id _) : blocks)
 225         next_round accum madeProgress
 226  = do
 227         block_assig <- getBlockAssigR
 228
 229         if isJust (lookupBlockEnv block_assig id)
 230              || id == first_id
 231          then do
 232                 b'  <- processBlock block_live b
 233                 process first_id block_live blocks
 234                         next_round (b' : accum) True
 235
 236          else   process first_id block_live blocks
 237                         (b : next_round) accum madeProgress
 238
 239
 240 -- | Do register allocation on this basic block
 241 --
 242 processBlock
 243         :: (Outputable instr, Instruction instr)
 244         => BlockMap RegSet              -- ^ live regs on entry to each basic block
 245         -> LiveBasicBlock instr         -- ^ block to do register allocation on
 246         -> RegM [NatBasicBlock instr]   -- ^ block with registers allocated
 247
 248 processBlock block_live (BasicBlock id instrs)
 249  = do   initBlock id
 250         (instrs', fixups)
 251                 <- linearRA block_live [] [] id instrs
 252         return  $ BasicBlock id instrs' : fixups
 253
 254
 255 -- | Load the freeregs and current reg assignment into the RegM state
 256 --      for the basic block with this BlockId.
 257 initBlock :: BlockId -> RegM ()
 258 initBlock id
 259  = do   block_assig     <- getBlockAssigR
 260         case lookupBlockEnv block_assig id of
 261                 -- no prior info about this block: assume everything is
 262                 -- free and the assignment is empty.
 263                 Nothing
 264                  -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
 265
 266                         setFreeRegsR    initFreeRegs
 267                         setAssigR       emptyRegMap
 268
 269                 -- load info about register assignments leading into this block.
 270                 Just (freeregs, assig)
 271                  -> do  setFreeRegsR    freeregs
 272                         setAssigR       assig
 273
 274
 275 -- | Do allocation for a sequence of instructions.
 276 linearRA
 277         :: (Outputable instr, Instruction instr)
 278         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
 279         -> [instr]                              -- ^ accumulator for instructions already processed.
 280         -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
 281         -> BlockId                              -- ^ id of the current block, for debugging.
 282         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 283
 284         -> RegM ( [instr]                       --   instructions after register allocation
 285                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 286
 287
 288 linearRA _          accInstr accFixup _ []
 289         = return
 290                 ( reverse accInstr              -- instrs need to be returned in the correct order.
 291                 , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.
 292
 293
 294 linearRA block_live accInstr accFixups id (instr:instrs)
 295  = do
 296         (accInstr', new_fixups)
 297                 <- raInsn block_live accInstr id instr
 298
 299         linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
 300
 301
 302 -- | Do allocation for a single instruction.
 303 raInsn
 304         :: (Outputable instr, Instruction instr)
 305         => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
 306         -> [instr]                              -- ^ accumulator for instructions already processed.
 307         -> BlockId                              -- ^ the id of the current block, for debugging
 308         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
 309         -> RegM
 310                 ( [instr]                       -- new instructions
 311                 , [NatBasicBlock instr])        -- extra fixup blocks
 312
 313 raInsn _     new_instrs _ (LiveInstr ii Nothing)
 314         | Just n        <- takeDeltaInstr ii
 315         = do    setDeltaR n
 316                 return (new_instrs, [])
 317
 318 raInsn _     new_instrs _ (LiveInstr ii Nothing)
 319         | isMetaInstr ii
 320         = return (new_instrs, [])
 321
 322
 323 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
 324  = do
 325     assig    <- getAssigR
 326
 327     -- If we have a reg->reg move between virtual registers, where the
 328     -- src register is not live after this instruction, and the dst
 329     -- register does not already have an assignment,
 330     -- and the source register is assigned to a register, not to a spill slot,
 331     -- then we can eliminate the instruction.
 332     -- (we can't eliminitate it if the source register is on the stack, because
 333     --  we do not want to use one spill slot for different virtual registers)
 334     case takeRegRegMoveInstr instr of
 335         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
 336                           isVirtualReg dst,
 337                           not (dst `elemUFM` assig),
 338                           Just (InReg _) <- (lookupUFM assig src) -> do
 339            case src of
 340               (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
 341                 -- if src is a fixed reg, then we just map dest to this
 342                 -- reg in the assignment.  src must be an allocatable reg,
 343                 -- otherwise it wouldn't be in r_dying.
 344               _virt -> case lookupUFM assig src of
 345                          Nothing -> panic "raInsn"
 346                          Just loc ->
 347                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
 348
 349            -- we have eliminated this instruction
 350           {-
 351           freeregs <- getFreeRegsR
 352           assig <- getAssigR
 353           pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
 354                         $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
 355           -}
 356            return (new_instrs, [])
 357
 358         _ -> genRaInsn block_live new_instrs id instr
 359                         (uniqSetToList $ liveDieRead live)
 360                         (uniqSetToList $ liveDieWrite live)
 361
 362
 363 raInsn _ _ _ instr
 364         = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 365
 366
 367
 368
 369 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
 370     case regUsageOfInstr instr              of { RU read written ->
 371     do
 372     let real_written    = [ rr  | (RegReal     rr) <- written ]
 373     let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
 374
 375     -- we don't need to do anything with real registers that are
 376     -- only read by this instr.  (the list is typically ~2 elements,
 377     -- so using nub isn't a problem).
 378     let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]
 379
 380     -- (a) save any temporaries which will be clobbered by this instruction
 381     clobber_saves       <- saveClobberedTemps real_written r_dying
 382
 383     -- debugging
 384 {-    freeregs <- getFreeRegsR
 385     assig    <- getAssigR
 386     pprTrace "genRaInsn"
 387         (ppr instr
 388                 $$ text "r_dying      = " <+> ppr r_dying
 389                 $$ text "w_dying      = " <+> ppr w_dying
 390                 $$ text "virt_read    = " <+> ppr virt_read
 391                 $$ text "virt_written = " <+> ppr virt_written
 392                 $$ text "freeregs     = " <+> text (show freeregs)
 393                 $$ text "assig        = " <+> ppr assig)
 394         $ do
 395 -}
 396
 397     -- (b), (c) allocate real regs for all regs read by this instruction.
 398     (r_spills, r_allocd) <-
 399         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 400
 401     -- (d) Update block map for new destinations
 402     -- NB. do this before removing dead regs from the assignment, because
 403     -- these dead regs might in fact be live in the jump targets (they're
 404     -- only dead in the code that follows in the current basic block).
 405     (fixup_blocks, adjusted_instr)
 406         <- joinToTargets block_live block_id instr
 407
 408     -- (e) Delete all register assignments for temps which are read
 409     --     (only) and die here.  Update the free register list.
 410     releaseRegs r_dying
 411
 412     -- (f) Mark regs which are clobbered as unallocatable
 413     clobberRegs real_written
 414
 415     -- (g) Allocate registers for temporaries *written* (only)
 416     (w_spills, w_allocd) <-
 417         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 418
 419     -- (h) Release registers for temps which are written here and not
 420     -- used again.
 421     releaseRegs w_dying
 422
 423     let
 424         -- (i) Patch the instruction
 425         patch_map
 426                 = listToUFM
 427                         [ (t, RegReal r)
 428                                 | (t, r) <- zip virt_read    r_allocd
 429                                          ++ zip virt_written w_allocd ]
 430
 431         patched_instr
 432                 = patchRegsOfInstr adjusted_instr patchLookup
 433
 434         patchLookup x
 435                 = case lookupUFM patch_map x of
 436                         Nothing -> x
 437                         Just y  -> y
 438
 439
 440     -- (j) free up stack slots for dead spilled regs
 441     -- TODO (can't be bothered right now)
 442
 443     -- erase reg->reg moves where the source and destination are the same.
 444     --  If the src temp didn't die in this instr but happened to be allocated
 445     --  to the same real reg as the destination, then we can erase the move anyway.
 446     let squashed_instr  = case takeRegRegMoveInstr patched_instr of
 447                                 Just (src, dst)
 448                                  | src == dst   -> []
 449                                 _               -> [patched_instr]
 450
 451     let code = squashed_instr ++ w_spills ++ reverse r_spills
 452                 ++ clobber_saves ++ new_instrs
 453
 454 --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
 455 --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
 456
 457     return (code, fixup_blocks)
 458
 459   }
 460
 461 -- -----------------------------------------------------------------------------
 462 -- releaseRegs
 463
 464 releaseRegs regs = do
 465   assig <- getAssigR
 466   free <- getFreeRegsR
 467   loop assig free regs
 468  where
 469   loop _     free _ | free `seq` False = undefined
 470   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 471   loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs
 472   loop assig free (r:rs) =
 473      case lookupUFM assig r of
 474         Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
 475         Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
 476         _other            -> loop (delFromUFM assig r) free rs
 477
 478
 479 -- -----------------------------------------------------------------------------
 480 -- Clobber real registers
 481
 482 -- For each temp in a register that is going to be clobbered:
 483 --      - if the temp dies after this instruction, do nothing
 484 --      - otherwise, put it somewhere safe (another reg if possible,
 485 --              otherwise spill and record InBoth in the assignment).
 486 --      - for allocateRegs on the temps *read*,
 487 --      - clobbered regs are allocatable.
 488 --
 489 --      for allocateRegs on the temps *written*,
 490 --        - clobbered regs are not allocatable.
 491 --
 492 --      TODO:   instead of spilling, try to copy clobbered
 493 --              temps to another register if possible.
 494 --
 495
 496
 497 saveClobberedTemps
 498         :: Instruction instr
 499         => [RealReg]            -- real registers clobbered by this instruction
 500         -> [Reg]                -- registers which are no longer live after this insn
 501         -> RegM [instr]         -- return: instructions to spill any temps that will
 502                                 -- be clobbered.
 503
 504 saveClobberedTemps [] _
 505         = return []
 506
 507 saveClobberedTemps clobbered dying
 508  = do
 509         assig   <- getAssigR
 510         let to_spill
 511                 = [ (temp,reg)
 512                         | (temp, InReg reg) <- ufmToList assig
 513                         , any (realRegsAlias reg) clobbered
 514                         , temp `notElem` map getUnique dying  ]
 515
 516         (instrs,assig') <- clobber assig [] to_spill
 517         setAssigR assig'
 518         return instrs
 519
 520    where
 521         clobber assig instrs []
 522                 = return (instrs, assig)
 523
 524         clobber assig instrs ((temp, reg) : rest)
 525          = do
 526                 (spill, slot)   <- spillR (RegReal reg) temp
 527
 528                 -- record why this reg was spilled for profiling
 529                 recordSpill (SpillClobber temp)
 530
 531                 let new_assign  = addToUFM assig temp (InBoth reg slot)
 532
 533                 clobber new_assign (spill : instrs) rest
 534
 535
 536
 537 -- | Mark all these regal regs as allocated,
 538 --      and kick out their vreg assignments.
 539 --
 540 clobberRegs :: [RealReg] -> RegM ()
 541 clobberRegs []
 542         = return ()
 543
 544 clobberRegs clobbered
 545  = do
 546         freeregs        <- getFreeRegsR
 547         setFreeRegsR $! foldr allocateReg freeregs clobbered
 548
 549         assig           <- getAssigR
 550         setAssigR $! clobber assig (ufmToList assig)
 551
 552    where
 553         -- if the temp was InReg and clobbered, then we will have
 554         -- saved it in saveClobberedTemps above.  So the only case
 555         -- we have to worry about here is InBoth.  Note that this
 556         -- also catches temps which were loaded up during allocation
 557         -- of read registers, not just those saved in saveClobberedTemps.
 558
 559         clobber assig []
 560                 = assig
 561
 562         clobber assig ((temp, InBoth reg slot) : rest)
 563                 | any (realRegsAlias reg) clobbered
 564                 = clobber (addToUFM assig temp (InMem slot)) rest
 565
 566         clobber assig (_:rest)
 567                 = clobber assig rest
 568
 569 -- -----------------------------------------------------------------------------
 570 -- allocateRegsAndSpill
 571
 572 -- This function does several things:
 573 --   For each temporary referred to by this instruction,
 574 --   we allocate a real register (spilling another temporary if necessary).
 575 --   We load the temporary up from memory if necessary.
 576 --   We also update the register assignment in the process, and
 577 --   the list of free registers and free stack slots.
 578
 579 allocateRegsAndSpill
 580         :: Instruction instr
 581         => Bool                 -- True <=> reading (load up spilled regs)
 582         -> [VirtualReg]         -- don't push these out
 583         -> [instr]              -- spill insns
 584         -> [RealReg]            -- real registers allocated (accum.)
 585         -> [VirtualReg]         -- temps to allocate
 586         -> RegM ( [instr]
 587                 , [RealReg])
 588
 589 allocateRegsAndSpill _       _    spills alloc []
 590         = return (spills, reverse alloc)
 591
 592 allocateRegsAndSpill reading keep spills alloc (r:rs)
 593  = do   assig <- getAssigR
 594         case lookupUFM assig r of
 595                 -- case (1a): already in a register
 596                 Just (InReg my_reg) ->
 597                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 598
 599                 -- case (1b): already in a register (and memory)
 600                 -- NB1. if we're writing this register, update its assignemnt to be
 601                 -- InReg, because the memory value is no longer valid.
 602                 -- NB2. This is why we must process written registers here, even if they
 603                 -- are also read by the same instruction.
 604                 Just (InBoth my_reg _)
 605                  -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 606                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 607
 608                 -- Not already in a register, so we need to find a free one...
 609                 loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
 610
 611
 612 allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
 613  = do
 614         freeRegs                <- getFreeRegsR
 615         let freeRegs_thisClass  = getFreeRegs (classOfVirtualReg r) freeRegs
 616
 617         case freeRegs_thisClass of
 618
 619          -- case (2): we have a free register
 620          (my_reg : _) ->
 621            do   spills'   <- loadTemp reading r loc my_reg spills
 622
 623                 let new_loc
 624                         -- if the tmp was in a slot, then now its in a reg as well
 625                         | Just (InMem slot) <- loc
 626                         , reading
 627                         = InBoth my_reg slot
 628
 629                         -- tmp has been loaded into a reg
 630                         | otherwise
 631                         = InReg my_reg
 632
 633                 setAssigR       (addToUFM assig r $! new_loc)
 634                 setFreeRegsR $  allocateReg my_reg freeRegs
 635
 636                 allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
 637
 638
 639           -- case (3): we need to push something out to free up a register
 640          [] ->
 641            do   let keep' = map getUnique keep
 642
 643                 -- the vregs we could kick out that are already in a slot
 644                 let candidates_inBoth
 645                         = [ (temp, reg, mem)
 646                                 | (temp, InBoth reg mem) <- ufmToList assig
 647                                 , temp `notElem` keep'
 648                                 , targetClassOfRealReg reg == classOfVirtualReg r ]
 649
 650                 -- the vregs we could kick out that are only in a reg
 651                 --      this would require writing the reg to a new slot before using it.
 652                 let candidates_inReg
 653                         = [ (temp, reg)
 654                                 | (temp, InReg reg)     <- ufmToList assig
 655                                 , temp `notElem` keep'
 656                                 , targetClassOfRealReg reg == classOfVirtualReg r ]
 657
 658                 let result
 659
 660                         -- we have a temporary that is in both register and mem,
 661                         -- just free up its register for use.
 662                         | (temp, my_reg, slot) : _      <- candidates_inBoth
 663                         = do    spills' <- loadTemp reading r loc my_reg spills
 664                                 let assig1  = addToUFM assig temp (InMem slot)
 665                                 let assig2  = addToUFM assig1 r   (InReg my_reg)
 666
 667                                 setAssigR assig2
 668                                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 669
 670                         -- otherwise, we need to spill a temporary that currently
 671                         -- resides in a register.
 672                         | (temp_to_push_out, (my_reg :: RealReg)) : _
 673                                         <- candidates_inReg
 674                         = do
 675                                 (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
 676                                 let spill_store  = (if reading then id else reverse)
 677                                                         [ -- COMMENT (fsLit "spill alloc")
 678                                                            spill_insn ]
 679
 680                                 -- record that this temp was spilled
 681                                 recordSpill (SpillAlloc temp_to_push_out)
 682
 683                                 -- update the register assignment
 684                                 let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
 685                                 let assig2  = addToUFM assig1 r                 (InReg my_reg)
 686                                 setAssigR assig2
 687
 688                                 -- if need be, load up a spilled temp into the reg we've just freed up.
 689                                 spills' <- loadTemp reading r loc my_reg spills
 690
 691                                 allocateRegsAndSpill reading keep
 692                                         (spill_store ++ spills')
 693                                         (my_reg:alloc) rs
 694
 695
 696                         -- there wasn't anything to spill, so we're screwed.
 697                         | otherwise
 698                         = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
 699                         $ vcat
 700                                 [ text "allocating vreg:  " <> text (show r)
 701                                 , text "assignment:       " <> text (show $ ufmToList assig)
 702                                 , text "freeRegs:         " <> text (show freeRegs)
 703                                 , text "initFreeRegs:     " <> text (show initFreeRegs) ]
 704
 705                 result
 706
 707
 708 -- | Load up a spilled temporary if we need to.
 709 loadTemp
 710         :: Instruction instr
 711         => Bool
 712         -> VirtualReg   -- the temp being loaded
 713         -> Maybe Loc    -- the current location of this temp
 714         -> RealReg      -- the hreg to load the temp into
 715         -> [instr]
 716         -> RegM [instr]
 717
 718 loadTemp True vreg (Just (InMem slot)) hreg spills
 719  = do
 720         insn <- loadR (RegReal hreg) slot
 721         recordSpill (SpillLoad $ getUnique vreg)
 722         return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
 723
 724 loadTemp _ _ _ _ spills =
 725    return spills
 726