compiler/nativeGen/RegAlloc/Linear/Main.hs

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