Main.hs 37.3 KB
Newer Older
1
{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
2

3 4
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

5 6 7 8 9 10 11 12 13 14
-----------------------------------------------------------------------------
--
-- The register allocator
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------

{-
The algorithm is roughly:
15

16 17 18 19 20 21
  1) Compute strongly connected components of the basic block list.

  2) Compute liveness (mapping from pseudo register to
     point(s) of death?).

  3) Walk instructions in each basic block.  We keep track of
22 23 24 25 26 27
        (a) Free real registers (a bitmap?)
        (b) Current assignment of temporaries to machine registers and/or
            spill slots (call this the "assignment").
        (c) Partial mapping from basic block ids to a virt-to-loc mapping.
            When we first encounter a branch to a basic block,
            we fill in its entry in this table with the current mapping.
28 29

     For each instruction:
30
        (a) For each temporary *read* by the instruction:
31 32 33 34 35 36 37 38 39 40
            If the temporary does not have a real register allocation:
                - Allocate a real register from the free list.  If
                  the list is empty:
                  - Find a temporary to spill.  Pick one that is
                    not used in this instruction (ToDo: not
                    used for a while...)
                  - generate a spill instruction
                - If the temporary was previously spilled,
                  generate an instruction to read the temp from its spill loc.
            (optimisation: if we can see that a real register is going to
41 42
            be used soon, then don't use it for allocation).

43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
        (b) For each real register clobbered by this instruction:
            If a temporary resides in it,
                If the temporary is live after this instruction,
                    Move the temporary to another (non-clobbered & free) reg,
                    or spill it to memory.  Mark the temporary as residing
                    in both memory and a register if it was spilled (it might
                    need to be read by this instruction).

            (ToDo: this is wrong for jump instructions?)

            We do this after step (a), because if we start with
               movq v1, %rsi
            which is an instruction that clobbers %rsi, if v1 currently resides
            in %rsi we want to get
               movq %rsi, %freereg
               movq %rsi, %rsi     -- will disappear
            instead of
               movq %rsi, %freereg
               movq %freereg, %rsi

63
        (c) Update the current assignment
64

65 66 67 68 69 70 71
        (d) If the instruction is a branch:
              if the destination block already has a register assignment,
                Generate a new block with fixup code and redirect the
                jump to the new block.
              else,
                Update the block id->assignment mapping with the current
                assignment.
72

73 74
        (e) Delete all register assignments for temps which are read
            (only) and die here.  Update the free register list.
75

76 77 78
        (f) Mark all registers clobbered by this instruction as not free,
            and mark temporaries which have been spilled due to clobbering
            as in memory (step (a) marks then as in both mem & reg).
79

80 81 82 83 84 85
        (g) For each temporary *written* by this instruction:
            Allocate a real register as for (b), spilling something
            else if necessary.
                - except when updating the assignment, drop any memory
                  locations that the temporary was previously in, since
                  they will be no longer valid after this instruction.
86

87 88 89
        (h) Delete all register assignments for temps which are
            written and die here (there should rarely be any).  Update
            the free register list.
90

91
        (i) Rewrite the instruction with the new mapping.
92

93 94
        (j) For each spilled reg known to be now dead, re-add its stack slot
            to the free list.
95 96 97

-}

98
module RegAlloc.Linear.Main (
99 100 101
        regAlloc,
        module  RegAlloc.Linear.Base,
        module  RegAlloc.Linear.Stats
102 103 104 105
  ) where

#include "HsVersions.h"

106

107 108
import GhcPrelude

109 110 111 112 113
import RegAlloc.Linear.State
import RegAlloc.Linear.Base
import RegAlloc.Linear.StackMap
import RegAlloc.Linear.FreeRegs
import RegAlloc.Linear.Stats
114
import RegAlloc.Linear.JoinToTargets
ian@well-typed.com's avatar
ian@well-typed.com committed
115 116 117 118
import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
import qualified RegAlloc.Linear.X86.FreeRegs    as X86
import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
119
import TargetReg
120
import RegAlloc.Liveness
121 122
import Instruction
import Reg
123

124 125 126
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm hiding (RegSet)
127 128

