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 PprMach
 105
 106 import BlockId
 107 import Cmm hiding (RegSet)
 108
 109 import Digraph
 110 import Unique
 111 import UniqSet
 112 import UniqFM
 113 import UniqSupply
 114 import Outputable
 115
 116 import Data.Maybe
 117 import Data.List
 118 import Control.Monad
 119
 120 #include "../includes/MachRegs.h"
 121
 122
 123 -- -----------------------------------------------------------------------------
 124 -- Top level of the register allocator
 125
 126 -- Allocate registers
 127 regAlloc
 128         :: (Outputable instr, Instruction instr)
 129         => LiveCmmTop instr
 130         -> UniqSM (NatCmmTop instr, Maybe RegAllocStats)
 131
 132 regAlloc (CmmData sec d)
 133         = return
 134                 ( CmmData sec d
 135                 , Nothing )
 136
 137 regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
 138         = return ( CmmProc info lbl params (ListGraph [])
 139                  , Nothing )
 140
 141 regAlloc (CmmProc static lbl params (ListGraph comps))
 142         | LiveInfo info (Just first_id) block_live      <- static
 143         = do
 144                 -- do register allocation on each component.
 145                 (final_blocks, stats)
 146                         <- linearRegAlloc first_id block_live
 147                         $ map (\b -> case b of
 148                                         BasicBlock _ [b]        -> AcyclicSCC b
 149                                         BasicBlock _ bs         -> CyclicSCC  bs)
 150                         $ comps
 151
 152                 -- make sure the block that was first in the input list
 153                 --      stays at the front of the output
 154                 let ((first':_), rest')
 155                                 = partition ((== first_id) . blockId) final_blocks
 156
 157                 return  ( CmmProc info lbl params (ListGraph (first' : rest'))
 158                         , Just stats)
 159
 160 -- bogus. to make non-exhaustive match warning go away.
 161 regAlloc (CmmProc _ _ _ _)
 162         = panic "RegAllocLinear.regAlloc: no match"
 163
 164
 165 -- -----------------------------------------------------------------------------
 166 -- Linear sweep to allocate registers
 167
 168
 169 -- | Do register allocation on some basic blocks.
 170 --   But be careful to allocate a block in an SCC only if it has
 171 --   an entry in the block map or it is the first block.
 172 --
 173 linearRegAlloc
 174         :: (Outputable instr, Instruction instr)
 175         => BlockId                      -- ^ the first block
 176         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
 177         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
 178         -> UniqSM ([NatBasicBlock instr], RegAllocStats)
 179
 180 linearRegAlloc first_id block_live sccs
 181  = do   us      <- getUs
 182         let (_, _, stats, blocks) =
 183                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
 184                         $ linearRA_SCCs first_id block_live [] sccs
 185
 186         return  (blocks, stats)
 187
 188 linearRA_SCCs _ _ blocksAcc []
 189         = return $ reverse blocksAcc
 190
 191 linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
 192  = do   blocks' <- processBlock block_live block
 193         linearRA_SCCs first_id block_live
 194                 ((reverse blocks') ++ blocksAcc)
 195                 sccs
 196
 197 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
 198  = do
 199         blockss' <- process first_id block_live blocks [] (return [])
 200         linearRA_SCCs first_id block_live
 201                 (reverse (concat blockss') ++ blocksAcc)
 202                 sccs
 203
 204 {- from John Dias's patch 2008/10/16:
 205    The linear-scan allocator sometimes allocates a block
 206    before allocating one of its predecessors, which could lead to
 207    inconsistent allocations. Make it so a block is only allocated
 208    if a predecessor has set the "incoming" assignments for the block, or
 209    if it's the procedure's entry block.
 210
 211    BL 2009/02: Careful. If the assignment for a block doesn't get set for
 212    some reason then this function will loop. We should probably do some
 213    more sanity checking to guard against this eventuality.
 214 -}
 215
 216 process _ _ [] []         accum
 217         = return $ reverse accum
 218
 219 process first_id block_live [] next_round accum
 220         = process first_id block_live next_round [] accum
 221
 222 process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
 223  = do
 224         block_assig <- getBlockAssigR
 225
 226         if isJust (lookupBlockEnv block_assig id)
 227              || id == first_id
 228          then do
 229                 b'  <- processBlock block_live b
 230                 process first_id block_live blocks next_round (b' : accum)
 231
 232          else   process first_id block_live blocks (b : next_round) accum
 233
 234
 235 -- | Do register allocation on this basic block
 236 --
 237 processBlock
 238         :: (Outputable instr, Instruction instr)
 239         => BlockMap RegSet              -- ^ live regs on entry to each basic block
 240         -> LiveBasicBlock instr         -- ^ block to do register allocation on
 241         -> RegM [NatBasicBlock instr]   -- ^ block with registers allocated
 242
 243 processBlock block_live (BasicBlock id instrs)
 244  = do   initBlock id
 245         (instrs', fixups)
 246                 <- linearRA block_live [] [] id instrs
 247         return  $ BasicBlock id instrs' : fixups
 248
 249
 250 -- | Load the freeregs and current reg assignment into the RegM state
 251 --      for the basic block with this BlockId.
 252 initBlock :: BlockId -> RegM ()
 253 initBlock id
 254  = do   block_assig     <- getBlockAssigR
 255         case lookupBlockEnv block_assig id of
 256                 -- no prior info about this block: assume everything is
 257                 -- free and the assignment is empty.
 258                 Nothing
 259                  -> do  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               RealReg i -> setAssigR (addToUFM assig dst (InReg i))
 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     case partition isRealReg written of { (real_written1,virt_written) ->
 365     do
 366     let
 367         real_written = [ r | RealReg r <- real_written1 ]
 368
 369         -- we don't need to do anything with real registers that are
 370         -- only read by this instr.  (the list is typically ~2 elements,
 371         -- so using nub isn't a problem).
 372         virt_read = nub (filter isVirtualReg read)
 373     -- in
 374
 375     -- (a) save any temporaries which will be clobbered by this instruction
 376     clobber_saves <- saveClobberedTemps real_written r_dying
 377
 378
 379 {-    freeregs <- getFreeRegsR
 380     assig    <- getAssigR
 381     pprTrace "genRaInsn"
 382         (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written
 383                 $$ text (show freeregs) $$ ppr assig)
 384                 $ do
 385 -}
 386
 387     -- (b), (c) allocate real regs for all regs read by this instruction.
 388     (r_spills, r_allocd) <-
 389         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 390
 391     -- (d) Update block map for new destinations
 392     -- NB. do this before removing dead regs from the assignment, because
 393     -- these dead regs might in fact be live in the jump targets (they're
 394     -- only dead in the code that follows in the current basic block).
 395     (fixup_blocks, adjusted_instr)
 396         <- joinToTargets block_live block_id instr
 397
 398     -- (e) Delete all register assignments for temps which are read
 399     --     (only) and die here.  Update the free register list.
 400     releaseRegs r_dying
 401
 402     -- (f) Mark regs which are clobbered as unallocatable
 403     clobberRegs real_written
 404
 405     -- (g) Allocate registers for temporaries *written* (only)
 406     (w_spills, w_allocd) <-
 407         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 408
 409     -- (h) Release registers for temps which are written here and not
 410     -- used again.
 411     releaseRegs w_dying
 412
 413     let
 414         -- (i) Patch the instruction
 415         patch_map = listToUFM   [ (t,RealReg r) |
 416                                   (t,r) <- zip virt_read r_allocd
 417                                           ++ zip virt_written w_allocd ]
 418
 419         patched_instr = patchRegsOfInstr adjusted_instr patchLookup
 420         patchLookup x = case lookupUFM patch_map x of
 421                                 Nothing -> x
 422                                 Just y  -> y
 423     -- in
 424
 425 --    pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
 426
 427     -- (j) free up stack slots for dead spilled regs
 428     -- TODO (can't be bothered right now)
 429
 430     -- erase reg->reg moves where the source and destination are the same.
 431     --  If the src temp didn't die in this instr but happened to be allocated
 432     --  to the same real reg as the destination, then we can erase the move anyway.
 433     let squashed_instr  = case takeRegRegMoveInstr patched_instr of
 434                                 Just (src, dst)
 435                                  | src == dst   -> []
 436                                 _               -> [patched_instr]
 437
 438     let code = squashed_instr ++ w_spills ++ reverse r_spills
 439                 ++ clobber_saves ++ new_instrs
 440
 441 --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
 442 --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
 443
 444     return (code, fixup_blocks)
 445
 446   }}
 447
 448 -- -----------------------------------------------------------------------------
 449 -- releaseRegs
 450
 451 releaseRegs regs = do
 452   assig <- getAssigR
 453   free <- getFreeRegsR
 454   loop assig free regs
 455  where
 456   loop _     free _ | free `seq` False = undefined
 457   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 458   loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
 459   loop assig free (r:rs) =
 460      case lookupUFM assig r of
 461         Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
 462         Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
 463         _other            -> loop (delFromUFM assig r) free rs
 464
 465 -- -----------------------------------------------------------------------------
 466 -- Clobber real registers
 467
 468 {-
 469 For each temp in a register that is going to be clobbered:
 470   - if the temp dies after this instruction, do nothing
 471   - otherwise, put it somewhere safe (another reg if possible,
 472     otherwise spill and record InBoth in the assignment).
 473
 474 for allocateRegs on the temps *read*,
 475   - clobbered regs are allocatable.
 476
 477 for allocateRegs on the temps *written*,
 478   - clobbered regs are not allocatable.
 479 -}
 480
 481 saveClobberedTemps
 482         :: Instruction instr
 483         => [RegNo]              -- real registers clobbered by this instruction
 484         -> [Reg]                -- registers which are no longer live after this insn
 485         -> RegM [instr]         -- return: instructions to spill any temps that will
 486                                 -- be clobbered.
 487
 488 saveClobberedTemps [] _ = return [] -- common case
 489 saveClobberedTemps clobbered dying =  do
 490   assig <- getAssigR
 491   let
 492         to_spill  = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
 493                                    reg `elem` clobbered,
 494                                    temp `notElem` map getUnique dying  ]
 495   -- in
 496   (instrs,assig') <- clobber assig [] to_spill
 497   setAssigR assig'
 498   return instrs
 499  where
 500   clobber assig instrs [] = return (instrs,assig)
 501   clobber assig instrs ((temp,reg):rest)
 502     = do
 503         --ToDo: copy it to another register if possible
 504         (spill,slot) <- spillR (RealReg reg) temp
 505         recordSpill (SpillClobber temp)
 506
 507         let new_assign  = addToUFM assig temp (InBoth reg slot)
 508         clobber new_assign (spill : {- COMMENT (fsLit "spill clobber") : -} instrs) rest
 509
 510 clobberRegs :: [RegNo] -> RegM ()
 511 clobberRegs [] = return () -- common case
 512 clobberRegs clobbered = do
 513   freeregs <- getFreeRegsR
 514 --  setFreeRegsR $! foldr grabReg freeregs clobbered
 515   setFreeRegsR $! foldr allocateReg freeregs clobbered
 516
 517   assig <- getAssigR
 518   setAssigR $! clobber assig (ufmToList assig)
 519  where
 520     -- if the temp was InReg and clobbered, then we will have
 521     -- saved it in saveClobberedTemps above.  So the only case
 522     -- we have to worry about here is InBoth.  Note that this
 523     -- also catches temps which were loaded up during allocation
 524     -- of read registers, not just those saved in saveClobberedTemps.
 525   clobber assig [] = assig
 526   clobber assig ((temp, InBoth reg slot) : rest)
 527         | reg `elem` clobbered
 528         = clobber (addToUFM assig temp (InMem slot)) rest
 529   clobber assig (_:rest)
 530         = clobber assig rest
 531
 532 -- -----------------------------------------------------------------------------
 533 -- allocateRegsAndSpill
 534
 535 -- This function does several things:
 536 --   For each temporary referred to by this instruction,
 537 --   we allocate a real register (spilling another temporary if necessary).
 538 --   We load the temporary up from memory if necessary.
 539 --   We also update the register assignment in the process, and
 540 --   the list of free registers and free stack slots.
 541
 542 allocateRegsAndSpill
 543         :: Instruction instr
 544         => Bool                 -- True <=> reading (load up spilled regs)
 545         -> [Reg]                -- don't push these out
 546         -> [instr]              -- spill insns
 547         -> [RegNo]              -- real registers allocated (accum.)
 548         -> [Reg]                -- temps to allocate
 549         -> RegM ([instr], [RegNo])
 550
 551 allocateRegsAndSpill _       _    spills alloc []
 552   = return (spills,reverse alloc)
 553
 554 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 555   assig <- getAssigR
 556   case lookupUFM assig r of
 557   -- case (1a): already in a register
 558      Just (InReg my_reg) ->
 559         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 560
 561   -- case (1b): already in a register (and memory)
 562   -- NB1. if we're writing this register, update its assignemnt to be
 563   -- InReg, because the memory value is no longer valid.
 564   -- NB2. This is why we must process written registers here, even if they
 565   -- are also read by the same instruction.
 566      Just (InBoth my_reg _) -> do
 567         when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 568         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 569
 570   -- Not already in a register, so we need to find a free one...
 571      loc -> do
 572         freeregs <- getFreeRegsR
 573
 574         case getFreeRegs (targetRegClass r) freeregs of
 575
 576         -- case (2): we have a free register
 577           my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -}
 578             do
 579             spills'   <- loadTemp reading r loc my_reg spills
 580             let new_loc
 581                  | Just (InMem slot) <- loc, reading = InBoth my_reg slot
 582                  | otherwise                         = InReg my_reg
 583             setAssigR (addToUFM assig r $! new_loc)
 584             setFreeRegsR $ allocateReg my_reg freeregs
 585             allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 586
 587         -- case (3): we need to push something out to free up a register
 588           [] -> do
 589             let
 590               keep' = map getUnique keep
 591               candidates1 = [ (temp,reg,mem)
 592                             | (temp, InBoth reg mem) <- ufmToList assig,
 593                               temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ]
 594               candidates2 = [ (temp,reg)
 595                             | (temp, InReg reg) <- ufmToList assig,
 596                               temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r  ]
 597             -- in
 598             ASSERT2(not (null candidates1 && null candidates2),
 599                     text (show freeregs) <+> ppr r <+> ppr assig) do
 600
 601             case candidates1 of
 602
 603              -- we have a temporary that is in both register and mem,
 604              -- just free up its register for use.
 605              --
 606              (temp,my_reg,slot):_ -> do
 607                 spills' <- loadTemp reading r loc my_reg spills
 608                 let
 609                   assig1  = addToUFM assig temp (InMem slot)
 610                   assig2  = addToUFM assig1 r (InReg my_reg)
 611                 -- in
 612                 setAssigR assig2
 613                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 614
 615              -- otherwise, we need to spill a temporary that currently
 616              -- resides in a register.
 617
 618
 619              [] -> do
 620
 621                 -- TODO: plenty of room for optimisation in choosing which temp
 622                 -- to spill.  We just pick the first one that isn't used in
 623                 -- the current instruction for now.
 624
 625                 let (temp_to_push_out, my_reg)
 626                         = case candidates2 of
 627                                 []      -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates"
 628                                         ++ "assignment: " ++ show (ufmToList assig) ++ "\n"
 629                                 (x:_)   -> x
 630
 631                 (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
 632                 let spill_store  = (if reading then id else reverse)
 633                                         [ -- COMMENT (fsLit "spill alloc")
 634                                            spill_insn ]
 635
 636                 -- record that this temp was spilled
 637                 recordSpill (SpillAlloc temp_to_push_out)
 638
 639                 -- update the register assignment
 640                 let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
 641                 let assig2  = addToUFM assig1 r                 (InReg my_reg)
 642                 setAssigR assig2
 643
 644                 -- if need be, load up a spilled temp into the reg we've just freed up.
 645                 spills' <- loadTemp reading r loc my_reg spills
 646
 647                 allocateRegsAndSpill reading keep
 648                         (spill_store ++ spills')
 649                         (my_reg:alloc) rs
 650
 651
 652 -- | Load up a spilled temporary if we need to.
 653 loadTemp
 654         :: Instruction instr
 655         => Bool
 656         -> Reg          -- the temp being loaded
 657         -> Maybe Loc    -- the current location of this temp
 658         -> RegNo        -- the hreg to load the temp into
 659         -> [instr]
 660         -> RegM [instr]
 661
 662 loadTemp True vreg (Just (InMem slot)) hreg spills
 663  = do
 664         insn <- loadR (RealReg hreg) slot
 665         recordSpill (SpillLoad $ getUnique vreg)
 666         return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
 667
 668 loadTemp _ _ _ _ spills =
 669    return spills
 670