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