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