compiler/nativeGen/RegAllocLinear.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- The register allocator
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8 {-# OPTIONS -fno-warn-missing-signatures #-}
   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 RegAllocLinear (
  85         regAlloc,
  86         RegAllocStats, pprStats
  87   ) where
  88
  89 #include "HsVersions.h"
  90
  91 import MachRegs
  92 import MachInstrs
  93 import RegAllocInfo
  94 import RegLiveness
  95 import Cmm hiding (RegSet)
  96
  97 import Digraph
  98 import Unique           ( Uniquable(getUnique), Unique )
  99 import UniqSet
 100 import UniqFM
 101 import UniqSupply
 102 import Outputable
 103 import State
 104
 105 import Data.Maybe
 106 import Data.List
 107 import Control.Monad
 108 import Data.Word
 109 import Data.Bits
 110
 111
 112 -- -----------------------------------------------------------------------------
 113 -- The free register set
 114
 115 -- This needs to be *efficient*
 116
 117 {- Here's an inefficient 'executable specification' of the FreeRegs data type:
 118 type FreeRegs = [RegNo]
 119
 120 noFreeRegs = 0
 121 releaseReg n f = if n `elem` f then f else (n : f)
 122 initFreeRegs = allocatableRegs
 123 getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
 124 allocateReg f r = filter (/= r) f
 125 -}
 126
 127 #if defined(powerpc_TARGET_ARCH)
 128
 129 -- The PowerPC has 32 integer and 32 floating point registers.
 130 -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
 131 -- better.
 132 -- Note that when getFreeRegs scans for free registers, it starts at register
 133 -- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
 134 -- registers are callee-saves, while the lower regs are caller-saves, so it
 135 -- makes sense to start at the high end.
 136 -- Apart from that, the code does nothing PowerPC-specific, so feel free to
 137 -- add your favourite platform to the #if (if you have 64 registers but only
 138 -- 32-bit words).
 139
 140 data FreeRegs = FreeRegs !Word32 !Word32
 141               deriving( Show )  -- The Show is used in an ASSERT
 142
 143 noFreeRegs :: FreeRegs
 144 noFreeRegs = FreeRegs 0 0
 145
 146 releaseReg :: RegNo -> FreeRegs -> FreeRegs
 147 releaseReg r (FreeRegs g f)
 148     | r > 31    = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
 149     | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
 150
 151 initFreeRegs :: FreeRegs
 152 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
 153
 154 getFreeRegs :: RegClass -> FreeRegs -> [RegNo]  -- lazilly
 155 getFreeRegs cls (FreeRegs g f)
 156     | RcDouble <- cls = go f (0x80000000) 63
 157     | RcInteger <- cls = go g (0x80000000) 31
 158     where
 159         go x 0 i = []
 160         go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
 161                  | otherwise    = go x (m `shiftR` 1) $! i-1
 162
 163 allocateReg :: RegNo -> FreeRegs -> FreeRegs
 164 allocateReg r (FreeRegs g f)
 165     | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
 166     | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
 167
 168 #else
 169
 170 -- If we have less than 32 registers, or if we have efficient 64-bit words,
 171 -- we will just use a single bitfield.
 172
 173 #if defined(alpha_TARGET_ARCH)
 174 type FreeRegs = Word64
 175 #else
 176 type FreeRegs = Word32
 177 #endif
 178
 179 noFreeRegs :: FreeRegs
 180 noFreeRegs = 0
 181
 182 releaseReg :: RegNo -> FreeRegs -> FreeRegs
 183 releaseReg n f = f .|. (1 `shiftL` n)
 184
 185 initFreeRegs :: FreeRegs
 186 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
 187
 188 getFreeRegs :: RegClass -> FreeRegs -> [RegNo]  -- lazilly
 189 getFreeRegs cls f = go f 0
 190   where go 0 _ = []
 191         go n m
 192           | n .&. 1 /= 0 && regClass (RealReg m) == cls
 193           = m : (go (n `shiftR` 1) $! (m+1))
 194           | otherwise
 195           = go (n `shiftR` 1) $! (m+1)
 196         -- ToDo: there's no point looking through all the integer registers
 197         -- in order to find a floating-point one.
 198
 199 allocateReg :: RegNo -> FreeRegs -> FreeRegs
 200 allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
 201
 202 #endif
 203
 204 -- -----------------------------------------------------------------------------
 205 -- The assignment of virtual registers to stack slots
 206
 207 -- We have lots of stack slots. Memory-to-memory moves are a pain on most
 208 -- architectures. Therefore, we avoid having to generate memory-to-memory moves
 209 -- by simply giving every virtual register its own stack slot.
 210
 211 -- The StackMap stack map keeps track of virtual register - stack slot
 212 -- associations and of which stack slots are still free. Once it has been
 213 -- associated, a stack slot is never "freed" or removed from the StackMap again,
 214 -- it remains associated until we are done with the current CmmProc.
 215
 216 type StackSlot = Int
 217 data StackMap = StackMap [StackSlot] (UniqFM StackSlot)
 218
 219 emptyStackMap :: StackMap
 220 emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
 221
 222 getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
 223 getStackSlotFor (StackMap [] _) _
 224         = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
 225
 226 getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
 227     case lookupUFM reserved reg of
 228         Just slot -> (fs,slot)
 229         Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
 230
 231 -- -----------------------------------------------------------------------------
 232 -- Top level of the register allocator
 233
 234 -- Allocate registers
 235 regAlloc
 236         :: LiveCmmTop
 237         -> UniqSM (NatCmmTop, Maybe RegAllocStats)
 238
 239 regAlloc (CmmData sec d)
 240         = return
 241                 ( CmmData sec d
 242                 , Nothing )
 243
 244 regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
 245         = return
 246                 ( CmmProc info lbl params (ListGraph [])
 247                 , Nothing )
 248
 249 regAlloc (CmmProc static lbl params (ListGraph comps))
 250         | LiveInfo info (Just first_id) block_live      <- static
 251         = do
 252                 -- do register allocation on each component.
 253                 (final_blocks, stats)
 254                         <- linearRegAlloc block_live
 255                         $ map (\b -> case b of
 256                                         BasicBlock _ [b]        -> AcyclicSCC b
 257                                         BasicBlock _ bs         -> CyclicSCC  bs)
 258                         $ comps
 259
 260                 -- make sure the block that was first in the input list
 261                 --      stays at the front of the output
 262                 let ((first':_), rest')
 263                                 = partition ((== first_id) . blockId) final_blocks
 264
 265                 return  ( CmmProc info lbl params (ListGraph (first' : rest'))
 266                         , Just stats)
 267
 268 -- bogus. to make non-exhaustive match warning go away.
 269 regAlloc (CmmProc _ _ _ _)
 270         = panic "RegAllocLinear.regAlloc: no match"
 271
 272
 273 -- -----------------------------------------------------------------------------
 274 -- Linear sweep to allocate registers
 275
 276 data Loc = InReg   {-# UNPACK #-} !RegNo
 277          | InMem   {-# UNPACK #-} !Int          -- stack slot
 278          | InBoth  {-# UNPACK #-} !RegNo
 279                    {-# UNPACK #-} !Int          -- stack slot
 280   deriving (Eq, Show, Ord)
 281
 282 {-
 283 A temporary can be marked as living in both a register and memory
 284 (InBoth), for example if it was recently loaded from a spill location.
 285 This makes it cheap to spill (no save instruction required), but we
 286 have to be careful to turn this into InReg if the value in the
 287 register is changed.
 288
 289 This is also useful when a temporary is about to be clobbered.  We
 290 save it in a spill location, but mark it as InBoth because the current
 291 instruction might still want to read it.
 292 -}
 293
 294 instance Outputable Loc where
 295   ppr l = text (show l)
 296
 297
 298 -- | Do register allocation on some basic blocks.
 299 --
 300 linearRegAlloc
 301         :: BlockMap RegSet              -- ^ live regs on entry to each basic block
 302         -> [SCC LiveBasicBlock]         -- ^ instructions annotated with "deaths"
 303         -> UniqSM ([NatBasicBlock], RegAllocStats)
 304
 305 linearRegAlloc block_live sccs
 306  = do   us      <- getUs
 307         let (_, _, stats, blocks) =
 308                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
 309                         $ linearRA_SCCs block_live [] sccs
 310
 311         return  (blocks, stats)
 312
 313 linearRA_SCCs _ blocksAcc []
 314         = return $ reverse blocksAcc
 315
 316 linearRA_SCCs block_live blocksAcc (AcyclicSCC block : sccs)
 317  = do   blocks' <- processBlock block_live block
 318         linearRA_SCCs block_live
 319                 ((reverse blocks') ++ blocksAcc)
 320                 sccs
 321
 322 linearRA_SCCs block_live blocksAcc (CyclicSCC blocks : sccs)
 323  = do   blockss' <- mapM (processBlock block_live) blocks
 324         linearRA_SCCs block_live
 325                 (reverse (concat blockss') ++ blocksAcc)
 326                 sccs
 327
 328
 329 -- | Do register allocation on this basic block
 330 --
 331 processBlock
 332         :: BlockMap RegSet              -- ^ live regs on entry to each basic block
 333         -> LiveBasicBlock               -- ^ block to do register allocation on
 334         -> RegM [NatBasicBlock]         -- ^ block with registers allocated
 335
 336 processBlock block_live (BasicBlock id instrs)
 337  = do   initBlock id
 338         (instrs', fixups)
 339                 <- linearRA block_live [] [] instrs
 340
 341         return  $ BasicBlock id instrs' : fixups
 342
 343
 344 -- | Load the freeregs and current reg assignment into the RegM state
 345 --      for the basic block with this BlockId.
 346 initBlock :: BlockId -> RegM ()
 347 initBlock id
 348  = do   block_assig     <- getBlockAssigR
 349         case lookupUFM block_assig id of
 350                 -- no prior info about this block: assume everything is
 351                 -- free and the assignment is empty.
 352                 Nothing
 353                  -> do  setFreeRegsR    initFreeRegs
 354                         setAssigR       emptyRegMap
 355
 356                 -- load info about register assignments leading into this block.
 357                 Just (freeregs, assig)
 358                  -> do  setFreeRegsR    freeregs
 359                         setAssigR       assig
 360
 361
 362 linearRA
 363         :: BlockMap RegSet
 364         -> [Instr] -> [NatBasicBlock] -> [LiveInstr]
 365         -> RegM ([Instr], [NatBasicBlock])
 366
 367 linearRA _          instr_acc fixups []
 368         = return (reverse instr_acc, fixups)
 369
 370 linearRA block_live instr_acc fixups (instr:instrs)
 371  = do   (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
 372         linearRA block_live instr_acc' (new_fixups++fixups) instrs
 373
 374 -- -----------------------------------------------------------------------------
 375 -- Register allocation for a single instruction
 376
 377 type BlockAssignment = BlockMap (FreeRegs, RegMap Loc)
 378
 379 raInsn  :: BlockMap RegSet              -- Live temporaries at each basic block
 380         -> [Instr]                      -- new instructions (accum.)
 381         -> LiveInstr                    -- the instruction (with "deaths")
 382         -> RegM (
 383              [Instr],                   -- new instructions
 384              [NatBasicBlock]            -- extra fixup blocks
 385            )
 386
 387 raInsn _     new_instrs (Instr (COMMENT _) Nothing)
 388  = return (new_instrs, [])
 389
 390 raInsn _     new_instrs (Instr (DELTA n) Nothing)
 391  = do
 392     setDeltaR n
 393     return (new_instrs, [])
 394
 395 raInsn block_live new_instrs (Instr instr (Just live))
 396  = do
 397     assig    <- getAssigR
 398
 399     -- If we have a reg->reg move between virtual registers, where the
 400     -- src register is not live after this instruction, and the dst
 401     -- register does not already have an assignment,
 402     -- and the source register is assigned to a register, not to a spill slot,
 403     -- then we can eliminate the instruction.
 404     -- (we can't eliminitate it if the source register is on the stack, because
 405     --  we do not want to use one spill slot for different virtual registers)
 406     case isRegRegMove instr of
 407         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
 408                           isVirtualReg dst,
 409                           not (dst `elemUFM` assig),
 410                           Just (InReg _) <- (lookupUFM assig src) -> do
 411            case src of
 412               RealReg i -> setAssigR (addToUFM assig dst (InReg i))
 413                 -- if src is a fixed reg, then we just map dest to this
 414                 -- reg in the assignment.  src must be an allocatable reg,
 415                 -- otherwise it wouldn't be in r_dying.
 416               _virt -> case lookupUFM assig src of
 417                          Nothing -> panic "raInsn"
 418                          Just loc ->
 419                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
 420
 421            -- we have elimianted this instruction
 422            {-
 423            freeregs <- getFreeRegsR
 424            assig <- getAssigR
 425            pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
 426            -}
 427            return (new_instrs, [])
 428
 429         _ -> genRaInsn block_live new_instrs instr
 430                         (uniqSetToList $ liveDieRead live)
 431                         (uniqSetToList $ liveDieWrite live)
 432
 433
 434 raInsn _ _ li
 435         = pprPanic "raInsn" (text "no match for:" <> ppr li)
 436
 437
 438 genRaInsn block_live new_instrs instr r_dying w_dying =
 439     case regUsage instr              of { RU read written ->
 440     case partition isRealReg written of { (real_written1,virt_written) ->
 441     do
 442     let
 443         real_written = [ r | RealReg r <- real_written1 ]
 444
 445         -- we don't need to do anything with real registers that are
 446         -- only read by this instr.  (the list is typically ~2 elements,
 447         -- so using nub isn't a problem).
 448         virt_read = nub (filter isVirtualReg read)
 449     -- in
 450
 451     -- (a) save any temporaries which will be clobbered by this instruction
 452     clobber_saves <- saveClobberedTemps real_written r_dying
 453
 454     {-
 455     freeregs <- getFreeRegsR
 456     assig <- getAssigR
 457     pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
 458     -}
 459
 460     -- (b), (c) allocate real regs for all regs read by this instruction.
 461     (r_spills, r_allocd) <-
 462         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 463
 464     -- (d) Update block map for new destinations
 465     -- NB. do this before removing dead regs from the assignment, because
 466     -- these dead regs might in fact be live in the jump targets (they're
 467     -- only dead in the code that follows in the current basic block).
 468     (fixup_blocks, adjusted_instr)
 469         <- joinToTargets block_live [] instr (jumpDests instr [])
 470
 471     -- (e) Delete all register assignments for temps which are read
 472     --     (only) and die here.  Update the free register list.
 473     releaseRegs r_dying
 474
 475     -- (f) Mark regs which are clobbered as unallocatable
 476     clobberRegs real_written
 477
 478     -- (g) Allocate registers for temporaries *written* (only)
 479     (w_spills, w_allocd) <-
 480         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 481
 482     -- (h) Release registers for temps which are written here and not
 483     -- used again.
 484     releaseRegs w_dying
 485
 486     let
 487         -- (i) Patch the instruction
 488         patch_map = listToUFM   [ (t,RealReg r) |
 489                                   (t,r) <- zip virt_read r_allocd
 490                                           ++ zip virt_written w_allocd ]
 491
 492         patched_instr = patchRegs adjusted_instr patchLookup
 493         patchLookup x = case lookupUFM patch_map x of
 494                                 Nothing -> x
 495                                 Just y  -> y
 496     -- in
 497
 498     -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
 499
 500     -- (j) free up stack slots for dead spilled regs
 501     -- TODO (can't be bothered right now)
 502
 503     -- erase reg->reg moves where the source and destination are the same.
 504     --  If the src temp didn't die in this instr but happened to be allocated
 505     --  to the same real reg as the destination, then we can erase the move anyway.
 506         squashed_instr  = case isRegRegMove patched_instr of
 507                                 Just (src, dst)
 508                                  | src == dst   -> []
 509                                 _               -> [patched_instr]
 510
 511     return (squashed_instr ++ w_spills ++ reverse r_spills
 512                  ++ clobber_saves ++ new_instrs,
 513             fixup_blocks)
 514   }}
 515
 516 -- -----------------------------------------------------------------------------
 517 -- releaseRegs
 518
 519 releaseRegs regs = do
 520   assig <- getAssigR
 521   free <- getFreeRegsR
 522   loop assig free regs
 523  where
 524   loop _     free _ | free `seq` False = undefined
 525   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 526   loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
 527   loop assig free (r:rs) =
 528      case lookupUFM assig r of
 529         Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
 530         Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
 531         _other            -> loop (delFromUFM assig r) free rs
 532
 533 -- -----------------------------------------------------------------------------
 534 -- Clobber real registers
 535
 536 {-
 537 For each temp in a register that is going to be clobbered:
 538   - if the temp dies after this instruction, do nothing
 539   - otherwise, put it somewhere safe (another reg if possible,
 540     otherwise spill and record InBoth in the assignment).
 541
 542 for allocateRegs on the temps *read*,
 543   - clobbered regs are allocatable.
 544
 545 for allocateRegs on the temps *written*,
 546   - clobbered regs are not allocatable.
 547 -}
 548
 549 saveClobberedTemps
 550    :: [RegNo]              -- real registers clobbered by this instruction
 551    -> [Reg]                -- registers which are no longer live after this insn
 552    -> RegM [Instr]         -- return: instructions to spill any temps that will
 553                            -- be clobbered.
 554
 555 saveClobberedTemps [] _ = return [] -- common case
 556 saveClobberedTemps clobbered dying =  do
 557   assig <- getAssigR
 558   let
 559         to_spill  = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
 560                                    reg `elem` clobbered,
 561                                    temp `notElem` map getUnique dying  ]
 562   -- in
 563   (instrs,assig') <- clobber assig [] to_spill
 564   setAssigR assig'
 565   return instrs
 566  where
 567   clobber assig instrs [] = return (instrs,assig)
 568   clobber assig instrs ((temp,reg):rest)
 569     = do
 570         --ToDo: copy it to another register if possible
 571         (spill,slot) <- spillR (RealReg reg) temp
 572         recordSpill (SpillClobber temp)
 573
 574         let new_assign  = addToUFM assig temp (InBoth reg slot)
 575         clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
 576
 577 clobberRegs :: [RegNo] -> RegM ()
 578 clobberRegs [] = return () -- common case
 579 clobberRegs clobbered = do
 580   freeregs <- getFreeRegsR
 581   setFreeRegsR $! foldr allocateReg freeregs clobbered
 582   assig <- getAssigR
 583   setAssigR $! clobber assig (ufmToList assig)
 584  where
 585     -- if the temp was InReg and clobbered, then we will have
 586     -- saved it in saveClobberedTemps above.  So the only case
 587     -- we have to worry about here is InBoth.  Note that this
 588     -- also catches temps which were loaded up during allocation
 589     -- of read registers, not just those saved in saveClobberedTemps.
 590   clobber assig [] = assig
 591   clobber assig ((temp, InBoth reg slot) : rest)
 592         | reg `elem` clobbered
 593         = clobber (addToUFM assig temp (InMem slot)) rest
 594   clobber assig (_:rest)
 595         = clobber assig rest
 596
 597 -- -----------------------------------------------------------------------------
 598 -- allocateRegsAndSpill
 599
 600 -- This function does several things:
 601 --   For each temporary referred to by this instruction,
 602 --   we allocate a real register (spilling another temporary if necessary).
 603 --   We load the temporary up from memory if necessary.
 604 --   We also update the register assignment in the process, and
 605 --   the list of free registers and free stack slots.
 606
 607 allocateRegsAndSpill
 608         :: Bool                 -- True <=> reading (load up spilled regs)
 609         -> [Reg]                -- don't push these out
 610         -> [Instr]              -- spill insns
 611         -> [RegNo]              -- real registers allocated (accum.)
 612         -> [Reg]                -- temps to allocate
 613         -> RegM ([Instr], [RegNo])
 614
 615 allocateRegsAndSpill _       _    spills alloc []
 616   = return (spills,reverse alloc)
 617
 618 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 619   assig <- getAssigR
 620   case lookupUFM assig r of
 621   -- case (1a): already in a register
 622      Just (InReg my_reg) ->
 623         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 624
 625   -- case (1b): already in a register (and memory)
 626   -- NB1. if we're writing this register, update its assignemnt to be
 627   -- InReg, because the memory value is no longer valid.
 628   -- NB2. This is why we must process written registers here, even if they
 629   -- are also read by the same instruction.
 630      Just (InBoth my_reg _) -> do
 631         when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 632         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 633
 634   -- Not already in a register, so we need to find a free one...
 635      loc -> do
 636         freeregs <- getFreeRegsR
 637
 638         case getFreeRegs (regClass r) freeregs of
 639
 640         -- case (2): we have a free register
 641           my_reg:_ -> do
 642             spills'   <- loadTemp reading r loc my_reg spills
 643             let new_loc
 644                  | Just (InMem slot) <- loc, reading = InBoth my_reg slot
 645                  | otherwise                         = InReg my_reg
 646             setAssigR (addToUFM assig r $! new_loc)
 647             setFreeRegsR (allocateReg my_reg freeregs)
 648             allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 649
 650         -- case (3): we need to push something out to free up a register
 651           [] -> do
 652             let
 653               keep' = map getUnique keep
 654               candidates1 = [ (temp,reg,mem)
 655                             | (temp, InBoth reg mem) <- ufmToList assig,
 656                               temp `notElem` keep', regClass (RealReg reg) == regClass r ]
 657               candidates2 = [ (temp,reg)
 658                             | (temp, InReg reg) <- ufmToList assig,
 659                               temp `notElem` keep', regClass (RealReg reg) == regClass r  ]
 660             -- in
 661             ASSERT2(not (null candidates1 && null candidates2),
 662                     text (show freeregs) <+> ppr r <+> ppr assig) do
 663
 664             case candidates1 of
 665
 666              -- we have a temporary that is in both register and mem,
 667              -- just free up its register for use.
 668              --
 669              (temp,my_reg,slot):_ -> do
 670                 spills' <- loadTemp reading r loc my_reg spills
 671                 let
 672                   assig1  = addToUFM assig temp (InMem slot)
 673                   assig2  = addToUFM assig1 r (InReg my_reg)
 674                 -- in
 675                 setAssigR assig2
 676                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 677
 678              -- otherwise, we need to spill a temporary that currently
 679              -- resides in a register.
 680
 681
 682              [] -> do
 683
 684                 -- TODO: plenty of room for optimisation in choosing which temp
 685                 -- to spill.  We just pick the first one that isn't used in
 686                 -- the current instruction for now.
 687
 688                 let (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
 689
 690                 (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
 691                 let spill_store  = (if reading then id else reverse)
 692                                         [ COMMENT FSLIT("spill alloc")
 693                                         , spill_insn ]
 694
 695                 -- record that this temp was spilled
 696                 recordSpill (SpillAlloc temp_to_push_out)
 697
 698                 -- update the register assignment
 699                 let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
 700                 let assig2  = addToUFM assig1 r                 (InReg my_reg)
 701                 setAssigR assig2
 702
 703                 -- if need be, load up a spilled temp into the reg we've just freed up.
 704                 spills' <- loadTemp reading r loc my_reg spills
 705
 706                 allocateRegsAndSpill reading keep
 707                         (spill_store ++ spills')
 708                         (my_reg:alloc) rs
 709
 710
 711 -- | Load up a spilled temporary if we need to.
 712 loadTemp
 713         :: Bool
 714         -> Reg          -- the temp being loaded
 715         -> Maybe Loc    -- the current location of this temp
 716         -> RegNo        -- the hreg to load the temp into
 717         -> [Instr]
 718         -> RegM [Instr]
 719
 720 loadTemp True vreg (Just (InMem slot)) hreg spills
 721  = do
 722         insn <- loadR (RealReg hreg) slot
 723         recordSpill (SpillLoad $ getUnique vreg)
 724         return  $  COMMENT FSLIT("spill load") : insn : spills
 725
 726 loadTemp _ _ _ _ spills =
 727    return spills
 728
 729
 730 myHead s [] = panic s
 731 myHead _ (x:_) = x
 732
 733 -- -----------------------------------------------------------------------------
 734 -- Joining a jump instruction to its targets
 735
 736 -- The first time we encounter a jump to a particular basic block, we
 737 -- record the assignment of temporaries.  The next time we encounter a
 738 -- jump to the same block, we compare our current assignment to the
 739 -- stored one.  They might be different if spilling has occrred in one
 740 -- branch; so some fixup code will be required to match up the
 741 -- assignments.
 742
 743 joinToTargets
 744         :: BlockMap RegSet
 745         -> [NatBasicBlock]
 746         -> Instr
 747         -> [BlockId]
 748         -> RegM ([NatBasicBlock], Instr)
 749
 750 joinToTargets _          new_blocks instr []
 751   = return (new_blocks, instr)
 752
 753 joinToTargets block_live new_blocks instr (dest:dests) = do
 754   block_assig <- getBlockAssigR
 755   assig <- getAssigR
 756   let
 757         -- adjust the assignment to remove any registers which are not
 758         -- live on entry to the destination block.
 759         adjusted_assig = filterUFM_Directly still_live assig
 760
 761         live_set = lookItUp "joinToTargets" block_live dest
 762         still_live uniq _ = uniq `elemUniqSet_Directly` live_set
 763
 764         -- and free up those registers which are now free.
 765         to_free =
 766           [ r | (reg, loc) <- ufmToList assig,
 767                 not (elemUniqSet_Directly reg live_set),
 768                 r <- regsOfLoc loc ]
 769
 770         regsOfLoc (InReg r)    = [r]
 771         regsOfLoc (InBoth r _) = [r]
 772         regsOfLoc (InMem _)    = []
 773   -- in
 774   case lookupUFM block_assig dest of
 775         -- Nothing <=> this is the first time we jumped to this
 776         -- block.
 777         Nothing -> do
 778           freeregs <- getFreeRegsR
 779           let freeregs' = foldr releaseReg freeregs to_free
 780           setBlockAssigR (addToUFM block_assig dest
 781                                 (freeregs',adjusted_assig))
 782           joinToTargets block_live new_blocks instr dests
 783
 784         Just (_, dest_assig)
 785
 786            -- the assignments match
 787            | ufmToList dest_assig == ufmToList adjusted_assig
 788            -> joinToTargets block_live new_blocks instr dests
 789
 790            -- need fixup code
 791            | otherwise
 792            -> do
 793                delta <- getDeltaR
 794
 795                let graph = makeRegMovementGraph adjusted_assig dest_assig
 796                let sccs  = stronglyConnCompR graph
 797                fixUpInstrs <- mapM (handleComponent delta instr) sccs
 798
 799                block_id <- getUniqueR
 800                let block = BasicBlock (BlockId block_id) $
 801                        concat fixUpInstrs ++ mkBranchInstr dest
 802
 803                let instr' = patchJump instr dest (BlockId block_id)
 804
 805                joinToTargets block_live (block : new_blocks) instr' dests
 806
 807
 808 -- | Construct a graph of register/spill movements.
 809 --
 810 --      We cut some corners by
 811 --      a) not handling cyclic components
 812 --      b) not handling memory-to-memory moves.
 813 --
 814 --      Cyclic components seem to occur only very rarely,
 815 --      and we don't need memory-to-memory moves because we
 816 --      make sure that every temporary always gets its own
 817 --      stack slot.
 818
 819 makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
 820 makeRegMovementGraph adjusted_assig dest_assig
 821  = let
 822         mkNodes src vreg
 823          = expandNode vreg src
 824          $ lookupWithDefaultUFM_Directly
 825                 dest_assig
 826                 (panic "RegisterAlloc.joinToTargets")
 827                 vreg
 828
 829    in   [ node  | (vreg, src) <- ufmToList adjusted_assig
 830                 , node <- mkNodes src vreg ]
 831
 832 -- The InBoth handling is a little tricky here.  If
 833 -- the destination is InBoth, then we must ensure that
 834 -- the value ends up in both locations.  An InBoth
 835 -- destination must conflict with an InReg or InMem
 836 -- source, so we expand an InBoth destination as
 837 -- necessary.  An InBoth source is slightly different:
 838 -- we only care about the register that the source value
 839 -- is in, so that we can move it to the destinations.
 840
 841 expandNode vreg loc@(InReg src) (InBoth dst mem)
 842         | src == dst = [(vreg, loc, [InMem mem])]
 843         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 844
 845 expandNode vreg loc@(InMem src) (InBoth dst mem)
 846         | src == mem = [(vreg, loc, [InReg dst])]
 847         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 848
 849 expandNode _        (InBoth _ src) (InMem dst)
 850         | src == dst = [] -- guaranteed to be true
 851
 852 expandNode _        (InBoth src _) (InReg dst)
 853         | src == dst = []
 854
 855 expandNode vreg     (InBoth src _) dst
 856         = expandNode vreg (InReg src) dst
 857
 858 expandNode vreg src dst
 859         | src == dst = []
 860         | otherwise  = [(vreg, src, [dst])]
 861
 862
 863 -- | Make a move instruction between these two locations so we
 864 --      can join together allocations for different basic blocks.
 865 --
 866 makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
 867 makeMove _     vreg (InReg src) (InReg dst)
 868  = do   recordSpill (SpillJoinRR vreg)
 869         return  $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
 870
 871 makeMove delta vreg (InMem src) (InReg dst)
 872  = do   recordSpill (SpillJoinRM vreg)
 873         return  $ mkLoadInstr (RealReg dst) delta src
 874
 875 makeMove delta vreg (InReg src) (InMem dst)
 876  = do   recordSpill (SpillJoinRM vreg)
 877         return  $ mkSpillInstr (RealReg src) delta dst
 878
 879 makeMove _     vreg src dst
 880         = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
 881                 ++ show dst ++ ")"
 882                 ++ " (workaround: use -fviaC)"
 883
 884
 885 -- we have eliminated any possibility of single-node cylces
 886 -- in expandNode above.
 887 handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
 888 handleComponent delta _  (AcyclicSCC (vreg,src,dsts))
 889          = mapM (makeMove delta vreg src) dsts
 890
 891 -- we can not have cycles that involve memory
 892 -- locations as source nor as single destination
 893 -- because memory locations (stack slots) are
 894 -- allocated exclusively for a virtual register and
 895 -- therefore can not require a fixup
 896 handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
 897  = do
 898         spill_id <- getUniqueR
 899         (_, slot)               <- spillR (RealReg sreg) spill_id
 900         remainingFixUps         <- mapM (handleComponent delta instr) (stronglyConnCompR rest)
 901         restoreAndFixInstr      <- getRestoreMoves dsts slot
 902         return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
 903
 904         where
 905         getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
 906          = do
 907                 restoreToReg    <- loadR (RealReg reg) slot
 908                 moveInstr       <- makeMove delta vreg r mem
 909                 return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr]
 910
 911         getRestoreMoves [InReg reg] slot
 912                 = loadR (RealReg reg) slot >>= return . (:[])
 913
 914         getRestoreMoves [InMem _] _     = panic "getRestoreMoves can not handle memory only restores"
 915         getRestoreMoves _ _             = panic "getRestoreMoves unknown case"
 916
 917
 918 handleComponent _ _ (CyclicSCC _)
 919  = panic "Register Allocator: handleComponent cyclic"
 920
 921
 922
 923 -- -----------------------------------------------------------------------------
 924 -- The register allocator's monad.
 925
 926 -- Here we keep all the state that the register allocator keeps track
 927 -- of as it walks the instructions in a basic block.
 928
 929 data RA_State
 930   = RA_State {
 931         ra_blockassig :: BlockAssignment,
 932                 -- The current mapping from basic blocks to
 933                 -- the register assignments at the beginning of that block.
 934         ra_freeregs   :: {-#UNPACK#-}!FreeRegs, -- free machine registers
 935         ra_assig      :: RegMap Loc,    -- assignment of temps to locations
 936         ra_delta      :: Int,           -- current stack delta
 937         ra_stack      :: StackMap,      -- free stack slots for spilling
 938         ra_us         :: UniqSupply,    -- unique supply for generating names
 939                                         -- for fixup blocks.
 940
 941         -- Record why things were spilled, for -ddrop-asm-stats.
 942         --      Just keep a list here instead of a map of regs -> reasons.
 943         --      We don't want to slow down the allocator if we're not going to emit the stats.
 944         ra_spills     :: [SpillReason]
 945   }
 946
 947 newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
 948
 949
 950 instance Monad RegM where
 951   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
 952   return a  =  RegM $ \s -> (# s, a #)
 953
 954 runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply
 955   -> RegM a -> (BlockAssignment, StackMap, RegAllocStats, a)
 956 runR block_assig freeregs assig stack us thing =
 957   case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
 958                         ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack,
 959                         ra_us = us, ra_spills = [] }) of
 960         (# state'@RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
 961                 -> (block_assig, stack', makeRAStats state', returned_thing)
 962
 963 spillR :: Reg -> Unique -> RegM (Instr, Int)
 964 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
 965   let (stack',slot) = getStackSlotFor stack temp
 966       instr  = mkSpillInstr reg delta slot
 967   in
 968   (# s{ra_stack=stack'}, (instr,slot) #)
 969
 970 loadR :: Reg -> Int -> RegM Instr
 971 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
 972   (# s, mkLoadInstr reg delta slot #)
 973
 974 getFreeRegsR :: RegM FreeRegs
 975 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
 976   (# s, freeregs #)
 977
 978 setFreeRegsR :: FreeRegs -> RegM ()
 979 setFreeRegsR regs = RegM $ \ s ->
 980   (# s{ra_freeregs = regs}, () #)
 981
 982 getAssigR :: RegM (RegMap Loc)
 983 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
 984   (# s, assig #)
 985
 986 setAssigR :: RegMap Loc -> RegM ()
 987 setAssigR assig = RegM $ \ s ->
 988   (# s{ra_assig=assig}, () #)
 989
 990 getBlockAssigR :: RegM BlockAssignment
 991 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
 992   (# s, assig #)
 993
 994 setBlockAssigR :: BlockAssignment -> RegM ()
 995 setBlockAssigR assig = RegM $ \ s ->
 996   (# s{ra_blockassig = assig}, () #)
 997
 998 setDeltaR :: Int -> RegM ()
 999 setDeltaR n = RegM $ \ s ->
1000   (# s{ra_delta = n}, () #)
1001
1002 getDeltaR :: RegM Int
1003 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
1004
1005 getUniqueR :: RegM Unique
1006 getUniqueR = RegM $ \s ->
1007   case splitUniqSupply (ra_us s) of
1008     (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
1009
1010 -- | Record that a spill instruction was inserted, for profiling.
1011 recordSpill :: SpillReason -> RegM ()
1012 recordSpill spill
1013         = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
1014
1015 -- -----------------------------------------------------------------------------
1016
1017 -- | Reasons why instructions might be inserted by the spiller.
1018 --      Used when generating stats for -ddrop-asm-stats.
1019 --
1020 data SpillReason
1021         = SpillAlloc    !Unique -- ^ vreg was spilled to a slot so we could use its
1022                                 --      current hreg for another vreg
1023         | SpillClobber  !Unique -- ^ vreg was moved because its hreg was clobbered
1024         | SpillLoad     !Unique -- ^ vreg was loaded from a spill slot
1025
1026         | SpillJoinRR   !Unique -- ^ reg-reg move inserted during join to targets
1027         | SpillJoinRM   !Unique -- ^ reg-mem move inserted during join to targets
1028
1029
1030 -- | Used to carry interesting stats out of the register allocator.
1031 data RegAllocStats
1032         = RegAllocStats
1033         { ra_spillInstrs        :: UniqFM [Int] }
1034
1035
1036 -- | Make register allocator stats from its final state.
1037 makeRAStats :: RA_State -> RegAllocStats
1038 makeRAStats state
1039         = RegAllocStats
1040         { ra_spillInstrs        = binSpillReasons (ra_spills state) }
1041
1042
1043 -- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
1044 binSpillReasons
1045         :: [SpillReason] -> UniqFM [Int]
1046
1047 binSpillReasons reasons
1048         = addListToUFM_C
1049                 (zipWith (+))
1050                 emptyUFM
1051                 (map (\reason -> case reason of
1052                         SpillAlloc r    -> (r, [1, 0, 0, 0, 0])
1053                         SpillClobber r  -> (r, [0, 1, 0, 0, 0])
1054                         SpillLoad r     -> (r, [0, 0, 1, 0, 0])
1055                         SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])
1056                         SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)
1057
1058
1059 -- | Count reg-reg moves remaining in this code.
1060 countRegRegMovesNat :: NatCmmTop -> Int
1061 countRegRegMovesNat cmm
1062         = execState (mapGenBlockTopM countBlock cmm) 0
1063  where
1064         countBlock b@(BasicBlock _ instrs)
1065          = do   mapM_ countInstr instrs
1066                 return  b
1067
1068         countInstr instr
1069                 | Just _        <- isRegRegMove instr
1070                 = do    modify (+ 1)
1071                         return instr
1072
1073                 | otherwise
1074                 =       return instr
1075
1076
1077 -- | Pretty print some RegAllocStats
1078 pprStats :: [NatCmmTop] -> [RegAllocStats] -> SDoc
1079 pprStats code statss
1080  = let  -- sum up all the instrs inserted by the spiller
1081         spills          = foldl' (plusUFM_C (zipWith (+)))
1082                                 emptyUFM
1083                         $ map ra_spillInstrs statss
1084
1085         spillTotals     = foldl' (zipWith (+))
1086                                 [0, 0, 0, 0, 0]
1087                         $ eltsUFM spills
1088
1089         -- count how many reg-reg-moves remain in the code
1090         moves           = sum $ map countRegRegMovesNat code
1091
1092         pprSpill (reg, spills)
1093                 = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
1094
1095    in   (  text "-- spills-added-total"
1096         $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
1097         $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
1098         $$ text ""
1099         $$ text "-- spills-added"
1100         $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
1101         $$ (vcat $ map pprSpill
1102                  $ ufmToList spills)
1103         $$ text "")
1104
1105
1106 -- -----------------------------------------------------------------------------
1107 -- Utils
1108
1109 #ifdef DEBUG
1110 my_fromJust s p Nothing  = pprPanic ("fromJust: " ++ s) p
1111 my_fromJust _ _ (Just x) = x
1112 #else
1113 my_fromJust _ _ = fromJust
1114 #endif
1115
1116 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
1117 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)