compiler/nativeGen/RegAlloc/Linear/Main.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 RegAlloc.Linear.Main (
  85         regAlloc,
  86         module  RegAlloc.Linear.Base,
  87         module  RegAlloc.Linear.Stats
  88   ) where
  89
  90 #include "HsVersions.h"
  91
  92
  93 import RegAlloc.Linear.State
  94 import RegAlloc.Linear.Base
  95 import RegAlloc.Linear.StackMap
  96 import RegAlloc.Linear.FreeRegs
  97 import RegAlloc.Linear.Stats
  98
  99 import BlockId
 100 import MachRegs
 101 import MachInstrs
 102 import RegAllocInfo
 103 import RegLiveness
 104 import Cmm hiding (RegSet)
 105
 106 import Digraph
 107 import Unique           ( Uniquable(getUnique), Unique )
 108 import UniqSet
 109 import UniqFM
 110 import UniqSupply
 111 import Outputable
 112 import FastString
 113
 114 import Data.Maybe
 115 import Data.List
 116 import Control.Monad
 117
 118 #include "../includes/MachRegs.h"
 119
 120
 121 -- -----------------------------------------------------------------------------
 122 -- Top level of the register allocator
 123
 124 -- Allocate registers
 125 regAlloc
 126         :: LiveCmmTop
 127         -> UniqSM (NatCmmTop, Maybe RegAllocStats)
 128
 129 regAlloc (CmmData sec d)
 130         = return
 131                 ( CmmData sec d
 132                 , Nothing )
 133
 134 regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
 135         = return ( CmmProc info lbl params (ListGraph [])
 136                  , Nothing )
 137
 138 regAlloc (CmmProc static lbl params (ListGraph comps))
 139         | LiveInfo info (Just first_id) block_live      <- static
 140         = do
 141                 -- do register allocation on each component.
 142                 (final_blocks, stats)
 143                         <- linearRegAlloc first_id block_live
 144                         $ map (\b -> case b of
 145                                         BasicBlock _ [b]        -> AcyclicSCC b
 146                                         BasicBlock _ bs         -> CyclicSCC  bs)
 147                         $ comps
 148
 149                 -- make sure the block that was first in the input list
 150                 --      stays at the front of the output
 151                 let ((first':_), rest')
 152                                 = partition ((== first_id) . blockId) final_blocks
 153
 154                 return  ( CmmProc info lbl params (ListGraph (first' : rest'))
 155                         , Just stats)
 156
 157 -- bogus. to make non-exhaustive match warning go away.
 158 regAlloc (CmmProc _ _ _ _)
 159         = panic "RegAllocLinear.regAlloc: no match"
 160
 161
 162 -- -----------------------------------------------------------------------------
 163 -- Linear sweep to allocate registers
 164
 165
 166 -- | Do register allocation on some basic blocks.
 167 --   But be careful to allocate a block in an SCC only if it has
 168 --   an entry in the block map or it is the first block.
 169 --
 170 linearRegAlloc
 171         :: BlockId                      -- ^ the first block
 172         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
 173         -> [SCC LiveBasicBlock]         -- ^ instructions annotated with "deaths"
 174         -> UniqSM ([NatBasicBlock], RegAllocStats)
 175
 176 linearRegAlloc first_id block_live sccs
 177  = do   us      <- getUs
 178         let (_, _, stats, blocks) =
 179                 runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us
 180                         $ linearRA_SCCs first_id block_live [] sccs
 181
 182         return  (blocks, stats)
 183
 184 linearRA_SCCs _ _ blocksAcc []
 185         = return $ reverse blocksAcc
 186
 187 linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
 188  = do   blocks' <- processBlock block_live block
 189         linearRA_SCCs first_id block_live
 190                 ((reverse blocks') ++ blocksAcc)
 191                 sccs
 192
 193 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
 194  = do   let process [] []         accum = return $ reverse accum
 195             process [] next_round accum = process next_round [] accum
 196             process (b@(BasicBlock id _) : blocks) next_round accum =
 197               do block_assig <- getBlockAssigR
 198                  if isJust (lookupBlockEnv block_assig id) || id == first_id
 199                   then do b'  <- processBlock block_live b
 200                           process blocks next_round (b' : accum)
 201                   else process blocks (b : next_round) accum
 202         blockss' <- process blocks [] (return [])
 203         linearRA_SCCs first_id block_live
 204                 (reverse (concat blockss') ++ blocksAcc)
 205                 sccs
 206
 207
 208 -- | Do register allocation on this basic block
 209 --
 210 processBlock
 211         :: BlockMap RegSet              -- ^ live regs on entry to each basic block
 212         -> LiveBasicBlock               -- ^ block to do register allocation on
 213         -> RegM [NatBasicBlock]         -- ^ block with registers allocated
 214
 215 processBlock block_live (BasicBlock id instrs)
 216  = do   initBlock id
 217         (instrs', fixups)
 218                 <- linearRA block_live [] [] instrs
 219
 220         return  $ BasicBlock id instrs' : fixups
 221
 222
 223 -- | Load the freeregs and current reg assignment into the RegM state
 224 --      for the basic block with this BlockId.
 225 initBlock :: BlockId -> RegM ()
 226 initBlock id
 227  = do   block_assig     <- getBlockAssigR
 228         case lookupBlockEnv block_assig id of
 229                 -- no prior info about this block: assume everything is
 230                 -- free and the assignment is empty.
 231                 Nothing
 232                  -> do  setFreeRegsR    initFreeRegs
 233                         setAssigR       emptyRegMap
 234
 235                 -- load info about register assignments leading into this block.
 236                 Just (freeregs, assig)
 237                  -> do  setFreeRegsR    freeregs
 238                         setAssigR       assig
 239
 240
 241 linearRA
 242         :: BlockMap RegSet
 243         -> [Instr] -> [NatBasicBlock] -> [LiveInstr]
 244         -> RegM ([Instr], [NatBasicBlock])
 245
 246 linearRA _          instr_acc fixups []
 247         = return (reverse instr_acc, fixups)
 248
 249 linearRA block_live instr_acc fixups (instr:instrs)
 250  = do   (instr_acc', new_fixups) <- raInsn block_live instr_acc instr
 251         linearRA block_live instr_acc' (new_fixups++fixups) instrs
 252
 253 -- -----------------------------------------------------------------------------
 254 -- Register allocation for a single instruction
 255
 256 raInsn  :: BlockMap RegSet              -- Live temporaries at each basic block
 257         -> [Instr]                      -- new instructions (accum.)
 258         -> LiveInstr                    -- the instruction (with "deaths")
 259         -> RegM (
 260              [Instr],                   -- new instructions
 261              [NatBasicBlock]            -- extra fixup blocks
 262            )
 263
 264 raInsn _     new_instrs (Instr (COMMENT _) Nothing)
 265  = return (new_instrs, [])
 266
 267 raInsn _     new_instrs (Instr (DELTA n) Nothing)
 268  = do
 269     setDeltaR n
 270     return (new_instrs, [])
 271
 272 raInsn block_live new_instrs (Instr instr (Just live))
 273  = do
 274     assig    <- getAssigR
 275
 276     -- If we have a reg->reg move between virtual registers, where the
 277     -- src register is not live after this instruction, and the dst
 278     -- register does not already have an assignment,
 279     -- and the source register is assigned to a register, not to a spill slot,
 280     -- then we can eliminate the instruction.
 281     -- (we can't eliminitate it if the source register is on the stack, because
 282     --  we do not want to use one spill slot for different virtual registers)
 283     case isRegRegMove instr of
 284         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
 285                           isVirtualReg dst,
 286                           not (dst `elemUFM` assig),
 287                           Just (InReg _) <- (lookupUFM assig src) -> do
 288            case src of
 289               RealReg i -> setAssigR (addToUFM assig dst (InReg i))
 290                 -- if src is a fixed reg, then we just map dest to this
 291                 -- reg in the assignment.  src must be an allocatable reg,
 292                 -- otherwise it wouldn't be in r_dying.
 293               _virt -> case lookupUFM assig src of
 294                          Nothing -> panic "raInsn"
 295                          Just loc ->
 296                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
 297
 298            -- we have eliminated this instruction
 299           {-
 300           freeregs <- getFreeRegsR
 301           assig <- getAssigR
 302           pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
 303           -}
 304            return (new_instrs, [])
 305
 306         _ -> genRaInsn block_live new_instrs instr
 307                         (uniqSetToList $ liveDieRead live)
 308                         (uniqSetToList $ liveDieWrite live)
 309
 310
 311 raInsn _ _ li
 312         = pprPanic "raInsn" (text "no match for:" <> ppr li)
 313
 314
 315 genRaInsn block_live new_instrs instr r_dying w_dying =
 316     case regUsage instr              of { RU read written ->
 317     case partition isRealReg written of { (real_written1,virt_written) ->
 318     do
 319     let
 320         real_written = [ r | RealReg r <- real_written1 ]
 321
 322         -- we don't need to do anything with real registers that are
 323         -- only read by this instr.  (the list is typically ~2 elements,
 324         -- so using nub isn't a problem).
 325         virt_read = nub (filter isVirtualReg read)
 326     -- in
 327
 328     -- (a) save any temporaries which will be clobbered by this instruction
 329     clobber_saves <- saveClobberedTemps real_written r_dying
 330
 331
 332 {-  freeregs <- getFreeRegsR
 333     assig <- getAssigR
 334     pprTrace "raInsn"
 335         (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written
 336                 $$ text (show freeregs) $$ ppr assig)
 337                 $ do
 338 -}
 339
 340     -- (b), (c) allocate real regs for all regs read by this instruction.
 341     (r_spills, r_allocd) <-
 342         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
 343
 344     -- (d) Update block map for new destinations
 345     -- NB. do this before removing dead regs from the assignment, because
 346     -- these dead regs might in fact be live in the jump targets (they're
 347     -- only dead in the code that follows in the current basic block).
 348     (fixup_blocks, adjusted_instr)
 349         <- joinToTargets block_live [] instr (jumpDests instr [])
 350
 351     -- (e) Delete all register assignments for temps which are read
 352     --     (only) and die here.  Update the free register list.
 353     releaseRegs r_dying
 354
 355     -- (f) Mark regs which are clobbered as unallocatable
 356     clobberRegs real_written
 357
 358     -- (g) Allocate registers for temporaries *written* (only)
 359     (w_spills, w_allocd) <-
 360         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
 361
 362     -- (h) Release registers for temps which are written here and not
 363     -- used again.
 364     releaseRegs w_dying
 365
 366     let
 367         -- (i) Patch the instruction
 368         patch_map = listToUFM   [ (t,RealReg r) |
 369                                   (t,r) <- zip virt_read r_allocd
 370                                           ++ zip virt_written w_allocd ]
 371
 372         patched_instr = patchRegs adjusted_instr patchLookup
 373         patchLookup x = case lookupUFM patch_map x of
 374                                 Nothing -> x
 375                                 Just y  -> y
 376     -- in
 377
 378     -- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do
 379
 380     -- (j) free up stack slots for dead spilled regs
 381     -- TODO (can't be bothered right now)
 382
 383     -- erase reg->reg moves where the source and destination are the same.
 384     --  If the src temp didn't die in this instr but happened to be allocated
 385     --  to the same real reg as the destination, then we can erase the move anyway.
 386         squashed_instr  = case isRegRegMove patched_instr of
 387                                 Just (src, dst)
 388                                  | src == dst   -> []
 389                                 _               -> [patched_instr]
 390
 391     return (squashed_instr ++ w_spills ++ reverse r_spills
 392                  ++ clobber_saves ++ new_instrs,
 393             fixup_blocks)
 394   }}
 395
 396 -- -----------------------------------------------------------------------------
 397 -- releaseRegs
 398
 399 releaseRegs regs = do
 400   assig <- getAssigR
 401   free <- getFreeRegsR
 402   loop assig free regs
 403  where
 404   loop _     free _ | free `seq` False = undefined
 405   loop assig free [] = do setAssigR assig; setFreeRegsR free; return ()
 406   loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs
 407   loop assig free (r:rs) =
 408      case lookupUFM assig r of
 409         Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs
 410         Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs
 411         _other            -> loop (delFromUFM assig r) free rs
 412
 413 -- -----------------------------------------------------------------------------
 414 -- Clobber real registers
 415
 416 {-
 417 For each temp in a register that is going to be clobbered:
 418   - if the temp dies after this instruction, do nothing
 419   - otherwise, put it somewhere safe (another reg if possible,
 420     otherwise spill and record InBoth in the assignment).
 421
 422 for allocateRegs on the temps *read*,
 423   - clobbered regs are allocatable.
 424
 425 for allocateRegs on the temps *written*,
 426   - clobbered regs are not allocatable.
 427 -}
 428
 429 saveClobberedTemps
 430    :: [RegNo]              -- real registers clobbered by this instruction
 431    -> [Reg]                -- registers which are no longer live after this insn
 432    -> RegM [Instr]         -- return: instructions to spill any temps that will
 433                            -- be clobbered.
 434
 435 saveClobberedTemps [] _ = return [] -- common case
 436 saveClobberedTemps clobbered dying =  do
 437   assig <- getAssigR
 438   let
 439         to_spill  = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig,
 440                                    reg `elem` clobbered,
 441                                    temp `notElem` map getUnique dying  ]
 442   -- in
 443   (instrs,assig') <- clobber assig [] to_spill
 444   setAssigR assig'
 445   return instrs
 446  where
 447   clobber assig instrs [] = return (instrs,assig)
 448   clobber assig instrs ((temp,reg):rest)
 449     = do
 450         --ToDo: copy it to another register if possible
 451         (spill,slot) <- spillR (RealReg reg) temp
 452         recordSpill (SpillClobber temp)
 453
 454         let new_assign  = addToUFM assig temp (InBoth reg slot)
 455         clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
 456
 457 clobberRegs :: [RegNo] -> RegM ()
 458 clobberRegs [] = return () -- common case
 459 clobberRegs clobbered = do
 460   freeregs <- getFreeRegsR
 461 --  setFreeRegsR $! foldr grabReg freeregs clobbered
 462   setFreeRegsR $! foldr allocateReg freeregs clobbered
 463
 464   assig <- getAssigR
 465   setAssigR $! clobber assig (ufmToList assig)
 466  where
 467     -- if the temp was InReg and clobbered, then we will have
 468     -- saved it in saveClobberedTemps above.  So the only case
 469     -- we have to worry about here is InBoth.  Note that this
 470     -- also catches temps which were loaded up during allocation
 471     -- of read registers, not just those saved in saveClobberedTemps.
 472   clobber assig [] = assig
 473   clobber assig ((temp, InBoth reg slot) : rest)
 474         | reg `elem` clobbered
 475         = clobber (addToUFM assig temp (InMem slot)) rest
 476   clobber assig (_:rest)
 477         = clobber assig rest
 478
 479 -- -----------------------------------------------------------------------------
 480 -- allocateRegsAndSpill
 481
 482 -- This function does several things:
 483 --   For each temporary referred to by this instruction,
 484 --   we allocate a real register (spilling another temporary if necessary).
 485 --   We load the temporary up from memory if necessary.
 486 --   We also update the register assignment in the process, and
 487 --   the list of free registers and free stack slots.
 488
 489 allocateRegsAndSpill
 490         :: Bool                 -- True <=> reading (load up spilled regs)
 491         -> [Reg]                -- don't push these out
 492         -> [Instr]              -- spill insns
 493         -> [RegNo]              -- real registers allocated (accum.)
 494         -> [Reg]                -- temps to allocate
 495         -> RegM ([Instr], [RegNo])
 496
 497 allocateRegsAndSpill _       _    spills alloc []
 498   = return (spills,reverse alloc)
 499
 500 allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 501   assig <- getAssigR
 502   case lookupUFM assig r of
 503   -- case (1a): already in a register
 504      Just (InReg my_reg) ->
 505         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 506
 507   -- case (1b): already in a register (and memory)
 508   -- NB1. if we're writing this register, update its assignemnt to be
 509   -- InReg, because the memory value is no longer valid.
 510   -- NB2. This is why we must process written registers here, even if they
 511   -- are also read by the same instruction.
 512      Just (InBoth my_reg _) -> do
 513         when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
 514         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
 515
 516   -- Not already in a register, so we need to find a free one...
 517      loc -> do
 518         freeregs <- getFreeRegsR
 519
 520         case getFreeRegs (regClass r) freeregs of
 521
 522         -- case (2): we have a free register
 523           my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -}
 524             do
 525             spills'   <- loadTemp reading r loc my_reg spills
 526             let new_loc
 527                  | Just (InMem slot) <- loc, reading = InBoth my_reg slot
 528                  | otherwise                         = InReg my_reg
 529             setAssigR (addToUFM assig r $! new_loc)
 530             setFreeRegsR $ allocateReg my_reg freeregs
 531             allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 532
 533         -- case (3): we need to push something out to free up a register
 534           [] -> do
 535             let
 536               keep' = map getUnique keep
 537               candidates1 = [ (temp,reg,mem)
 538                             | (temp, InBoth reg mem) <- ufmToList assig,
 539                               temp `notElem` keep', regClass (RealReg reg) == regClass r ]
 540               candidates2 = [ (temp,reg)
 541                             | (temp, InReg reg) <- ufmToList assig,
 542                               temp `notElem` keep', regClass (RealReg reg) == regClass r  ]
 543             -- in
 544             ASSERT2(not (null candidates1 && null candidates2),
 545                     text (show freeregs) <+> ppr r <+> ppr assig) do
 546
 547             case candidates1 of
 548
 549              -- we have a temporary that is in both register and mem,
 550              -- just free up its register for use.
 551              --
 552              (temp,my_reg,slot):_ -> do
 553                 spills' <- loadTemp reading r loc my_reg spills
 554                 let
 555                   assig1  = addToUFM assig temp (InMem slot)
 556                   assig2  = addToUFM assig1 r (InReg my_reg)
 557                 -- in
 558                 setAssigR assig2
 559                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
 560
 561              -- otherwise, we need to spill a temporary that currently
 562              -- resides in a register.
 563
 564
 565              [] -> do
 566
 567                 -- TODO: plenty of room for optimisation in choosing which temp
 568                 -- to spill.  We just pick the first one that isn't used in
 569                 -- the current instruction for now.
 570
 571                 let (temp_to_push_out, my_reg)
 572                         = case candidates2 of
 573                                 []      -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates"
 574                                         ++ "assignment: " ++ show (ufmToList assig) ++ "\n"
 575                                 (x:_)   -> x
 576
 577                 (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
 578                 let spill_store  = (if reading then id else reverse)
 579                                         [ COMMENT (fsLit "spill alloc")
 580                                         , spill_insn ]
 581
 582                 -- record that this temp was spilled
 583                 recordSpill (SpillAlloc temp_to_push_out)
 584
 585                 -- update the register assignment
 586                 let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
 587                 let assig2  = addToUFM assig1 r                 (InReg my_reg)
 588                 setAssigR assig2
 589
 590                 -- if need be, load up a spilled temp into the reg we've just freed up.
 591                 spills' <- loadTemp reading r loc my_reg spills
 592
 593                 allocateRegsAndSpill reading keep
 594                         (spill_store ++ spills')
 595                         (my_reg:alloc) rs
 596
 597
 598 -- | Load up a spilled temporary if we need to.
 599 loadTemp
 600         :: Bool
 601         -> Reg          -- the temp being loaded
 602         -> Maybe Loc    -- the current location of this temp
 603         -> RegNo        -- the hreg to load the temp into
 604         -> [Instr]
 605         -> RegM [Instr]
 606
 607 loadTemp True vreg (Just (InMem slot)) hreg spills
 608  = do
 609         insn <- loadR (RealReg hreg) slot
 610         recordSpill (SpillLoad $ getUnique vreg)
 611         return  $  COMMENT (fsLit "spill load") : insn : spills
 612
 613 loadTemp _ _ _ _ spills =
 614    return spills
 615
 616
 617 -- -----------------------------------------------------------------------------
 618 -- Joining a jump instruction to its targets
 619
 620 -- The first time we encounter a jump to a particular basic block, we
 621 -- record the assignment of temporaries.  The next time we encounter a
 622 -- jump to the same block, we compare our current assignment to the
 623 -- stored one.  They might be different if spilling has occrred in one
 624 -- branch; so some fixup code will be required to match up the
 625 -- assignments.
 626
 627 joinToTargets
 628         :: BlockMap RegSet
 629         -> [NatBasicBlock]
 630         -> Instr
 631         -> [BlockId]
 632         -> RegM ([NatBasicBlock], Instr)
 633
 634 joinToTargets _          new_blocks instr []
 635   = return (new_blocks, instr)
 636
 637 joinToTargets block_live new_blocks instr (dest:dests) = do
 638   block_assig <- getBlockAssigR
 639   assig <- getAssigR
 640   let
 641         -- adjust the assignment to remove any registers which are not
 642         -- live on entry to the destination block.
 643         adjusted_assig = filterUFM_Directly still_live assig
 644
 645         live_set = lookItUp "joinToTargets" block_live dest
 646         still_live uniq _ = uniq `elemUniqSet_Directly` live_set
 647
 648         -- and free up those registers which are now free.
 649         to_free =
 650           [ r | (reg, loc) <- ufmToList assig,
 651                 not (elemUniqSet_Directly reg live_set),
 652                 r <- regsOfLoc loc ]
 653
 654         regsOfLoc (InReg r)    = [r]
 655         regsOfLoc (InBoth r _) = [r]
 656         regsOfLoc (InMem _)    = []
 657   -- in
 658   case lookupBlockEnv block_assig dest of
 659         -- Nothing <=> this is the first time we jumped to this
 660         -- block.
 661         Nothing -> do
 662           freeregs <- getFreeRegsR
 663           let freeregs' = foldr releaseReg freeregs to_free
 664           setBlockAssigR (extendBlockEnv block_assig dest
 665                                 (freeregs',adjusted_assig))
 666           joinToTargets block_live new_blocks instr dests
 667
 668         Just (_, dest_assig)
 669
 670            -- the assignments match
 671            | ufmToList dest_assig == ufmToList adjusted_assig
 672            -> joinToTargets block_live new_blocks instr dests
 673
 674            -- need fixup code
 675            | otherwise
 676            -> do
 677                delta <- getDeltaR
 678
 679                let graph = makeRegMovementGraph adjusted_assig dest_assig
 680                let sccs  = stronglyConnCompFromEdgedVerticesR graph
 681                fixUpInstrs <- mapM (handleComponent delta instr) sccs
 682
 683                block_id <- getUniqueR
 684                let block = BasicBlock (BlockId block_id) $
 685                        concat fixUpInstrs ++ mkBranchInstr dest
 686
 687                let instr' = patchJump instr dest (BlockId block_id)
 688
 689                joinToTargets block_live (block : new_blocks) instr' dests
 690
 691
 692 -- | Construct a graph of register\/spill movements.
 693 --
 694 --      We cut some corners by
 695 --      a) not handling cyclic components
 696 --      b) not handling memory-to-memory moves.
 697 --
 698 --      Cyclic components seem to occur only very rarely,
 699 --      and we don't need memory-to-memory moves because we
 700 --      make sure that every temporary always gets its own
 701 --      stack slot.
 702
 703 makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
 704 makeRegMovementGraph adjusted_assig dest_assig
 705  = let
 706         mkNodes src vreg
 707          = expandNode vreg src
 708          $ lookupWithDefaultUFM_Directly
 709                 dest_assig
 710                 (panic "RegAllocLinear.makeRegMovementGraph")
 711                 vreg
 712
 713    in   [ node  | (vreg, src) <- ufmToList adjusted_assig
 714                 , node <- mkNodes src vreg ]
 715
 716 -- The InBoth handling is a little tricky here.  If
 717 -- the destination is InBoth, then we must ensure that
 718 -- the value ends up in both locations.  An InBoth
 719 -- destination must conflict with an InReg or InMem
 720 -- source, so we expand an InBoth destination as
 721 -- necessary.  An InBoth source is slightly different:
 722 -- we only care about the register that the source value
 723 -- is in, so that we can move it to the destinations.
 724
 725 expandNode vreg loc@(InReg src) (InBoth dst mem)
 726         | src == dst = [(vreg, loc, [InMem mem])]
 727         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 728
 729 expandNode vreg loc@(InMem src) (InBoth dst mem)
 730         | src == mem = [(vreg, loc, [InReg dst])]
 731         | otherwise  = [(vreg, loc, [InReg dst, InMem mem])]
 732
 733 expandNode _        (InBoth _ src) (InMem dst)
 734         | src == dst = [] -- guaranteed to be true
 735
 736 expandNode _        (InBoth src _) (InReg dst)
 737         | src == dst = []
 738
 739 expandNode vreg     (InBoth src _) dst
 740         = expandNode vreg (InReg src) dst
 741
 742 expandNode vreg src dst
 743         | src == dst = []
 744         | otherwise  = [(vreg, src, [dst])]
 745
 746
 747 -- | Make a move instruction between these two locations so we
 748 --      can join together allocations for different basic blocks.
 749 --
 750 makeMove :: Int -> Unique -> Loc -> Loc -> RegM Instr
 751 makeMove _     vreg (InReg src) (InReg dst)
 752  = do   recordSpill (SpillJoinRR vreg)
 753         return  $ mkRegRegMoveInstr (RealReg src) (RealReg dst)
 754
 755 makeMove delta vreg (InMem src) (InReg dst)
 756  = do   recordSpill (SpillJoinRM vreg)
 757         return  $ mkLoadInstr (RealReg dst) delta src
 758
 759 makeMove delta vreg (InReg src) (InMem dst)
 760  = do   recordSpill (SpillJoinRM vreg)
 761         return  $ mkSpillInstr (RealReg src) delta dst
 762
 763 makeMove _     vreg src dst
 764         = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
 765                 ++ show dst ++ ")"
 766                 ++ " (workaround: use -fviaC)"
 767
 768
 769 -- we have eliminated any possibility of single-node cylces
 770 -- in expandNode above.
 771 handleComponent :: Int -> Instr -> SCC (Unique, Loc, [Loc]) -> RegM [Instr]
 772 handleComponent delta _  (AcyclicSCC (vreg,src,dsts))
 773          = mapM (makeMove delta vreg src) dsts
 774
 775 -- we can not have cycles that involve memory
 776 -- locations as source nor as single destination
 777 -- because memory locations (stack slots) are
 778 -- allocated exclusively for a virtual register and
 779 -- therefore can not require a fixup
 780 handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
 781  = do
 782         spill_id <- getUniqueR
 783         (_, slot)               <- spillR (RealReg sreg) spill_id
 784         remainingFixUps         <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
 785         restoreAndFixInstr      <- getRestoreMoves dsts slot
 786         return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
 787
 788         where
 789         getRestoreMoves [r@(InReg reg), mem@(InMem _)] slot
 790          = do
 791                 restoreToReg    <- loadR (RealReg reg) slot
 792                 moveInstr       <- makeMove delta vreg r mem
 793                 return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
 794
 795         getRestoreMoves [InReg reg] slot
 796                 = loadR (RealReg reg) slot >>= return . (:[])
 797
 798         getRestoreMoves [InMem _] _     = panic "getRestoreMoves can not handle memory only restores"
 799         getRestoreMoves _ _             = panic "getRestoreMoves unknown case"
 800
 801
 802 handleComponent _ _ (CyclicSCC _)
 803  = panic "Register Allocator: handleComponent cyclic"
 804
 805
 806
 807 -- -----------------------------------------------------------------------------
 808 -- Utils
 809
 810 my_fromJust :: String -> SDoc -> Maybe a -> a
 811 my_fromJust _ _ (Just x) = x
 812 my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
 813
 814 lookItUp :: String -> BlockMap a -> BlockId -> a
 815 lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x)