import Digraph
129
import DynFlags
130
import Unique
131
import UniqSet
132
import UniqFM
133
import UniqSupply
134
import Outputable
John Ericson's avatar
John Ericson committed
135
import GHC.Platform
136

137 138 139
import Data.Maybe
import Data.List
import Control.Monad
140 141 142 143

-- -----------------------------------------------------------------------------
-- Top level of the register allocator

144
-- Allocate registers
145
regAlloc
Ian Lynagh's avatar
Ian Lynagh committed
146
        :: (Outputable instr, Instruction instr)
147
        => DynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
148
        -> LiveCmmDecl statics instr
149 150 151
        -> UniqSM ( NatCmmDecl statics instr
                  , Maybe Int  -- number of extra stack slots required,
                               -- beyond maxSpillSlots
152 153
                  , Maybe RegAllocStats
                  )
154

155
regAlloc _ (CmmData sec d)
156 157
        = return
                ( CmmData sec d
158
                , Nothing
159 160
                , Nothing )

161 162
regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
        = return ( CmmProc info lbl live (ListGraph [])
163
                 , Nothing
164 165
                 , Nothing )

166
regAlloc dflags (CmmProc static lbl live sccs)
167
        | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
168 169
        = do
                -- do register allocation on each component.
170
                (final_blocks, stats, stack_use)
171
                        <- linearRegAlloc dflags entry_ids block_live sccs
