compiler/nativeGen/RegAllocLinear.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- The register allocator
   4 --
   5 -- (c) The University of Glasgow 2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {-
  10 The algorithm is roughly:
  11
  12   1) Compute strongly connected components of the basic block list.
  13
  14   2) Compute liveness (mapping from pseudo register to
  15      point(s) of death?).
  16
  17   3) Walk instructions in each basic block.  We keep track of
  18         (a) Free real registers (a bitmap?)
  19         (b) Current assignment of temporaries to machine registers and/or
  20             spill slots (call this the "assignment").
  21         (c) Partial mapping from basic block ids to a virt-to-loc mapping.
  22             When we first encounter a branch to a basic block,
  23             we fill in its entry in this table with the current mapping.
  24
  25      For each instruction:
  26         (a) For each real register clobbered by this instruction:
  27             If a temporary resides in it,
  28                 If the temporary is live after this instruction,
  29                     Move the temporary to another (non-clobbered & free) reg,
  30                     or spill it to memory.  Mark the temporary as residing
  31                     in both memory and a register if it was spilled (it might
  32                     need to be read by this instruction).
  33             (ToDo: this is wrong for jump instructions?)
  34
  35         (b) For each temporary *read* by the instruction:
  36             If the temporary does not have a real register allocation:
  37                 - Allocate a real register from the free list.  If
  38                   the list is empty:
  39                   - Find a temporary to spill.  Pick one that is
  40                     not used in this instruction (ToDo: not
  41                     used for a while...)
  42                   - generate a spill instruction
  43                 - If the temporary was previously spilled,
  44                   generate an instruction to read the temp from its spill loc.
  45             (optimisation: if we can see that a real register is going to
  46             be used soon, then don't use it for allocation).
  47
  48         (c) Update the current assignment
  49
  50         (d) If the intstruction is a branch:
  51               if the destination block already has a register assignment,
  52                 Generate a new block with fixup code and redirect the
  53                 jump to the new block.
  54               else,
  55                 Update the block id->assignment mapping with the current
  56                 assignment.
  57
  58         (e) Delete all register assignments for temps which are read
  59             (only) and die here.  Update the free register list.
  60
  61         (f) Mark all registers clobbered by this instruction as not free,
  62             and mark temporaries which have been spilled due to clobbering
  63             as in memory (step (a) marks then as in both mem & reg).
  64
  65         (g) For each temporary *written* by this instruction:
  66             Allocate a real register as for (b), spilling something
  67             else if necessary.
  68                 - except when updating the assignment, drop any memory
  69                   locations that the temporary was previously in, since
  70                   they will be no longer valid after this instruction.
  71
  72         (h) Delete all register assignments for temps which are
  73             written and die here (there should rarely be any).  Update
  74             the free register list.
  75
  76         (i) Rewrite the instruction with the new mapping.
  77
  78         (j) For each spilled reg known to be now dead, re-add its stack slot
  79             to the free list.
  80
  81 -}
  82
  83 module RegAllocLinear (
  84         regAlloc,
  85   ) where
  86
  87 #include "HsVersions.h"
  88
  89 import MachRegs
  90 import MachInstrs
  91 import RegAllocInfo
  92 import RegLiveness
  93 import Cmm
  94
  95 import Digraph
  96 import Unique           ( Uniquable(getUnique), Unique )
  97 import UniqSet
  98 import UniqFM
  99 import UniqSupply
 100 import Outputable
 101
 102 #ifndef DEBUG
 103 import Data.Maybe       ( fromJust )
 104 #endif
 105 import Data.List        ( nub, partition, mapAccumL)
 106 import Control.Monad    ( when )
 107 import Data.Word
 108 import Data.Bits
 109
 110
 111 -- -----------------------------------------------------------------------------
 112 -- The free register set
 113
 114 -- This needs to be *efficient*
 115
 116 {- Here's an inefficient 'executable specification' of the FreeRegs data type:
 117 type FreeRegs = [RegNo]
 118
 119 noFreeRegs = 0
 120 releaseReg n f = if n `elem` f then f else (n : f)
 121 initFreeRegs = allocatableRegs
 122 getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
 123 allocateReg f r = filter (/= r) f
 124 -}
 125
 126 #if defined(powerpc_TARGET_ARCH)
 127
 128 -- The PowerPC has 32 integer and 32 floating point registers.
 129 -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
 130 -- better.
 131 -- Note that when getFreeRegs scans for free registers, it starts at register
 132 -- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
 133 -- registers are callee-saves, while the lower regs are caller-saves, so it
 134 -- makes sense to start at the high end.
 135 -- Apart from that, the code does nothing PowerPC-specific, so feel free to
 136 -- add your favourite platform to the #if (if you have 64 registers but only
 137 -- 32-bit words).
 138
 139 data FreeRegs = FreeRegs !Word32 !Word32
 140               deriving( Show )  -- The Show is used in an ASSERT
 141
 142 noFreeRegs :: FreeRegs
 143 noFreeRegs = FreeRegs 0 0
 144
 145 releaseReg :: RegNo -> FreeRegs -> FreeRegs
 146 releaseReg r (FreeRegs g f)
 147     | r > 31    = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32)))
 148     | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f
 149
 150 initFreeRegs :: FreeRegs
 151 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
 152
 153 getFreeRegs :: RegClass -> FreeRegs -> [RegNo]  -- lazilly
 154 getFreeRegs cls (FreeRegs g f)
 155     | RcDouble <- cls = go f (0x80000000) 63
 156     | RcInteger <- cls = go g (0x80000000) 31
 157     where
 158         go x 0 i = []
 159         go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
 160                  | otherwise    = go x (m `shiftR` 1) $! i-1
 161
 162 allocateReg :: RegNo -> FreeRegs -> FreeRegs
 163 allocateReg r (FreeRegs g f)
 164     | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32)))
 165     | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f
 166
 167 #else
 168
 169 -- If we have less than 32 registers, or if we have efficient 64-bit words,
 170 -- we will just use a single bitfield.
 171
 172 #if defined(alpha_TARGET_ARCH)
 173 type FreeRegs = Word64
 174 #else
 175 type FreeRegs = Word32
 176 #endif
 177
 178 noFreeRegs :: FreeRegs
 179 noFreeRegs = 0
 180
 181 releaseReg :: RegNo -> FreeRegs -> FreeRegs
 182 releaseReg n f = f .|. (1 `shiftL` n)
 183
 184 initFreeRegs :: FreeRegs
 185 initFreeRegs = foldr releaseReg noFreeRegs allocatableRegs
 186
 187 getFreeRegs :: RegClass -> FreeRegs -> [RegNo]  -- lazilly
 188 getFreeRegs cls f = go f 0
 189   where go 0 m = []
 190         go n m
 191           | n .&. 1 /= 0 && regClass (RealReg m) == cls
 192           = m : (go (n `shiftR` 1) $! (m+1))
 193           | otherwise
 194           = go (n `shiftR` 1) $! (m+1)
 195         -- ToDo: there's no point looking through all the integer registers
 196         -- in order to find a floating-point one.
 197
 198 allocateReg :: RegNo -> FreeRegs -> FreeRegs
 199 allocateReg r f = f .&. complement (1 `shiftL` fromIntegral r)
 200
 201 #endif
 202
 203 -- -----------------------------------------------------------------------------
 204 -- The assignment of virtual registers to stack slots
 205
 206 -- We have lots of stack slots. Memory-to-memory moves are a pain on most
 207 -- architectures. Therefore, we avoid having to generate memory-to-memory moves
 208 -- by simply giving every virtual register its own stack slot.
 209
 210 -- The StackMap stack map keeps track of virtual register - stack slot
 211 -- associations and of which stack slots are still free. Once it has been
 212 -- associated, a stack slot is never "freed" or removed from the StackMap again,
 213 -- it remains associated until we are done with the current CmmProc.
 214
 215 type StackSlot = Int
 216 data StackMap = StackMap [StackSlot] (UniqFM StackSlot)
 217
 218 emptyStackMap :: StackMap
 219 emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
 220
 221 getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
 222 getStackSlotFor fs@(StackMap [] reserved) reg
 223         = panic "RegAllocLinear.getStackSlotFor: out of stack slots"
 224 getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
 225     case lookupUFM reserved reg of
 226         Just slot -> (fs,slot)
 227         Nothing -> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
 228
 229 -- -----------------------------------------------------------------------------
 230 -- Top level of the register allocator
 231
 232 -- Allocate registers
 233 regAlloc
 234         :: LiveCmmTop
 235         -> UniqSM NatCmmTop
 236
 237 regAlloc cmm@(CmmData sec d)
 238         = returnUs $ CmmData sec d
 239
 240 regAlloc cmm@(CmmProc (LiveInfo info _ _) lbl params [])
 241         = returnUs $ CmmProc info lbl params []
 242
 243 regAlloc cmm@(CmmProc (LiveInfo info (Just first_id) block_live) lbl params comps)
 244  = let  ann_sccs = map (\b -> case b of
 245                                 BasicBlock i [b]        -> AcyclicSCC b
 246                                 BasicBlock i bs         -> CyclicSCC  bs)
 247                 $ comps
 248
 249    in   linearRegAlloc block_live ann_sccs `thenUs` \final_blocks ->
 250
 251          let    ((first':_), rest')     = partition ((== first_id) . blockId) final_blocks
 252          in     returnUs $ CmmProc info lbl params (first' : rest')
 253
 254
 255
 256 -- -----------------------------------------------------------------------------
 257 -- Linear sweep to allocate registers
 258
 259 data Loc = InReg   {-# UNPACK #-} !RegNo
 260          | InMem   {-# UNPACK #-} !Int          -- stack slot
 261          | InBoth  {-# UNPACK #-} !RegNo
 262                    {-# UNPACK #-} !Int          -- stack slot
 263   deriving (Eq, Show, Ord)
 264
 265 {-
 266 A temporary can be marked as living in both a register and memory
 267 (InBoth), for example if it was recently loaded from a spill location.
 268 This makes it cheap to spill (no save instruction required), but we
 269 have to be careful to turn this into InReg if the value in the
 270 register is changed.
 271
 272 This is also useful when a temporary is about to be clobbered.  We
 273 save it in a spill location, but mark it as InBoth because the current
 274 instruction might still want to read it.
 275 -}
 276
 277 #ifdef DEBUG
 278 instance Outputable Loc where
 279   ppr l = text (show l)
 280 #endif
 281
 282 linearRegAlloc
 283    :: BlockMap RegSet           -- live regs on entry to each basic block
 284    -> [SCC LiveBasicBlock]      -- instructions annotated with "deaths"
 285    -> UniqSM [NatBasicBlock]
 286 linearRegAlloc block_live sccs = linearRA_SCCs emptyBlockMap emptyStackMap sccs
 287   where
 288   linearRA_SCCs
 289         :: BlockAssignment
 290         -> StackMap
 291         -> [SCC LiveBasicBlock]
 292         -> UniqSM [NatBasicBlock]
 293   linearRA_SCCs block_assig stack [] = returnUs []
 294   linearRA_SCCs block_assig stack
 295         (AcyclicSCC (BasicBlock id instrs) : sccs)
 296         = getUs `thenUs` \us ->
 297           let
 298             (block_assig',stack',(instrs',fixups)) =
 299                case lookupUFM block_assig id of
 300                     -- no prior info about this block: assume everything is
 301                     -- free and the assignment is empty.
 302                     Nothing ->
 303                         runR block_assig initFreeRegs
 304                                     emptyRegMap stack us $
 305                             linearRA [] [] instrs
 306                     Just (freeregs,assig) ->
 307                        runR block_assig freeregs assig stack us $
 308                             linearRA [] [] instrs
 309           in
 310           linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks ->
 311           returnUs $ BasicBlock id instrs' : fixups ++ moreBlocks
 312
 313   linearRA_SCCs block_assig stack
 314         (CyclicSCC blocks : sccs)
 315         = getUs `thenUs` \us ->
 316           let
 317             ((block_assig', stack', _), blocks') = mapAccumL processBlock
 318                                                        (block_assig, stack, us)
 319                                                        ({-reverse-} blocks)
 320           in
 321           linearRA_SCCs block_assig' stack' sccs `thenUs` \moreBlocks ->
 322           returnUs $ concat blocks' ++ moreBlocks
 323     where
 324         processBlock (block_assig, stack, us0) (BasicBlock id instrs)
 325           = ((block_assig', stack', us'), BasicBlock id instrs' : fixups)
 326           where
 327                 (us, us') = splitUniqSupply us0
 328                 (block_assig',stack',(instrs',fixups)) =
 329                    case lookupUFM block_assig id of
 330                         -- no prior info about this block: assume everything is
 331                         -- free and the assignment is empty.
 332                         Nothing ->
 333                            runR block_assig initFreeRegs
 334                                         emptyRegMap stack us $
 335                                 linearRA [] [] instrs
 336                         Just (freeregs,assig) ->
 337                            runR block_assig freeregs assig stack us $
 338                                 linearRA [] [] instrs
 339
 340   linearRA :: [Instr] -> [NatBasicBlock] -> [LiveInstr]
 341         -> RegM ([Instr], [NatBasicBlock])
 342   linearRA instr_acc fixups [] =
 343     return (reverse instr_acc, fixups)
 344   linearRA instr_acc fixups (instr:instrs) = do
 345     (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
 346     linearRA instr_acc' (new_fixups++fixups) instrs
 347
 348 -- -----------------------------------------------------------------------------
 349 -- Register allocation for a single instruction
 350
 351 type BlockAssignment = BlockMap (FreeRegs, RegMap Loc)
 352
 353 raInsn  :: BlockMap RegSet              -- Live temporaries at each basic block
 354         -> [Instr]                      -- new instructions (accum.)
 355         -> LiveInstr                    -- the instruction (with "deaths")
 356         -> RegM (
 357              [Instr],                   -- new instructions
 358              [NatBasicBlock]            -- extra fixup blocks
 359            )
 360
 361 raInsn block_live new_instrs (Instr instr@(COMMENT _) Nothing)
 362  = return (new_instrs, [])
 363
 364 raInsn block_live new_instrs (Instr instr@(DELTA n) Nothing)
 365  = do
 366     setDeltaR n
 367     return (new_instrs, [])
 368
 369 raInsn block_live new_instrs (Instr instr (Just live))
 370  = do
 371     assig    <- getAssigR
 372
 373     -- If we have a reg->reg move between virtual registers, where the
 374     -- src register is not live after this instruction, and the dst
 375     -- register does not already have an assignment,
 376     -- and the source register is assigned to a register, not to a spill slot,
 377     -- then we can eliminate the instruction.
 378     -- (we can't eliminitate it if the source register is on the stack, because
 379     --  we do not want to use one spill slot for different virtual registers)
 380     case isRegRegMove instr of
 381         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
 382                           isVirtualReg dst,
 383                           not (dst `elemUFM` assig),
 384                           Just (InReg _) <- (lookupUFM assig src) -> do
 385            case src of
 386               RealReg i -> setAssigR (addToUFM assig dst (InReg i))
 387                 -- if src is a fixed reg, then we just map dest to this
 388                 -- reg in the assignment.  src must be an allocatable reg,
 389                 -- otherwise it wouldn't be in r_dying.
 390               _virt -> case lookupUFM assig src of
 391                          Nothing -> panic "raInsn"
 392                          Just loc ->
 393                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
 394
 395            -- we have elimianted this instruction
 396            {-
 397            freeregs <- getFreeRegsR
 398            assig <- getAssigR
 399            pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
 400            -}
 401            return (new_instrs, [])
 402
 403         other -> genRaInsn block_live new_instrs instr
 404                         (uniqSetToList $ liveDieRead live)
 405                         (uniqSetToList $ liveDieWrite live)
 406
 407
 408 raInsn block_live new_instrs li
 409         = pprPanic "raInsn" (text "no match for:" <> ppr li)
 410
 411
 412 genRaInsn block_live new_instrs instr r_dying w_dying =
 413     case regUsage instr              of { RU read written ->
 414     case partition isRealReg written of { (real_written1,virt_written) ->
 415     do
 416     let
 417         real_written = [ r | RealReg r <- real_written1 ]
 418
 419         -- we don't need to do anything with real registers that are
 420         -- only read by this instr.  (the list is typically ~2 elements,
 421         -- so using nub isn't a problem).
 422         virt_read = nub (filter isVirtualReg read)
 423     -- in
 424
 425     -- (a) save any temporaries which will be clobbered by this instruction
 426     clobber_saves <- saveClobberedTemps real_written r_dying
 427
 428     {-
 429     freeregs <- getFreeRegsR
 430     assig <- getAssigR
 431     pprTrace "raInsn" (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written $$ text (show freeregs) $$ ppr assig) $ do
 432     -}
 433
 434     -- (b), (c) allocate real regs for all regs read by this instruction.
 435     (r_spills, r_allocd) <-
 436         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 437
 438     -- (d) Update block map for new destinations
 439     -- NB. do this before removing dead regs from the assignment, because
 440     -- these dead regs might in fact be live in the jump targets (they're
 441     -- only dead in the code that follows in the current basic block).
 442     (fixup_blocks, adjusted_instr)
 443         <- joinToTargets block_live [] instr (jumpDests instr [])
 444
 445     -- (e) Delete all register assignments for temps which are read
 446     --     (only) and die here.  Update the free register list.
 447     releaseRegs r_dying
 448
 449     -- (f) Mark regs which are clobbered as unallocatable
 450     clobberRegs real_written
 451
 452     -- (g) Allocate registers for temporaries *written* (only)
 453     (w_spills, w_allocd) <-
 454         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 455
 456     -- (h) Release registers for temps which are written here and not
 457     -- used again.
 458     releaseRegs w_dying
 459
 460     let
 461         -- (i) Patch the instruction
 462         patch_map = listToUFM   [ (t,RealReg r) |
 463                                   (t,r) <- zip virt_read r_allocd
 464                                           ++ zip virt_written w_allocd ]
 465
 466         patched_instr = patchRegs adjusted_instr patchLookup
 467         patchLookup x = case lookupUFM patch_map x of
 468                                 Nothing -> x
 469                                 Just y  -> y
 470     -- in
 471
 472     -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
 473
 474     -- (j) free up stack slots for dead spilled regs
 475     -- TODO (can't be bothered right now)
 476
 477     return (patched_instr : w_spills ++ reverse r_spills
 478                  ++ clobber_saves ++ new_instrs,
 479             fixup_blocks)
 480   }}
 481
 482 -- -----------------------------------------------------------------------------
 483 -- releaseRegs
 484
 485 releaseRegs regs = do
 486   assig <- getAssigR
 487   free <- getFreeRegsR
 488   loop assig free regs
 489  where
 490   loop assig free _ | free `seq` False = undefined
 491   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 492   loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
 493   loop assig free (r:rs) =
 494      case lookupUFM assig r of
 495         Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
 496         Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
 497         _other            -> loop (delFromUFM assig r) free rs
 498
 499 -- -----------------------------------------------------------------------------
 500 -- Clobber real registers
 501
 502 {-
 503 For each temp in a register that is going to be clobbered:
 504   - if the temp dies after this instruction, do nothing
 505   - otherwise, put it somewhere safe (another reg if possible,
 506     otherwise spill and record InBoth in the assignment).
 507
 508 for allocateRegs on the temps *read*,
 509   - clobbered regs are allocatable.
 510
 511 for allocateRegs on the temps *written*,
 512   - clobbered regs are not allocatable.
 513 -}
 514
 515 saveClobberedTemps
 516    :: [RegNo]              -- real registers clobbered by this instruction
 517    -> [Reg]                -- registers which are no longer live after this insn
 518    -> RegM [Instr]         -- return: instructions to spill any temps that will
 519                            -- be clobbered.
 520
 521 saveClobberedTemps [] _ = return [] -- common case
 522 saveClobberedTemps clobbered dying =  do
 523   assig <- getAssigR
 524   let
 525         to_spill  = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
 526                                    reg `elem` clobbered,
 527                                    temp `notElem` map getUnique dying  ]
 528   -- in
 529   (instrs,assig') <- clobber assig [] to_spill
 530   setAssigR assig'
 531   return instrs
 532  where
 533   clobber assig instrs [] = return (instrs,assig)
 534   clobber assig instrs ((temp,reg):rest)
 535     = do
 536         --ToDo: copy it to another register if possible
 537       (spill,slot) <- spillR (RealReg reg) temp
 538       clobber (addToUFM assig temp (InBoth reg slot)) (spill: COMMENT FSLIT("spill clobber") : instrs) rest
 539
 540 clobberRegs :: [RegNo] -> RegM ()
 541 clobberRegs [] = return () -- common case
 542 clobberRegs clobbered = do
 543   freeregs <- getFreeRegsR
 544   setFreeRegsR $! foldr allocateReg freeregs clobbered
 545   assig <- getAssigR
 546   setAssigR $! clobber assig (ufmToList assig)
 547  where
 548     -- if the temp was InReg and clobbered, then we will have
 549     -- saved it in saveClobberedTemps above.  So the only case
 550     -- we have to worry about here is InBoth.  Note that this
 551     -- also catches temps which were loaded up during allocation
 552     -- of read registers, not just those saved in saveClobberedTemps.
 553   clobber assig [] = assig
 554   clobber assig ((temp, InBoth reg slot) : rest)
 555         | reg `elem` clobbered
 556         = clobber (addToUFM assig temp (InMem slot)) rest
 557   clobber assig (entry:rest)
 558         = clobber assig rest
 559
 560 -- -----------------------------------------------------------------------------
 561 -- allocateRegsAndSpill
 562
 563 -- This function does several things:
 564 --   For each temporary referred to by this instruction,
 565 --   we allocate a real register (spilling another temporary if necessary).
 566 --   We load the temporary up from memory if necessary.
 567 --   We also update the register assignment in the process, and
 568 --   the list of free registers and free stack slots.
 569
 570 allocateRegsAndSpill
 571         :: Bool                 -- True <=> reading (load up spilled regs)
 572         -> [Reg]                -- don't push these out
 573         -> [Instr]              -- spill insns
 574         -> [RegNo]              -- real registers allocated (accum.)
 575         -> [Reg]                -- temps to allocate
 576         -> RegM ([Instr], [RegNo])
 577
 578 allocateRegsAndSpill reading keep spills alloc []
 579   = return (spills,reverse alloc)
 580
 581 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 582   assig <- getAssigR
 583   case lookupUFM assig r of
 584   -- case (1a): already in a register
 585      Just (InReg my_reg) ->
 586         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 587
 588   -- case (1b): already in a register (and memory)
 589   -- NB1. if we're writing this register, update its assignemnt to be
 590   -- InReg, because the memory value is no longer valid.
 591   -- NB2. This is why we must process written registers here, even if they
 592   -- are also read by the same instruction.
 593      Just (InBoth my_reg mem) -> do
 594         when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 595         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 596
 597   -- Not already in a register, so we need to find a free one...
 598      loc -> do
 599         freeregs <- getFreeRegsR
 600
 601         case getFreeRegs (regClass r) freeregs of
 602
 603         -- case (2): we have a free register
 604           my_reg:_ -> do
 605             spills'   <- do_load reading loc my_reg spills
 606             let new_loc
 607                  | Just (InMem slot) <- loc, reading = InBoth my_reg slot
 608                  | otherwise                         = InReg my_reg
 609             setAssigR (addToUFM assig r $! new_loc)
 610             setFreeRegsR (allocateReg my_reg freeregs)
 611             allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 612
 613         -- case (3): we need to push something out to free up a register
 614           [] -> do
 615             let
 616               keep' = map getUnique keep
 617               candidates1 = [ (temp,reg,mem)
 618                             | (temp, InBoth reg mem) <- ufmToList assig,
 619                               temp `notElem` keep', regClass (RealReg reg) == regClass r ]
 620               candidates2 = [ (temp,reg)
 621                             | (temp, InReg reg) <- ufmToList assig,
 622                               temp `notElem` keep', regClass (RealReg reg) == regClass r  ]
 623             -- in
 624             ASSERT2(not (null candidates1 && null candidates2),
 625                     text (show freeregs) <+> ppr r <+> ppr assig) do
 626
 627             case candidates1 of
 628
 629              -- we have a temporary that is in both register and mem,
 630              -- just free up its register for use.
 631              --
 632              (temp,my_reg,slot):_ -> do
 633                 spills' <- do_load reading loc my_reg spills
 634                 let
 635                   assig1  = addToUFM assig temp (InMem slot)
 636                   assig2  = addToUFM assig1 r (InReg my_reg)
 637                 -- in
 638                 setAssigR assig2
 639                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 640
 641              -- otherwise, we need to spill a temporary that currently
 642              -- resides in a register.
 643              [] -> do
 644                 let
 645                   (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
 646                   -- TODO: plenty of room for optimisation in choosing which temp
 647                   -- to spill.  We just pick the first one that isn't used in
 648                   -- the current instruction for now.
 649                 -- in
 650                 (spill_insn,slot) <- spillR (RealReg my_reg) temp_to_push_out
 651                 let
 652                   assig1  = addToUFM assig temp_to_push_out (InMem slot)
 653                   assig2  = addToUFM assig1 r (InReg my_reg)
 654                 -- in
 655                 setAssigR assig2
 656                 spills' <- do_load reading loc my_reg spills
 657                 allocateRegsAndSpill reading keep
 658                         (spill_insn : COMMENT FSLIT("spill alloc") : spills')
 659                         (my_reg:alloc) rs
 660   where
 661         -- load up a spilled temporary if we need to
 662         do_load True (Just (InMem slot)) reg spills = do
 663            insn <- loadR (RealReg reg) slot
 664            return (insn : COMMENT FSLIT("spill load") : spills)
 665         do_load _ _ _ spills =
 666            return spills
 667
 668 myHead s [] = panic s
 669 myHead s (x:xs) = x
 670
 671 -- -----------------------------------------------------------------------------
 672 -- Joining a jump instruction to its targets
 673
 674 -- The first time we encounter a jump to a particular basic block, we
 675 -- record the assignment of temporaries.  The next time we encounter a
 676 -- jump to the same block, we compare our current assignment to the
 677 -- stored one.  They might be different if spilling has occrred in one
 678 -- branch; so some fixup code will be required to match up the
 679 -- assignments.
 680
 681 joinToTargets
 682         :: BlockMap RegSet
 683         -> [NatBasicBlock]
 684         -> Instr
 685         -> [BlockId]
 686         -> RegM ([NatBasicBlock], Instr)
 687
 688 joinToTargets block_live new_blocks instr []
 689   = return (new_blocks, instr)
 690 joinToTargets block_live new_blocks instr (dest:dests) = do
 691   block_assig <- getBlockAssigR
 692   assig <- getAssigR
 693   let
 694         -- adjust the assignment to remove any registers which are not
 695         -- live on entry to the destination block.
 696         adjusted_assig = filterUFM_Directly still_live assig
 697         still_live uniq _ = uniq `elemUniqSet_Directly` live_set
 698
 699         -- and free up those registers which are now free.
 700         to_free =
 701           [ r | (reg, loc) <- ufmToList assig,
 702                 not (elemUniqSet_Directly reg live_set),
 703                 r <- regsOfLoc loc ]
 704
 705         regsOfLoc (InReg r)    = [r]
 706         regsOfLoc (InBoth r _) = [r]
 707         regsOfLoc (InMem _)    = []
 708   -- in
 709   case lookupUFM block_assig dest of
 710         -- Nothing <=> this is the first time we jumped to this
 711         -- block.
 712         Nothing -> do
 713           freeregs <- getFreeRegsR
 714           let freeregs' = foldr releaseReg freeregs to_free
 715           setBlockAssigR (addToUFM block_assig dest
 716                                 (freeregs',adjusted_assig))
 717           joinToTargets block_live new_blocks instr dests
 718
 719         Just (freeregs,dest_assig)
 720            | ufmToList dest_assig == ufmToList adjusted_assig
 721            -> -- ok, the assignments match
 722              joinToTargets block_live new_blocks instr dests
 723            | otherwise
 724            -> -- need fixup code
 725              do
 726                delta <- getDeltaR
 727                -- Construct a graph of register/spill movements and
 728                -- untangle it component by component.
 729                --
 730                -- We cut some corners by
 731                -- a) not handling cyclic components
 732                -- b) not handling memory-to-memory moves.
 733                --
 734                -- Cyclic components seem to occur only very rarely,
 735                -- and we don't need memory-to-memory moves because we
 736                -- make sure that every temporary always gets its own
 737                -- stack slot.
 738
 739                let graph = [ node | (vreg, src) <- ufmToList adjusted_assig,
 740                                     node <- mkNodes src vreg ]
 741
 742                    sccs = stronglyConnCompR graph
 743
 744                    mkNodes src vreg =
 745                         expandNode vreg src (lookupWithDefaultUFM_Directly
 746                                           dest_assig
 747                                           (panic "RegisterAlloc.joinToTargets")
 748                                           vreg)
 749
 750                 -- The InBoth handling is a little tricky here.  If
 751                 -- the destination is InBoth, then we must ensure that
 752                 -- the value ends up in both locations.  An InBoth
 753                 -- destination must conflict with an InReg or InMem
 754                 -- source, so we expand an InBoth destination as
 755                 -- necessary.  An InBoth source is slightly different:
 756                 -- we only care about the register that the source value
 757                 -- is in, so that we can move it to the destinations.
 758
 759                    expandNode vreg loc@(InReg src) (InBoth dst mem)
 760                         | src == dst = [(vreg, loc, [InMem mem])]
 761                         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 762                    expandNode vreg loc@(InMem src) (InBoth dst mem)
 763                         | src == mem = [(vreg, loc, [InReg dst])]
 764                         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 765                    expandNode vreg loc@(InBoth _ src) (InMem dst)
 766                         | src == dst = [] -- guaranteed to be true
 767                    expandNode vreg loc@(InBoth src _) (InReg dst)
 768                         | src == dst = []
 769                    expandNode vreg loc@(InBoth src _) dst
 770                         = expandNode vreg (InReg src) dst
 771                    expandNode vreg src dst
 772                         | src == dst = []
 773                         | otherwise  = [(vreg, src, [dst])]
 774
 775                 -- we have eliminated any possibility of single-node cylces
 776                 -- in expandNode above.
 777                    handleComponent (AcyclicSCC (vreg,src,dsts))
 778                        = return $ map (makeMove vreg src) dsts
 779
 780                 -- we can not have cycles that involve memory
 781                 -- locations as source nor as single destination
 782                 -- because memory locations (stack slots) are
 783                 -- allocated exclusively for a virtual register and
 784                 -- therefore can not require a fixup
 785                    handleComponent (CyclicSCC ((vreg,src@(InReg sreg),dsts):rest))
 786                        = do
 787                            spill_id <- getUniqueR
 788                            (saveInstr,slot) <- spillR (RealReg sreg) spill_id
 789                            remainingFixUps <- mapM handleComponent (stronglyConnCompR rest)
 790                            restoreAndFixInstr <- getRestoreMoves dsts slot
 791                            return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
 792                          where
 793                            getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
 794                              = do
 795                                  restoreToReg <- loadR (RealReg reg) slot
 796                                  return $ [restoreToReg, makeMove vreg r mem]
 797                            getRestoreMoves [InReg reg] slot
 798                              = loadR (RealReg reg) slot >>= return . (:[])
 799                            getRestoreMoves [InMem _] _ = panic "getRestoreMoves can not handle memory only restores"
 800                            getRestoreMoves _ _ = panic "getRestoreMoves unknown case"
 801                    handleComponent (CyclicSCC _)
 802                        = panic "Register Allocator: handleComponent cyclic"
 803                    makeMove vreg (InReg src) (InReg dst)
 804                        = mkRegRegMoveInstr (RealReg src) (RealReg dst)
 805                    makeMove vreg (InMem src) (InReg dst)
 806                        = mkLoadInstr (RealReg dst) delta src
 807                    makeMove vreg (InReg src) (InMem dst)
 808                        = mkSpillInstr (RealReg src) delta dst
 809                    makeMove vreg src dst
 810                        = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
 811                                  ++ show dst ++ ")"
 812                                  ++ " (workaround: use -fviaC)"
 813
 814                block_id <- getUniqueR
 815                fixUpInstrs <- mapM handleComponent sccs
 816                let block = BasicBlock (BlockId block_id) $
 817                        concat fixUpInstrs ++ mkBranchInstr dest
 818                let instr' = patchJump instr dest (BlockId block_id)
 819                joinToTargets block_live (block : new_blocks) instr' dests
 820   where
 821         live_set = lookItUp "joinToTargets" block_live dest
 822
 823 -- -----------------------------------------------------------------------------
 824 -- The register allocator's monad.
 825
 826 -- Here we keep all the state that the register allocator keeps track
 827 -- of as it walks the instructions in a basic block.
 828
 829 data RA_State
 830   = RA_State {
 831         ra_blockassig :: BlockAssignment,
 832                 -- The current mapping from basic blocks to
 833                 -- the register assignments at the beginning of that block.
 834         ra_freeregs   :: {-#UNPACK#-}!FreeRegs, -- free machine registers
 835         ra_assig      :: RegMap Loc,    -- assignment of temps to locations
 836         ra_delta      :: Int,           -- current stack delta
 837         ra_stack      :: StackMap,      -- free stack slots for spilling
 838         ra_us         :: UniqSupply     -- unique supply for generating names
 839                                         -- for fixup blocks.
 840   }
 841
 842 newtype RegM a = RegM { unReg :: RA_State -> (# RA_State, a #) }
 843
 844 instance Monad RegM where
 845   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
 846   return a  =  RegM $ \s -> (# s, a #)
 847
 848 runR :: BlockAssignment -> FreeRegs -> RegMap Loc -> StackMap -> UniqSupply
 849   -> RegM a -> (BlockAssignment, StackMap, a)
 850 runR block_assig freeregs assig stack us thing =
 851   case unReg thing (RA_State{ ra_blockassig=block_assig, ra_freeregs=freeregs,
 852                         ra_assig=assig, ra_delta=0{-???-}, ra_stack=stack,
 853                         ra_us = us }) of
 854         (# RA_State{ ra_blockassig=block_assig, ra_stack=stack' }, returned_thing #)
 855                 -> (block_assig, stack', returned_thing)
 856
 857 spillR :: Reg -> Unique -> RegM (Instr, Int)
 858 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
 859   let (stack',slot) = getStackSlotFor stack temp
 860       instr  = mkSpillInstr reg delta slot
 861   in
 862   (# s{ra_stack=stack'}, (instr,slot) #)
 863
 864 loadR :: Reg -> Int -> RegM Instr
 865 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
 866   (# s, mkLoadInstr reg delta slot #)
 867
 868 getFreeRegsR :: RegM FreeRegs
 869 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
 870   (# s, freeregs #)
 871
 872 setFreeRegsR :: FreeRegs -> RegM ()
 873 setFreeRegsR regs = RegM $ \ s ->
 874   (# s{ra_freeregs = regs}, () #)
 875
 876 getAssigR :: RegM (RegMap Loc)
 877 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
 878   (# s, assig #)
 879
 880 setAssigR :: RegMap Loc -> RegM ()
 881 setAssigR assig = RegM $ \ s ->
 882   (# s{ra_assig=assig}, () #)
 883
 884 getBlockAssigR :: RegM BlockAssignment
 885 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
 886   (# s, assig #)
 887
 888 setBlockAssigR :: BlockAssignment -> RegM ()
 889 setBlockAssigR assig = RegM $ \ s ->
 890   (# s{ra_blockassig = assig}, () #)
 891
 892 setDeltaR :: Int -> RegM ()
 893 setDeltaR n = RegM $ \ s ->
 894   (# s{ra_delta = n}, () #)
 895
 896 getDeltaR :: RegM Int
 897 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 898
 899 getUniqueR :: RegM Unique
 900 getUniqueR = RegM $ \s ->
 901   case splitUniqSupply (ra_us s) of
 902     (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
 903
 904 -- -----------------------------------------------------------------------------
 905 -- Utils
 906
 907 #ifdef DEBUG
 908 my_fromJust s p Nothing  = pprPanic ("fromJust: " ++ s) p
 909 my_fromJust s p (Just x) = x
 910 #else
 911 my_fromJust _ _ = fromJust
 912 #endif
 913
 914 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
 915 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)