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