172 173 174 175 176 177

                -- make sure the block that was first in the input list
                --      stays at the front of the output
                let ((first':_), rest')
                                = partition ((== first_id) . blockId) final_blocks

178 179 180 181 182 183 184
                let max_spill_slots = maxSpillSlots dflags
                    extra_stack
                      | stack_use > max_spill_slots
                      = Just (stack_use - max_spill_slots)
                      | otherwise
                      = Nothing

185
                return  ( CmmProc info lbl live (ListGraph (first' : rest'))
186
                        , extra_stack
187 188
                        , Just stats)

Ben.Lippmeier@anu.edu.au's avatar
Ben.Lippmeier@anu.edu.au committed
189
-- bogus. to make non-exhaustive match warning go away.
190
regAlloc _ (CmmProc _ _ _ _)
191
        = panic "RegAllocLinear.regAlloc: no match"
192

193

194 195 196
-- -----------------------------------------------------------------------------
-- Linear sweep to allocate registers

197 198

-- | Do register allocation on some basic blocks.
199 200
--   But be careful to allocate a block in an SCC only if it has
--   an entry in the block map or it is the first block.
201
--
202
linearRegAlloc
Ian Lynagh's avatar
Ian Lynagh committed
203
        :: (Outputable instr, Instruction instr)
204
        => DynFlags
205 206 207 208 209
        -> [BlockId] -- ^ entry points
        -> BlockMap RegSet
              -- ^ live regs on entry to each basic block
        -> [SCC (LiveBasicBlock instr)]
              -- ^ instructions annotated with "deaths"
210
        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
211

212
linearRegAlloc dflags entry_ids block_live sccs
213 214 215
 = case platformArch platform of
      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
216
      ArchS390X      -> panic "linearRegAlloc ArchS390X"
217
      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
218
      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"
219 220 221
      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
      ArchARM64      -> panic "linearRegAlloc ArchARM64"
222
      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
223 224 225
      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
thoughtpolice's avatar
thoughtpolice committed
226
      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
227 228 229 230
      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
 where
  go f = linearRegAlloc' dflags f entry_ids block_live sccs
  platform = targetPlatform dflags
231 232

linearRegAlloc'
Ian Lynagh's avatar
Ian Lynagh committed
233
        :: (FR freeRegs, Outputable instr, Instruction instr)
234
        => DynFlags
235
        -> freeRegs
236
        -> [BlockId]                    -- ^ entry points
237 238
        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
239
        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
240

241
linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
242
 = do   us      <- getUniqueSupplyM
243
        let (_, stack, stats, blocks) =
244
                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
245
                    $ linearRA_SCCs entry_ids block_live [] sccs
246
        return  (blocks, stats, getStackUse stack)
247

248

Ian Lynagh's avatar
Ian Lynagh committed
249
linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
250
              => [BlockId]
251 252 253
              -> BlockMap RegSet
              -> [NatBasicBlock instr]
              -> [SCC (LiveBasicBlock instr)]
254
              -> RegM freeRegs [NatBasicBlock instr]
255

256
linearRA_SCCs _ _ blocksAcc []
257
        = return $ reverse blocksAcc
258

259
linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
260
 = do   blocks' <- processBlock block_live block
261
        linearRA_SCCs entry_ids block_live
262 263
                ((reverse blocks') ++ blocksAcc)
                sccs
264

265
linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
266
 = do
267 268
        blockss' <- process entry_ids block_live blocks [] (return []) False
        linearRA_SCCs entry_ids block_live
269 270
                (reverse (concat blockss') ++ blocksAcc)
                sccs
271 272 273

{- from John Dias's patch 2008/10/16:
   The linear-scan allocator sometimes allocates a block
274
   before allocating one of its predecessors, which could lead to
275 276 277 278 279
   inconsistent allocations. Make it so a block is only allocated
   if a predecessor has set the "incoming" assignments for the block, or
   if it's the procedure's entry block.

   BL 2009/02: Careful. If the assignment for a block doesn't get set for
280
   some reason then this function will loop. We should probably do some
281 282
   more sanity checking to guard against this eventuality.
-}
283

Ian Lynagh's avatar
Ian Lynagh committed
284
process :: (FR freeRegs, Instruction instr, Outputable instr)
285
        => [BlockId]
286 287 288 289 290
        -> BlockMap RegSet
        -> [GenBasicBlock (LiveInstr instr)]
        -> [GenBasicBlock (LiveInstr instr)]
        -> [[NatBasicBlock instr]]
        -> Bool
291
        -> RegM freeRegs [[NatBasicBlock instr]]
292

293
process _ _ [] []         accum _
294
        = return $ reverse accum
295

296
process entry_ids block_live [] next_round accum madeProgress
297 298 299 300 301 302 303 304 305
        | not madeProgress

          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
                (  text "Unreachable blocks:"
                $$ vcat (map ppr next_round)) -}
        = return $ reverse accum

        | otherwise
306
        = process entry_ids block_live
307 308
                  next_round [] accum False

309
process entry_ids block_live (b@(BasicBlock id _) : blocks)
310 311 312 313 314
        next_round accum madeProgress
 = do
        block_assig <- getBlockAssigR

        if isJust (mapLookup id block_assig)
315
             || id `elem` entry_ids
316
         then do
317
                b'  <- processBlock block_live b
318
                process entry_ids block_live blocks
319
                        next_round (b' : accum) True
320

321
         else   process entry_ids block_live blocks
322
                        (b : next_round) accum madeProgress
323

324 325 326 327

-- | Do register allocation on this basic block
--
processBlock
Ian Lynagh's avatar
Ian Lynagh committed
328
        :: (FR freeRegs, Outputable instr, Instruction instr)
329
        => BlockMap RegSet              -- ^ live regs on entry to each basic block
330
        -> LiveBasicBlock instr         -- ^ block to do register allocation on
331
        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
332

333 334
processBlock block_live (BasicBlock id instrs)
 = do   initBlock id block_live
335
        (instrs', fixups)
336
                <- linearRA block_live [] [] id instrs
337
        return  $ BasicBlock id instrs' : fixups
338 339 340


-- | Load the freeregs and current reg assignment into the RegM state
341
--      for the basic block with this BlockId.
342
initBlock :: FR freeRegs
343 344 345 346 347
          => BlockId -> BlockMap RegSet -> RegM freeRegs ()
initBlock id block_live
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags
        block_assig     <- getBlockAssigR
348
        case mapLookup id block_assig of
349 350 351 352 353
                -- no prior info about this block: we must consider
                -- any fixed regs to be allocated, but we can ignore
                -- virtual regs (presumably this is part of a loop,
                -- and we'll iterate again).  The assignment begins
                -- empty.
354 355
                Nothing
                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
356 357
                        case mapLookup id block_live of
                          Nothing ->
358
                            setFreeRegsR    (frInitFreeRegs platform)
359
                          Just live ->
360
                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
David Feuer's avatar
David Feuer committed
361
                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
niteria's avatar
niteria committed
362
                            -- See Note [Unique Determinism and code generation]
363 364 365 366 367 368
                        setAssigR       emptyRegMap

                -- load info about register assignments leading into this block.
                Just (freeregs, assig)
                 -> do  setFreeRegsR    freeregs
                        setAssigR       assig
369 370


371
-- | Do allocation for a sequence of instructions.
372
linearRA
Ian Lynagh's avatar
Ian Lynagh committed
373
        :: (FR freeRegs, Outputable instr, Instruction instr)
374
        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
375 376 377 378
        -> [instr]                              -- ^ accumulator for instructions already processed.
        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
        -> BlockId                              -- ^ id of the current block, for debugging.
        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
379

380
        -> RegM freeRegs
381
                ( [instr]                       --   instructions after register allocation
382
                , [NatBasicBlock instr])        --   fresh blocks of fixup code.
383

384

385
linearRA _          accInstr accFixup _ []
386 387 388
        = return
                ( reverse accInstr              -- instrs need to be returned in the correct order.
                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.
389 390


391
linearRA block_live accInstr accFixups id (instr:instrs)
392
 = do
393
        (accInstr', new_fixups) <- raInsn block_live accInstr id instr
394

395
        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
396 397


398
-- | Do allocation for a single instruction.
399
raInsn
Ian Lynagh's avatar
Ian Lynagh committed
400
        :: (FR freeRegs, Outputable instr, Instruction instr)
401
        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
402 403 404
        -> [instr]                              -- ^ accumulator for instructions already processed.
        -> BlockId                              -- ^ the id of the current block, for debugging
        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
405
        -> RegM freeRegs
406 407
                ( [instr]                       -- new instructions
                , [NatBasicBlock instr])        -- extra fixup blocks
408

409
raInsn _     new_instrs _ (LiveInstr ii Nothing)
410 411 412 413
        | Just n        <- takeDeltaInstr ii
        = do    setDeltaR n
                return (new_instrs, [])

414
raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
415
        | isMetaInstr ii
416
        = return (i : new_instrs, [])
417

418

419
raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
420
 = do
421 422 423 424
    assig    <- getAssigR

    -- If we have a reg->reg move between virtual registers, where the
    -- src register is not live after this instruction, and the dst
425 426 427
    -- register does not already have an assignment,
    -- and the source register is assigned to a register, not to a spill slot,
    -- then we can eliminate the instruction.
428
    -- (we can't eliminate it if the source register is on the stack, because
429
    --  we do not want to use one spill slot for different virtual registers)
430
    case takeRegRegMoveInstr instr of
431 432 433
        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
                          isVirtualReg dst,
                          not (dst `elemUFM` assig),
434
                          isRealReg src || isInReg src assig -> do
435 436 437 438 439 440 441 442 443 444 445
           case src of
              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
                -- if src is a fixed reg, then we just map dest to this
                -- reg in the assignment.  src must be an allocatable reg,
                -- otherwise it wouldn't be in r_dying.
              _virt -> case lookupUFM assig src of
                         Nothing -> panic "raInsn"
                         Just loc ->
                           setAssigR (addToUFM (delFromUFM assig src) dst loc)

           -- we have eliminated this instruction
446
          {-
447 448 449 450
          freeregs <- getFreeRegsR
          assig <- getAssigR
          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
451
          -}
452
           return (new_instrs, [])
453

454
        _ -> genRaInsn block_live new_instrs id instr
David Feuer's avatar
David Feuer committed
455 456
                        (nonDetEltsUniqSet $ liveDieRead live)
                        (nonDetEltsUniqSet $ liveDieWrite live)
niteria's avatar
niteria committed
457
                        -- See Note [Unique Determinism and code generation]
458

459
raInsn _ _ _ instr
Ian Lynagh's avatar
Ian Lynagh committed
460
        = pprPanic "raInsn" (text "no match for:" <> ppr instr)
461

462 463 464 465 466 467 468 469 470 471 472 473
-- ToDo: what can we do about
--
--     R1 = x
--     jump I64[x] // [R1]
--
-- where x is mapped to the same reg as R1.  We want to coalesce x and
-- R1, but the register allocator doesn't know whether x will be
-- assigned to again later, in which case x and R1 should be in
-- different registers.  Right now we assume the worst, and the
-- assignment to R1 will clobber x, so we'll spill x into another reg,
-- generating another reg->reg move.

474

475 476 477 478 479
isInReg :: Reg -> RegMap Loc -> Bool
isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
                  | otherwise = False


Ian Lynagh's avatar
Ian Lynagh committed
480
genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
481
          => BlockMap RegSet
482 483 484 485 486
          -> [instr]
          -> BlockId
          -> instr
          -> [Reg]
          -> [Reg]
487
          -> RegM freeRegs ([instr], [NatBasicBlock instr])
488

489 490 491 492
genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
  dflags <- getDynFlags
  let platform = targetPlatform dflags
  case regUsageOfInstr platform instr of { RU read written ->
493
    do
494 495
    let real_written    = [ rr  | (RegReal     rr) <- written ]
    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
496

497 498 499
    -- we don't need to do anything with real registers that are
    -- only read by this instr.  (the list is typically ~2 elements,
    -- so using nub isn't a problem).
500
    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]
501

502
    -- debugging
503
{-    freeregs <- getFreeRegsR
504
    assig    <- getAssigR
Moritz Angermann's avatar
Moritz Angermann committed
505
    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
506 507 508 509 510 511 512 513
        (ppr instr
                $$ text "r_dying      = " <+> ppr r_dying
                $$ text "w_dying      = " <+> ppr w_dying
                $$ text "virt_read    = " <+> ppr virt_read
                $$ text "virt_written = " <+> ppr virt_written
                $$ text "freeregs     = " <+> text (show freeregs)
                $$ text "assig        = " <+> ppr assig)
        $ do
514
-}
515

516
    -- (a), (b) allocate real regs for all regs read by this instruction.
517
    (r_spills, r_allocd) <-
518
        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
519

Simon Marlow's avatar
Simon Marlow committed
520
    -- (c) save any temporaries which will be clobbered by this instruction
521
    clobber_saves <- saveClobberedTemps real_written r_dying
522

523 524 525 526 527
    -- (d) Update block map for new destinations
    -- NB. do this before removing dead regs from the assignment, because
    -- these dead regs might in fact be live in the jump targets (they're
    -- only dead in the code that follows in the current basic block).
    (fixup_blocks, adjusted_instr)
528
        <- joinToTargets block_live block_id instr
529

530 531 532 533 534
    -- Debugging - show places where the reg alloc inserted
    -- assignment fixup blocks.
    -- when (not $ null fixup_blocks) $
    --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())

535 536
    -- (e) Delete all register assignments for temps which are read
    --     (only) and die here.  Update the free register list.
537
    releaseRegs r_dying
538 539

    -- (f) Mark regs which are clobbered as unallocatable
540
    clobberRegs real_written
541 542

    -- (g) Allocate registers for temporaries *written* (only)
543
    (w_spills, w_allocd) <-
544
        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
545 546 547

    -- (h) Release registers for temps which are written here and not
    -- used again.
548
    releaseRegs w_dying
549 550

    let
551 552 553 554 555 556
        -- (i) Patch the instruction
        patch_map
                = listToUFM
                        [ (t, RegReal r)
                                | (t, r) <- zip virt_read    r_allocd
                                         ++ zip virt_written w_allocd ]
557

558 559
        patched_instr
                = patchRegsOfInstr adjusted_instr patchLookup
560

561 562 563 564
        patchLookup x
                = case lookupUFM patch_map x of
                        Nothing -> x
                        Just y  -> y
565 566 567 568 569


    -- (j) free up stack slots for dead spilled regs
    -- TODO (can't be bothered right now)

570
    -- erase reg->reg moves where the source and destination are the same.
571 572 573 574 575 576
    --  If the src temp didn't die in this instr but happened to be allocated
    --  to the same real reg as the destination, then we can erase the move anyway.
    let squashed_instr  = case takeRegRegMoveInstr patched_instr of
                                Just (src, dst)
                                 | src == dst   -> []
                                _               -> [patched_instr]
577

578
    let code = squashed_instr ++ w_spills ++ reverse r_spills
579
                ++ clobber_saves ++ new_instrs
580 581 582 583 584 585

--    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
--    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do

    return (code, fixup_blocks)

586
  }
587 588 589 590

-- -----------------------------------------------------------------------------
-- releaseRegs

591 592 593 594
releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
releaseRegs regs = do
  dflags <- getDynFlags
  let platform = targetPlatform dflags
595 596
  assig <- getAssigR
  free <- getFreeRegsR
597 598 599
  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
      loop assig !free (r:rs) =
600 601 602 603 604 605
         case lookupUFM assig r of
         Just (InBoth real _) -> loop (delFromUFM assig r)
                                      (frReleaseReg platform real free) rs
         Just (InReg real)    -> loop (delFromUFM assig r)
                                      (frReleaseReg platform real free) rs
         _                    -> loop (delFromUFM assig r) free rs
606
  loop assig free regs
607

608

609 610 611
-- -----------------------------------------------------------------------------
-- Clobber real registers

612
-- For each temp in a register that is going to be clobbered:
613 614 615 616 617
--      - if the temp dies after this instruction, do nothing
--      - otherwise, put it somewhere safe (another reg if possible,
--              otherwise spill and record InBoth in the assignment).
--      - for allocateRegs on the temps *read*,
--      - clobbered regs are allocatable.
618
--
619 620
--      for allocateRegs on the temps *written*,
--        - clobbered regs are not allocatable.
621
--
622 623

saveClobberedTemps
624
        :: (Instruction instr, FR freeRegs)
625
        => [RealReg]            -- real registers clobbered by this instruction
626
        -> [Reg]                -- registers which are no longer live after this insn
627
        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
628
                                -- be clobbered.
629

630
saveClobberedTemps [] _
631
        = return []
632

633
saveClobberedTemps clobbered dying
634
 = do
635 636 637
        assig   <- getAssigR
        let to_spill
                = [ (temp,reg)
niteria's avatar
niteria committed
638 639 640 641
                        | (temp, InReg reg) <- nonDetUFMToList assig
                        -- This is non-deterministic but we do not
                        -- currently support deterministic code-generation.
                        -- See Note [Unique Determinism and code generation]
642 643
                        , any (realRegsAlias reg) clobbered
                        , temp `notElem` map getUnique dying  ]
644

645 646 647
        (instrs,assig') <- clobber assig [] to_spill
        setAssigR assig'
        return instrs
648 649

   where
650 651 652 653
     clobber assig instrs []
            = return (instrs, assig)

     clobber assig instrs ((temp, reg) : rest)
654 655 656
       = do dflags <- getDynFlags
            let platform = targetPlatform dflags

657 658
            freeRegs <- getFreeRegsR
            let regclass = targetClassOfRealReg platform reg
659
                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
660 661 662 663 664 665 666

            case filter (`notElem` clobbered) freeRegs_thisClass of

              -- (1) we have a free reg of the right class that isn't
              -- clobbered by this instruction; use it to save the
              -- clobbered value.
              (my_reg : _) -> do
667
                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)
668 669 670 671 672 673 674 675 676

                  let new_assign = addToUFM assig temp (InReg my_reg)
                  let instr = mkRegRegMoveInstr platform
                                  (RegReal reg) (RegReal my_reg)

                  clobber new_assign (instr : instrs) rest

              -- (2) no free registers: spill the value
              [] -> do
677
                  (spill, slot)   <- spillR (RegReal reg) temp
678

679 680
                  -- record why this reg was spilled for profiling
                  recordSpill (SpillClobber temp)
681

682
                  let new_assign  = addToUFM assig temp (InBoth reg slot)
683

684
                  clobber new_assign (spill : instrs) rest
685 686 687



688
-- | Mark all these real regs as allocated,
689
--      and kick out their vreg assignments.
690
--
691 692
clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
clobberRegs []
693
        = return ()
694

695 696 697 698
clobberRegs clobbered
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags

699
        freeregs        <- getFreeRegsR
700
        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
701

702
        assig           <- getAssigR
niteria's avatar
niteria committed
703 704 705 706
        setAssigR $! clobber assig (nonDetUFMToList assig)
          -- This is non-deterministic but we do not
          -- currently support deterministic code-generation.
          -- See Note [Unique Determinism and code generation]
707 708

   where
709 710 711 712 713 714 715 716 717 718 719 720 721 722 723
        -- if the temp was InReg and clobbered, then we will have
        -- saved it in saveClobberedTemps above.  So the only case
        -- we have to worry about here is InBoth.  Note that this
        -- also catches temps which were loaded up during allocation
        -- of read registers, not just those saved in saveClobberedTemps.

        clobber assig []
                = assig

        clobber assig ((temp, InBoth reg slot) : rest)
                | any (realRegsAlias reg) clobbered
                = clobber (addToUFM assig temp (InMem slot)) rest

        clobber assig (_:rest)
                = clobber assig rest
724 725 726 727

-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill

728 729 730 731 732 733 734 735 736 737
-- Why are we performing a spill?
data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
              | WriteNew           -- writing to a new variable
              | WriteMem           -- writing to register only in memory
-- Note that ReadNew is not valid, since you don't want to be reading
-- from an uninitialized register.  We also don't need the location of
-- the register in memory, since that will be invalidated by the write.
-- Technically, we could coalesce WriteNew and WriteMem into a single
-- entry as well. -- EZY

738 739 740 741 742 743 744 745
-- This function does several things:
--   For each temporary referred to by this instruction,
--   we allocate a real register (spilling another temporary if necessary).
--   We load the temporary up from memory if necessary.
--   We also update the register assignment in the process, and
--   the list of free registers and free stack slots.

allocateRegsAndSpill
Ian Lynagh's avatar
Ian Lynagh committed
746
        :: (FR freeRegs, Outputable instr, Instruction instr)
747
        => Bool                 -- True <=> reading (load up spilled regs)
748 749 750 751
        -> [VirtualReg]         -- don't push these out
        -> [instr]              -- spill insns
        -> [RealReg]            -- real registers allocated (accum.)
        -> [VirtualReg]         -- temps to allocate
752
        -> RegM freeRegs ( [instr] , [RealReg])
753

754
allocateRegsAndSpill _       _    spills alloc []
755 756
        = return (spills, reverse alloc)

757
allocateRegsAndSpill reading keep spills alloc (r:rs)
758
 = do   assig <- getAssigR
759
        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
760 761 762
        case lookupUFM assig r of
                -- case (1a): already in a register
                Just (InReg my_reg) ->
763
                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
764 765 766 767 768 769 770 771

                -- case (1b): already in a register (and memory)
                -- NB1. if we're writing this register, update its assignment to be
                -- InReg, because the memory value is no longer valid.
                -- NB2. This is why we must process written registers here, even if they
                -- are also read by the same instruction.
                Just (InBoth my_reg _)
                 -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
772
                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
773 774 775 776

                -- Not already in a register, so we need to find a free one...
                Just (InMem slot) | reading   -> doSpill (ReadMem slot)
                                  | otherwise -> doSpill WriteMem
777
                Nothing | reading   ->
778 779 780 781
                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
                   -- NOTE: if the input to the NCG contains some
                   -- unreachable blocks with junk code, this panic
                   -- might be triggered.  Make sure you only feed
782
                   -- sensible code into the NCG.  In GHC.Cmm.Pipeline we
783 784
                   -- call removeUnreachableBlocks at the end for this
                   -- reason.
785

786 787
                        | otherwise -> doSpill WriteNew

788

789 790
-- reading is redundant with reason, but we keep it around because it's
-- convenient and it maintains the recursive structure of the allocator. -- EZY
Ian Lynagh's avatar
Ian Lynagh committed
791
allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
792
                        => Bool
793 794 795 796 797 798 799
                        -> [VirtualReg]
                        -> [instr]
                        -> [RealReg]
                        -> VirtualReg
                        -> [VirtualReg]
                        -> UniqFM Loc
                        -> SpillLoc
800
                        -> RegM freeRegs ([instr], [RealReg])
801 802 803
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
 = do   dflags <- getDynFlags
        let platform = targetPlatform dflags
804
        freeRegs                <- getFreeRegsR
805
        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs
806 807 808

        case freeRegs_thisClass of

809 810
         -- case (2): we have a free register
         (my_reg : _) ->
811
           do   spills'   <- loadTemp r spill_loc my_reg spills
812 813

                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
814
                setFreeRegsR $  frAllocateReg platform my_reg freeRegs
815

816
                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
817 818 819 820


          -- case (3): we need to push something out to free up a register
         [] ->
821 822 823 824 825 826 827 828 829 830 831
           do   let inRegOrBoth (InReg _) = True
                    inRegOrBoth (InBoth _ _) = True
                    inRegOrBoth _ = False
                let candidates' =
                      flip delListFromUFM keep $
                      filterUFM inRegOrBoth $
                      assig
                      -- This is non-deterministic but we do not
                      -- currently support deterministic code-generation.
                      -- See Note [Unique Determinism and code generation]
                let candidates = nonDetUFMToList candidates'
832 833 834 835

                -- the vregs we could kick out that are already in a slot
                let candidates_inBoth
                        = [ (temp, reg, mem)
836
                          | (temp, InBoth reg mem) <- candidates
niteria's avatar
niteria committed
837
                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
838 839 840 841 842

                -- the vregs we could kick out that are only in a reg
                --      this would require writing the reg to a new slot before using it.
                let candidates_inReg
                        = [ (temp, reg)
843
                          | (temp, InReg reg) <- candidates
niteria's avatar
niteria committed
844
                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
845 846 847 848 849 850

                let result

                        -- we have a temporary that is in both register and mem,
                        -- just free up its register for use.
                        | (temp, my_reg, slot) : _      <- candidates_inBoth
851
                        = do    spills' <- loadTemp r spill_loc my_reg spills
852 853 854 855
                                let assig1  = addToUFM assig temp (InMem slot)
                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg

                                setAssigR assig2
856
                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
857 858 859 860 861 862

                        -- otherwise, we need to spill a temporary that currently
                        -- resides in a register.
                        | (temp_to_push_out, (my_reg :: RealReg)) : _
                                        <- candidates_inReg
                        = do
863
                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
864 865 866 867 868 869 870 871 872 873 874 875 876
                                let spill_store  = (if reading then id else reverse)
                                                        [ -- COMMENT (fsLit "spill alloc")
                                                           spill_insn ]

                                -- record that this temp was spilled
                                recordSpill (SpillAlloc temp_to_push_out)

                                -- update the register assignment
                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
                                setAssigR assig2

                                -- if need be, load up a spilled temp into the reg we've just freed up.
877
                                spills' <- loadTemp r spill_loc my_reg spills
878

879
                                allocateRegsAndSpill reading keep
880 881 882 883 884 885 886 887 888
                                        (spill_store ++ spills')
                                        (my_reg:alloc) rs


                        -- there wasn't anything to spill, so we're screwed.
                        | otherwise
                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
                        $ vcat
                                [ text "allocating vreg:  " <> text (show r)
niteria's avatar
niteria committed
889
                                , text "assignment:       " <> ppr assig
890 891
                                , text "freeRegs:         " <> text (show freeRegs)
                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
892 893 894

                result

895

896 897 898 899 900 901 902 903
-- | Calculate a new location after a register has been loaded.
newLocation :: SpillLoc -> RealReg -> Loc
-- if the tmp was read from a slot, then now its in a reg as well
newLocation (ReadMem slot) my_reg = InBoth my_reg slot
-- writes will always result in only the register being available
newLocation _ my_reg = InReg my_reg

-- | Load up a spilled temporary if we need to (read from memory).
904
loadTemp
905
        :: (Instruction instr)
906
        => VirtualReg   -- the temp being loaded
907 908 909
        -> SpillLoc     -- the current location of this temp
        -> RealReg      -- the hreg to load the temp into
        -> [instr]
910
        -> RegM freeRegs [instr]
911

912
loadTemp vreg (ReadMem slot) hreg spills
913
 = do
914
        insn <- loadR (RegReal hreg) slot
915 916
        recordSpill (SpillLoad $ getUnique vreg)
        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
917

918
loadTemp _ _ _ spills =
919 920
   return spills