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