never executed always true always false
    1 {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
    2 {-# LANGUAGE ConstraintKinds #-}
    3 
    4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    5 
    6 -----------------------------------------------------------------------------
    7 --
    8 -- The register allocator
    9 --
   10 -- (c) The University of Glasgow 2004
   11 --
   12 -----------------------------------------------------------------------------
   13 
   14 {-
   15 The algorithm is roughly:
   16 
   17   1) Compute strongly connected components of the basic block list.
   18 
   19   2) Compute liveness (mapping from pseudo register to
   20      point(s) of death?).
   21 
   22   3) Walk instructions in each basic block.  We keep track of
   23         (a) Free real registers (a bitmap?)
   24         (b) Current assignment of temporaries to machine registers and/or
   25             spill slots (call this the "assignment").
   26         (c) Partial mapping from basic block ids to a virt-to-loc mapping.
   27             When we first encounter a branch to a basic block,
   28             we fill in its entry in this table with the current mapping.
   29 
   30      For each instruction:
   31         (a) For each temporary *read* by the instruction:
   32             If the temporary does not have a real register allocation:
   33                 - Allocate a real register from the free list.  If
   34                   the list is empty:
   35                   - Find a temporary to spill.  Pick one that is
   36                     not used in this instruction (ToDo: not
   37                     used for a while...)
   38                   - generate a spill instruction
   39                 - If the temporary was previously spilled,
   40                   generate an instruction to read the temp from its spill loc.
   41             (optimisation: if we can see that a real register is going to
   42             be used soon, then don't use it for allocation).
   43 
   44         (b) For each real register clobbered by this instruction:
   45             If a temporary resides in it,
   46                 If the temporary is live after this instruction,
   47                     Move the temporary to another (non-clobbered & free) reg,
   48                     or spill it to memory.  Mark the temporary as residing
   49                     in both memory and a register if it was spilled (it might
   50                     need to be read by this instruction).
   51 
   52             (ToDo: this is wrong for jump instructions?)
   53 
   54             We do this after step (a), because if we start with
   55                movq v1, %rsi
   56             which is an instruction that clobbers %rsi, if v1 currently resides
   57             in %rsi we want to get
   58                movq %rsi, %freereg
   59                movq %rsi, %rsi     -- will disappear
   60             instead of
   61                movq %rsi, %freereg
   62                movq %freereg, %rsi
   63 
   64         (c) Update the current assignment
   65 
   66         (d) If the instruction is a branch:
   67               if the destination block already has a register assignment,
   68                 Generate a new block with fixup code and redirect the
   69                 jump to the new block.
   70               else,
   71                 Update the block id->assignment mapping with the current
   72                 assignment.
   73 
   74         (e) Delete all register assignments for temps which are read
   75             (only) and die here.  Update the free register list.
   76 
   77         (f) Mark all registers clobbered by this instruction as not free,
   78             and mark temporaries which have been spilled due to clobbering
   79             as in memory (step (a) marks then as in both mem & reg).
   80 
   81         (g) For each temporary *written* by this instruction:
   82             Allocate a real register as for (b), spilling something
   83             else if necessary.
   84                 - except when updating the assignment, drop any memory
   85                   locations that the temporary was previously in, since
   86                   they will be no longer valid after this instruction.
   87 
   88         (h) Delete all register assignments for temps which are
   89             written and die here (there should rarely be any).  Update
   90             the free register list.
   91 
   92         (i) Rewrite the instruction with the new mapping.
   93 
   94         (j) For each spilled reg known to be now dead, re-add its stack slot
   95             to the free list.
   96 
   97 -}
   98 
   99 module GHC.CmmToAsm.Reg.Linear (
  100         regAlloc,
  101         module  GHC.CmmToAsm.Reg.Linear.Base,
  102         module  GHC.CmmToAsm.Reg.Linear.Stats
  103   ) where
  104 
  105 import GHC.Prelude
  106 
  107 import GHC.CmmToAsm.Reg.Linear.State
  108 import GHC.CmmToAsm.Reg.Linear.Base
  109 import GHC.CmmToAsm.Reg.Linear.StackMap
  110 import GHC.CmmToAsm.Reg.Linear.FreeRegs
  111 import GHC.CmmToAsm.Reg.Linear.Stats
  112 import GHC.CmmToAsm.Reg.Linear.JoinToTargets
  113 import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC
  114 import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC
  115 import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86
  116 import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64
  117 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
  118 import GHC.CmmToAsm.Reg.Target
  119 import GHC.CmmToAsm.Reg.Liveness
  120 import GHC.CmmToAsm.Reg.Utils
  121 import GHC.CmmToAsm.Instr
  122 import GHC.CmmToAsm.Config
  123 import GHC.CmmToAsm.Types
  124 import GHC.Platform.Reg
  125 import GHC.Platform.Reg.Class (RegClass(..))
  126 
  127 import GHC.Cmm.BlockId
  128 import GHC.Cmm.Dataflow.Collections
  129 import GHC.Cmm hiding (RegSet)
  130 
  131 import GHC.Data.Graph.Directed
  132 import GHC.Types.Unique
  133 import GHC.Types.Unique.Set
  134 import GHC.Types.Unique.FM
  135 import GHC.Types.Unique.Supply
  136 import GHC.Utils.Outputable
  137 import GHC.Utils.Panic
  138 import GHC.Platform
  139 
  140 import Data.Maybe
  141 import Data.List (partition, nub)
  142 import Control.Monad
  143 
  144 -- -----------------------------------------------------------------------------
  145 -- Top level of the register allocator
  146 
  147 -- Allocate registers
  148 regAlloc
  149         :: Instruction instr
  150         => NCGConfig
  151         -> LiveCmmDecl statics instr
  152         -> UniqSM ( NatCmmDecl statics instr
  153                   , Maybe Int  -- number of extra stack slots required,
  154                                -- beyond maxSpillSlots
  155                   , Maybe RegAllocStats
  156                   )
  157 
  158 regAlloc _ (CmmData sec d)
  159         = return
  160                 ( CmmData sec d
  161                 , Nothing
  162                 , Nothing )
  163 
  164 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
  165         = return ( CmmProc info lbl live (ListGraph [])
  166                  , Nothing
  167                  , Nothing )
  168 
  169 regAlloc config (CmmProc static lbl live sccs)
  170         | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
  171         = do
  172                 -- do register allocation on each component.
  173                 !(!final_blocks, !stats, !stack_use)
  174                         <- linearRegAlloc config entry_ids block_live sccs
  175 
  176                 -- make sure the block that was first in the input list
  177                 --      stays at the front of the output
  178                 let !(!(!first':_), !rest')
  179                                 = partition ((== first_id) . blockId) final_blocks
  180 
  181                 let max_spill_slots = maxSpillSlots config
  182                     extra_stack
  183                       | stack_use > max_spill_slots
  184                       = Just $! stack_use - max_spill_slots
  185                       | otherwise
  186                       = Nothing
  187 
  188                 return  ( CmmProc info lbl live (ListGraph (first' : rest'))
  189                         , extra_stack
  190                         , Just stats)
  191 
  192 -- bogus. to make non-exhaustive match warning go away.
  193 regAlloc _ (CmmProc _ _ _ _)
  194         = panic "RegAllocLinear.regAlloc: no match"
  195 
  196 
  197 -- -----------------------------------------------------------------------------
  198 -- Linear sweep to allocate registers
  199 
  200 
  201 -- | Do register allocation on some basic blocks.
  202 --   But be careful to allocate a block in an SCC only if it has
  203 --   an entry in the block map or it is the first block.
  204 --
  205 linearRegAlloc
  206         :: forall instr. (Instruction instr)
  207         => NCGConfig
  208         -> [BlockId] -- ^ entry points
  209         -> BlockMap RegSet
  210               -- ^ live regs on entry to each basic block
  211         -> [SCC (LiveBasicBlock instr)]
  212               -- ^ instructions annotated with "deaths"
  213         -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
  214 
  215 linearRegAlloc config entry_ids block_live sccs
  216  = case platformArch platform of
  217       ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
  218       ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
  219       ArchS390X      -> panic "linearRegAlloc ArchS390X"
  220       ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
  221       ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"
  222       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
  223       ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
  224       ArchAArch64    -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)
  225       ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
  226       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
  227       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
  228       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
  229       ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"
  230       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
  231       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
  232  where
  233   go :: (FR regs, Outputable regs)
  234      => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
  235   go f = linearRegAlloc' config f entry_ids block_live sccs
  236   platform = ncgPlatform config
  237 
  238 -- | Constraints on the instruction instances used by the
  239 -- linear allocator.
  240 type OutputableRegConstraint freeRegs instr =
  241         (FR freeRegs, Outputable freeRegs, Instruction instr)
  242 
  243 linearRegAlloc'
  244         :: OutputableRegConstraint freeRegs instr
  245         => NCGConfig
  246         -> freeRegs
  247         -> [BlockId]                    -- ^ entry points
  248         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
  249         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
  250         -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
  251 
  252 linearRegAlloc' config initFreeRegs entry_ids block_live sccs
  253  = do   us      <- getUniqueSupplyM
  254         let !(_, !stack, !stats, !blocks) =
  255                 runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us
  256                     $ linearRA_SCCs entry_ids block_live [] sccs
  257         return  (blocks, stats, getStackUse stack)
  258 
  259 
  260 linearRA_SCCs :: OutputableRegConstraint freeRegs instr
  261               => [BlockId]
  262               -> BlockMap RegSet
  263               -> [NatBasicBlock instr]
  264               -> [SCC (LiveBasicBlock instr)]
  265               -> RegM freeRegs [NatBasicBlock instr]
  266 
  267 linearRA_SCCs _ _ blocksAcc []
  268         = return $ reverse blocksAcc
  269 
  270 linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
  271  = do   blocks' <- processBlock block_live block
  272         linearRA_SCCs entry_ids block_live
  273                 ((reverse blocks') ++ blocksAcc)
  274                 sccs
  275 
  276 linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
  277  = do
  278         blockss' <- process entry_ids block_live blocks
  279         linearRA_SCCs entry_ids block_live
  280                 (reverse (concat blockss') ++ blocksAcc)
  281                 sccs
  282 
  283 {- from John Dias's patch 2008/10/16:
  284    The linear-scan allocator sometimes allocates a block
  285    before allocating one of its predecessors, which could lead to
  286    inconsistent allocations. Make it so a block is only allocated
  287    if a predecessor has set the "incoming" assignments for the block, or
  288    if it's the procedure's entry block.
  289 
  290    BL 2009/02: Careful. If the assignment for a block doesn't get set for
  291    some reason then this function will loop. We should probably do some
  292    more sanity checking to guard against this eventuality.
  293 -}
  294 
  295 process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
  296         => [BlockId]
  297         -> BlockMap RegSet
  298         -> [GenBasicBlock (LiveInstr instr)]
  299         -> RegM freeRegs [[NatBasicBlock instr]]
  300 process entry_ids block_live =
  301     \blocks -> go blocks [] (return []) False
  302   where
  303     go :: [GenBasicBlock (LiveInstr instr)]
  304        -> [GenBasicBlock (LiveInstr instr)]
  305        -> [[NatBasicBlock instr]]
  306        -> Bool
  307        -> RegM freeRegs [[NatBasicBlock instr]]
  308     go [] []         accum _madeProgress
  309       = return $ reverse accum
  310 
  311     go [] next_round accum madeProgress
  312       | not madeProgress
  313           {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
  314              pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
  315                 (  text "Unreachable blocks:"
  316                 $$ vcat (map ppr next_round)) -}
  317       = return $ reverse accum
  318 
  319       | otherwise
  320       = go next_round [] accum False
  321 
  322     go (b@(BasicBlock id _) : blocks) next_round accum madeProgress
  323       = do
  324           block_assig <- getBlockAssigR
  325           if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids
  326             then do b' <- processBlock block_live b
  327                     go blocks next_round (b' : accum) True
  328 
  329             else do go blocks (b : next_round) accum madeProgress
  330 
  331 
  332 -- | Do register allocation on this basic block
  333 --
  334 processBlock
  335         :: OutputableRegConstraint freeRegs instr
  336         => BlockMap RegSet              -- ^ live regs on entry to each basic block
  337         -> LiveBasicBlock instr         -- ^ block to do register allocation on
  338         -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
  339 
  340 processBlock block_live (BasicBlock id instrs)
  341  = do   -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs)
  342         initBlock id block_live
  343 
  344         (instrs', fixups)
  345                 <- linearRA block_live id instrs
  346         -- pprTraceM "blockResult" $ ppr (instrs', fixups)
  347         return  $ BasicBlock id instrs' : fixups
  348 
  349 
  350 -- | Load the freeregs and current reg assignment into the RegM state
  351 --      for the basic block with this BlockId.
  352 initBlock :: FR freeRegs
  353           => BlockId -> BlockMap RegSet -> RegM freeRegs ()
  354 initBlock id block_live
  355  = do   platform    <- getPlatform
  356         block_assig <- getBlockAssigR
  357         case lookupBlockAssignment id block_assig of
  358                 -- no prior info about this block: we must consider
  359                 -- any fixed regs to be allocated, but we can ignore
  360                 -- virtual regs (presumably this is part of a loop,
  361                 -- and we'll iterate again).  The assignment begins
  362                 -- empty.
  363                 Nothing
  364                  -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
  365                         case mapLookup id block_live of
  366                           Nothing ->
  367                             setFreeRegsR    (frInitFreeRegs platform)
  368                           Just live ->
  369                             setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
  370                                                   [ r | RegReal r <- nonDetEltsUniqSet live ]
  371                             -- See Note [Unique Determinism and code generation]
  372                         setAssigR       emptyRegMap
  373 
  374                 -- load info about register assignments leading into this block.
  375                 Just (freeregs, assig)
  376                  -> do  setFreeRegsR    freeregs
  377                         setAssigR       assig
  378 
  379 
  380 -- | Do allocation for a sequence of instructions.
  381 linearRA
  382         :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
  383         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
  384         -> BlockId                              -- ^ id of the current block, for debugging.
  385         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
  386         -> RegM freeRegs
  387                 ( [instr]                       --   instructions after register allocation
  388                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
  389 linearRA block_live block_id = go [] []
  390   where
  391     go :: [instr]                              -- ^ accumulator for instructions already processed.
  392        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
  393        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
  394        -> RegM freeRegs
  395                ( [instr]                       --   instructions after register allocation
  396                , [NatBasicBlock instr] )       --   fresh blocks of fixup code.
  397     go !accInstr !accFixups [] = do
  398         return ( reverse accInstr               -- instrs need to be returned in the correct order.
  399                , accFixups )                    -- it doesn't matter what order the fixup blocks are returned in.
  400 
  401     go accInstr accFixups (instr:instrs) = do
  402         (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr
  403         go accInstr' (new_fixups ++ accFixups) instrs
  404 
  405 -- | Do allocation for a single instruction.
  406 raInsn
  407         :: OutputableRegConstraint freeRegs instr
  408         => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
  409         -> [instr]                              -- ^ accumulator for instructions already processed.
  410         -> BlockId                              -- ^ the id of the current block, for debugging
  411         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
  412         -> RegM freeRegs
  413                 ( [instr]                       -- new instructions
  414                 , [NatBasicBlock instr])        -- extra fixup blocks
  415 
  416 raInsn _     new_instrs _ (LiveInstr ii Nothing)
  417         | Just n        <- takeDeltaInstr ii
  418         = do    setDeltaR n
  419                 return (new_instrs, [])
  420 
  421 raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
  422         | isMetaInstr ii
  423         = return (i : new_instrs, [])
  424 
  425 
  426 raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
  427  = do
  428     assig    <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
  429 
  430     -- If we have a reg->reg move between virtual registers, where the
  431     -- src register is not live after this instruction, and the dst
  432     -- register does not already have an assignment,
  433     -- and the source register is assigned to a register, not to a spill slot,
  434     -- then we can eliminate the instruction.
  435     -- (we can't eliminate it if the source register is on the stack, because
  436     --  we do not want to use one spill slot for different virtual registers)
  437     case takeRegRegMoveInstr instr of
  438         Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
  439                           isVirtualReg dst,
  440                           not (dst `elemUFM` assig),
  441                           isRealReg src || isInReg src assig -> do
  442            case src of
  443               (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
  444                 -- if src is a fixed reg, then we just map dest to this
  445                 -- reg in the assignment.  src must be an allocatable reg,
  446                 -- otherwise it wouldn't be in r_dying.
  447               _virt -> case lookupUFM assig src of
  448                          Nothing -> panic "raInsn"
  449                          Just loc ->
  450                            setAssigR (addToUFM (delFromUFM assig src) dst loc)
  451 
  452            -- we have eliminated this instruction
  453           {-
  454           freeregs <- getFreeRegsR
  455           assig <- getAssigR
  456           pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
  457                         $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
  458           -}
  459            return (new_instrs, [])
  460 
  461         _ -> genRaInsn block_live new_instrs id instr
  462                         (nonDetEltsUniqSet $ liveDieRead live)
  463                         (nonDetEltsUniqSet $ liveDieWrite live)
  464                         -- See Note [Unique Determinism and code generation]
  465 
  466 raInsn _ _ _ instr
  467         = do
  468             platform <- getPlatform
  469             let instr' = fmap (pprInstr platform) instr
  470             pprPanic "raInsn" (text "no match for:" <> ppr instr')
  471 
  472 -- ToDo: what can we do about
  473 --
  474 --     R1 = x
  475 --     jump I64[x] // [R1]
  476 --
  477 -- where x is mapped to the same reg as R1.  We want to coalesce x and
  478 -- R1, but the register allocator doesn't know whether x will be
  479 -- assigned to again later, in which case x and R1 should be in
  480 -- different registers.  Right now we assume the worst, and the
  481 -- assignment to R1 will clobber x, so we'll spill x into another reg,
  482 -- generating another reg->reg move.
  483 
  484 
  485 isInReg :: Reg -> RegMap Loc -> Bool
  486 isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
  487                   | otherwise = False
  488 
  489 
  490 genRaInsn :: forall freeRegs instr.
  491              (OutputableRegConstraint freeRegs instr)
  492           => BlockMap RegSet
  493           -> [instr]
  494           -> BlockId
  495           -> instr
  496           -> [Reg]
  497           -> [Reg]
  498           -> RegM freeRegs ([instr], [NatBasicBlock instr])
  499 
  500 genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
  501 -- pprTraceM "genRaInsn" $ ppr (block_id, instr)
  502   platform <- getPlatform
  503   case regUsageOfInstr platform instr of { RU read written ->
  504     do
  505     let real_written    = [ rr  | (RegReal     rr) <- written ] :: [RealReg]
  506     let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
  507 
  508     -- we don't need to do anything with real registers that are
  509     -- only read by this instr.  (the list is typically ~2 elements,
  510     -- so using nub isn't a problem).
  511     let virt_read       = nub [ vr      | (RegVirtual vr) <- read ] :: [VirtualReg]
  512 
  513 --     do
  514 --         let real_read       = nub [ rr      | (RegReal rr) <- read]
  515 --         freeregs <- getFreeRegsR
  516 --         assig    <- getAssigR
  517 
  518 --         pprTraceM "genRaInsn"
  519 --                 (          text "block        = " <+> ppr block_id
  520 --                         $$ text "instruction  = " <+> ppr instr
  521 --                         $$ text "r_dying      = " <+> ppr r_dying
  522 --                         $$ text "w_dying      = " <+> ppr w_dying
  523 --                         $$ text "read         = " <+> ppr real_read    <+> ppr virt_read
  524 --                         $$ text "written      = " <+> ppr real_written <+> ppr virt_written
  525 --                         $$ text "freeregs     = " <+> ppr freeregs
  526 --                         $$ text "assign       = " <+> ppr assig)
  527 
  528     -- (a), (b) allocate real regs for all regs read by this instruction.
  529     (r_spills, r_allocd) <-
  530         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
  531 
  532     -- (c) save any temporaries which will be clobbered by this instruction
  533     clobber_saves <- saveClobberedTemps real_written r_dying
  534 
  535     -- (d) Update block map for new destinations
  536     -- NB. do this before removing dead regs from the assignment, because
  537     -- these dead regs might in fact be live in the jump targets (they're
  538     -- only dead in the code that follows in the current basic block).
  539     (fixup_blocks, adjusted_instr)
  540         <- joinToTargets block_live block_id instr
  541 
  542 --     when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks
  543 
  544     -- Debugging - show places where the reg alloc inserted
  545     -- assignment fixup blocks.
  546     -- when (not $ null fixup_blocks) $
  547     --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())
  548 
  549     -- (e) Delete all register assignments for temps which are read
  550     --     (only) and die here.  Update the free register list.
  551     releaseRegs r_dying
  552 
  553     -- (f) Mark regs which are clobbered as unallocatable
  554     clobberRegs real_written
  555 
  556     -- (g) Allocate registers for temporaries *written* (only)
  557     (w_spills, w_allocd) <-
  558         allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
  559 
  560     -- (h) Release registers for temps which are written here and not
  561     -- used again.
  562     releaseRegs w_dying
  563 
  564     let
  565         -- (i) Patch the instruction
  566         patch_map :: UniqFM Reg Reg
  567         patch_map
  568                 = toRegMap $ -- Cast key from VirtualReg to Reg
  569                              -- See Note [UniqFM and the register allocator]
  570                   listToUFM
  571                         [ (t, RegReal r)
  572                                 | (t, r) <- zip virt_read    r_allocd
  573                                          ++ zip virt_written w_allocd ]
  574 
  575         patched_instr :: instr
  576         patched_instr
  577                 = patchRegsOfInstr adjusted_instr patchLookup
  578 
  579         patchLookup :: Reg -> Reg
  580         patchLookup x
  581                 = case lookupUFM patch_map x of
  582                         Nothing -> x
  583                         Just y  -> y
  584 
  585     -- (j) free up stack slots for dead spilled regs
  586     -- TODO (can't be bothered right now)
  587 
  588     -- erase reg->reg moves where the source and destination are the same.
  589     --  If the src temp didn't die in this instr but happened to be allocated
  590     --  to the same real reg as the destination, then we can erase the move anyway.
  591     let squashed_instr  = case takeRegRegMoveInstr patched_instr of
  592                                 Just (src, dst)
  593                                  | src == dst   -> []
  594                                 _               -> [patched_instr]
  595 
  596     -- On the use of @reverse@ below.
  597     -- Since we can have spills and reloads produce multiple instructions
  598     -- we need to ensure they are emitted in the correct order.  We used to only
  599     -- emit single instructions in mkSpill/mkReload/mkRegRegMove.
  600     -- As such order of spills and reloads didn't matter.  However,  with
  601     -- mutliple instructions potentially issued by those functions we need to be
  602     -- careful to not break execution order. Reversing the spills (clobber will
  603     -- also spill), will ensure they are emitted in the right order.
  604     --
  605     -- See also Ticket 19910 for changing the return type from [] to OrdList.
  606 
  607     -- For debugging, uncomment the follow line and the mkComment lines.
  608     -- u <- getUniqueR
  609     let code = concat [ --  mkComment (text "<genRaInsn(" <> ppr u <> text ")>")
  610                         -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):squashed>")]
  611                         squashed_instr
  612                         -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):w_spills>")
  613                       , reverse w_spills
  614                         -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):r_spills>")
  615                       , reverse r_spills
  616                         -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):clobber_saves>")
  617                       , reverse clobber_saves
  618                         -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):new_instrs>")
  619                       , new_instrs
  620                         -- ,mkComment (text "</genRaInsn(" <> ppr u <> text ")>")
  621                       ]
  622 
  623 --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
  624 --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
  625 
  626     return (code, fixup_blocks)
  627 
  628   }
  629 
  630 -- -----------------------------------------------------------------------------
  631 -- releaseRegs
  632 
  633 releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
  634 releaseRegs regs = do
  635   platform <- getPlatform
  636   assig <- getAssigR
  637   free <- getFreeRegsR
  638 
  639   let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
  640       loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
  641       loop assig !free (r:rs) =
  642          case lookupUFM assig r of
  643          Just (InBoth real _) -> loop (delFromUFM assig r)
  644                                       (frReleaseReg platform real free) rs
  645          Just (InReg real)    -> loop (delFromUFM assig r)
  646                                       (frReleaseReg platform real free) rs
  647          _                    -> loop (delFromUFM assig r) free rs
  648   loop assig free regs
  649 
  650 
  651 -- -----------------------------------------------------------------------------
  652 -- Clobber real registers
  653 
  654 -- For each temp in a register that is going to be clobbered:
  655 --      - if the temp dies after this instruction, do nothing
  656 --      - otherwise, put it somewhere safe (another reg if possible,
  657 --              otherwise spill and record InBoth in the assignment).
  658 --      - for allocateRegs on the temps *read*,
  659 --      - clobbered regs are allocatable.
  660 --
  661 --      for allocateRegs on the temps *written*,
  662 --        - clobbered regs are not allocatable.
  663 --
  664 
  665 saveClobberedTemps
  666         :: forall instr freeRegs.
  667            (Instruction instr, FR freeRegs)
  668         => [RealReg]            -- real registers clobbered by this instruction
  669         -> [Reg]                -- registers which are no longer live after this insn
  670         -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
  671                                 -- be clobbered.
  672 
  673 saveClobberedTemps [] _
  674         = return []
  675 
  676 saveClobberedTemps clobbered dying
  677  = do
  678         assig   <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
  679         (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig
  680         setAssigR assig'
  681         return $ -- mkComment (text "<saveClobberedTemps>") ++
  682                  instrs
  683 --              ++ mkComment (text "</saveClobberedTemps>")
  684    where
  685      -- Unique represents the VirtualReg
  686      -- Here we separate the cases which we do want to spill from these we don't.
  687      maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])
  688      maybe_spill !temp !(assig,instrs) !loc =
  689         case loc of
  690                 -- This is non-deterministic but we do not
  691                 -- currently support deterministic code-generation.
  692                 -- See Note [Unique Determinism and code generation]
  693                 InReg reg
  694                     | any (realRegsAlias reg) clobbered
  695                     , temp `notElem` map getUnique dying
  696                     -> clobber temp (assig,instrs) (reg)
  697                 _ -> return (assig,instrs)
  698 
  699 
  700      -- See Note [UniqFM and the register allocator]
  701      clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])
  702      clobber temp (assig,instrs) (reg)
  703        = do platform <- getPlatform
  704 
  705             freeRegs <- getFreeRegsR
  706             let regclass = targetClassOfRealReg platform reg
  707                 freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
  708 
  709             case filter (`notElem` clobbered) freeRegs_thisClass of
  710 
  711               -- (1) we have a free reg of the right class that isn't
  712               -- clobbered by this instruction; use it to save the
  713               -- clobbered value.
  714               (my_reg : _) -> do
  715                   setFreeRegsR (frAllocateReg platform my_reg freeRegs)
  716 
  717                   let new_assign = addToUFM_Directly assig temp (InReg my_reg)
  718                   let instr = mkRegRegMoveInstr platform
  719                                   (RegReal reg) (RegReal my_reg)
  720 
  721                   return (new_assign,(instr : instrs))
  722 
  723               -- (2) no free registers: spill the value
  724               [] -> do
  725                   (spill, slot)   <- spillR (RegReal reg) temp
  726 
  727                   -- record why this reg was spilled for profiling
  728                   recordSpill (SpillClobber temp)
  729 
  730                   let new_assign  = addToUFM_Directly assig temp (InBoth reg slot)
  731 
  732                   return (new_assign, (spill ++ instrs))
  733 
  734 
  735 
  736 
  737 -- | Mark all these real regs as allocated,
  738 --      and kick out their vreg assignments.
  739 --
  740 clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
  741 clobberRegs []
  742         = return ()
  743 
  744 clobberRegs clobbered
  745  = do   platform <- getPlatform
  746         freeregs <- getFreeRegsR
  747 
  748         let gpRegs  = frGetFreeRegs platform RcInteger freeregs :: [RealReg]
  749             fltRegs = frGetFreeRegs platform RcFloat   freeregs :: [RealReg]
  750             dblRegs = frGetFreeRegs platform RcDouble  freeregs :: [RealReg]
  751 
  752         let extra_clobbered = [ r | r <- clobbered
  753                                   , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ]
  754 
  755         setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered
  756 
  757         -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
  758 
  759         assig           <- getAssigR
  760         setAssigR $! clobber assig (nonDetUFMToList assig)
  761           -- This is non-deterministic but we do not
  762           -- currently support deterministic code-generation.
  763           -- See Note [Unique Determinism and code generation]
  764 
  765    where
  766         -- if the temp was InReg and clobbered, then we will have
  767         -- saved it in saveClobberedTemps above.  So the only case
  768         -- we have to worry about here is InBoth.  Note that this
  769         -- also catches temps which were loaded up during allocation
  770         -- of read registers, not just those saved in saveClobberedTemps.
  771 
  772         clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
  773         clobber assig []
  774                 = assig
  775 
  776         clobber assig ((temp, InBoth reg slot) : rest)
  777                 | any (realRegsAlias reg) clobbered
  778                 = clobber (addToUFM_Directly assig temp (InMem slot)) rest
  779 
  780         clobber assig (_:rest)
  781                 = clobber assig rest
  782 
  783 -- -----------------------------------------------------------------------------
  784 -- allocateRegsAndSpill
  785 
  786 -- Why are we performing a spill?
  787 data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
  788               | WriteNew           -- writing to a new variable
  789               | WriteMem           -- writing to register only in memory
  790 -- Note that ReadNew is not valid, since you don't want to be reading
  791 -- from an uninitialized register.  We also don't need the location of
  792 -- the register in memory, since that will be invalidated by the write.
  793 -- Technically, we could coalesce WriteNew and WriteMem into a single
  794 -- entry as well. -- EZY
  795 
  796 -- This function does several things:
  797 --   For each temporary referred to by this instruction,
  798 --   we allocate a real register (spilling another temporary if necessary).
  799 --   We load the temporary up from memory if necessary.
  800 --   We also update the register assignment in the process, and
  801 --   the list of free registers and free stack slots.
  802 
  803 allocateRegsAndSpill
  804         :: forall freeRegs instr. (FR freeRegs, Instruction instr)
  805         => Bool                 -- True <=> reading (load up spilled regs)
  806         -> [VirtualReg]         -- don't push these out
  807         -> [instr]              -- spill insns
  808         -> [RealReg]            -- real registers allocated (accum.)
  809         -> [VirtualReg]         -- temps to allocate
  810         -> RegM freeRegs ( [instr] , [RealReg])
  811 
  812 allocateRegsAndSpill _       _    spills alloc []
  813         = return (spills, reverse alloc)
  814 
  815 allocateRegsAndSpill reading keep spills alloc (r:rs)
  816  = do   assig <- toVRegMap <$> getAssigR
  817         -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
  818         -- See Note [UniqFM and the register allocator]
  819         let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
  820         case lookupUFM assig r of
  821                 -- case (1a): already in a register
  822                 Just (InReg my_reg) ->
  823                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
  824 
  825                 -- case (1b): already in a register (and memory)
  826                 -- NB1. if we're writing this register, update its assignment to be
  827                 -- InReg, because the memory value is no longer valid.
  828                 -- NB2. This is why we must process written registers here, even if they
  829                 -- are also read by the same instruction.
  830                 Just (InBoth my_reg _)
  831                  -> do  when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg)))
  832                         allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
  833 
  834                 -- Not already in a register, so we need to find a free one...
  835                 Just (InMem slot) | reading   -> doSpill (ReadMem slot)
  836                                   | otherwise -> doSpill WriteMem
  837                 Nothing | reading   ->
  838                    pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
  839                    -- NOTE: if the input to the NCG contains some
  840                    -- unreachable blocks with junk code, this panic
  841                    -- might be triggered.  Make sure you only feed
  842                    -- sensible code into the NCG.  In GHC.Cmm.Pipeline we
  843                    -- call removeUnreachableBlocks at the end for this
  844                    -- reason.
  845 
  846                         | otherwise -> doSpill WriteNew
  847 
  848 -- | Given a virtual reg find a preferred real register.
  849 -- The preferred register is simply the first one the variable
  850 -- was assigned to (if any). This way when we allocate for a loop
  851 -- variables are likely to end up in the same registers at the
  852 -- end and start of the loop, avoiding redundant reg-reg moves.
  853 -- Note: I tried returning a list of past assignments, but that
  854 -- turned out to barely matter.
  855 findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
  856 findPrefRealReg vreg = do
  857   bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
  858   return $ lookupFirstUsed vreg bassig
  859 
  860 -- reading is redundant with reason, but we keep it around because it's
  861 -- convenient and it maintains the recursive structure of the allocator. -- EZY
  862 allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
  863                         => Bool
  864                         -> [VirtualReg]
  865                         -> [instr]
  866                         -> [RealReg]
  867                         -> VirtualReg
  868                         -> [VirtualReg]
  869                         -> UniqFM VirtualReg Loc
  870                         -> SpillLoc
  871                         -> RegM freeRegs ([instr], [RealReg])
  872 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
  873  = do   platform <- getPlatform
  874         freeRegs <- getFreeRegsR
  875         let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]
  876 
  877         -- Can we put the variable into a register it already was?
  878         pref_reg <- findPrefRealReg r
  879 
  880         case freeRegs_thisClass of
  881          -- case (2): we have a free register
  882          (first_free : _) ->
  883            do   let !final_reg
  884                         | Just reg <- pref_reg
  885                         , reg `elem` freeRegs_thisClass
  886                         = reg
  887                         | otherwise
  888                         = first_free
  889                 spills'   <- loadTemp r spill_loc final_reg spills
  890 
  891                 setAssigR $ toRegMap
  892                           $ (addToUFM assig r $! newLocation spill_loc final_reg)
  893                 setFreeRegsR $  frAllocateReg platform final_reg freeRegs
  894 
  895                 allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
  896 
  897 
  898           -- case (3): we need to push something out to free up a register
  899          [] ->
  900            do   let inRegOrBoth (InReg _) = True
  901                     inRegOrBoth (InBoth _ _) = True
  902                     inRegOrBoth _ = False
  903                 let candidates' :: UniqFM VirtualReg Loc
  904                     candidates' =
  905                       flip delListFromUFM keep $
  906                       filterUFM inRegOrBoth $
  907                       assig
  908                       -- This is non-deterministic but we do not
  909                       -- currently support deterministic code-generation.
  910                       -- See Note [Unique Determinism and code generation]
  911                 let candidates = nonDetUFMToList candidates'
  912 
  913                 -- the vregs we could kick out that are already in a slot
  914                 let candidates_inBoth :: [(Unique, RealReg, StackSlot)]
  915                     candidates_inBoth
  916                         = [ (temp, reg, mem)
  917                           | (temp, InBoth reg mem) <- candidates
  918                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
  919 
  920                 -- the vregs we could kick out that are only in a reg
  921                 --      this would require writing the reg to a new slot before using it.
  922                 let candidates_inReg
  923                         = [ (temp, reg)
  924                           | (temp, InReg reg) <- candidates
  925                           , targetClassOfRealReg platform reg == classOfVirtualReg r ]
  926 
  927                 let result
  928 
  929                         -- we have a temporary that is in both register and mem,
  930                         -- just free up its register for use.
  931                         | (temp, my_reg, slot) : _      <- candidates_inBoth
  932                         = do    spills' <- loadTemp r spill_loc my_reg spills
  933                                 let assig1  = addToUFM_Directly assig temp (InMem slot)
  934                                 let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg
  935 
  936                                 setAssigR $ toRegMap assig2
  937                                 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
  938 
  939                         -- otherwise, we need to spill a temporary that currently
  940                         -- resides in a register.
  941                         | (temp_to_push_out, (my_reg :: RealReg)) : _
  942                                         <- candidates_inReg
  943                         = do
  944                                 (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out
  945 
  946                                 -- record that this temp was spilled
  947                                 recordSpill (SpillAlloc temp_to_push_out)
  948 
  949                                 -- update the register assignment
  950                                 let assig1  = addToUFM_Directly assig temp_to_push_out   (InMem slot)
  951                                 let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
  952                                 setAssigR $ toRegMap assig2
  953 
  954                                 -- if need be, load up a spilled temp into the reg we've just freed up.
  955                                 spills' <- loadTemp r spill_loc my_reg spills
  956 
  957                                 allocateRegsAndSpill reading keep
  958                                         (spill_store ++ spills')
  959                                         (my_reg:alloc) rs
  960 
  961 
  962                         -- there wasn't anything to spill, so we're screwed.
  963                         | otherwise
  964                         = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
  965                         $ vcat
  966                                 [ text "allocating vreg:  " <> text (show r)
  967                                 , text "assignment:       " <> ppr assig
  968                                 , text "freeRegs:         " <> text (show freeRegs)
  969                                 , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
  970 
  971                 result
  972 
  973 
  974 -- | Calculate a new location after a register has been loaded.
  975 newLocation :: SpillLoc -> RealReg -> Loc
  976 -- if the tmp was read from a slot, then now its in a reg as well
  977 newLocation (ReadMem slot) my_reg = InBoth my_reg slot
  978 -- writes will always result in only the register being available
  979 newLocation _ my_reg = InReg my_reg
  980 
  981 -- | Load up a spilled temporary if we need to (read from memory).
  982 loadTemp
  983         :: (Instruction instr)
  984         => VirtualReg   -- the temp being loaded
  985         -> SpillLoc     -- the current location of this temp
  986         -> RealReg      -- the hreg to load the temp into
  987         -> [instr]
  988         -> RegM freeRegs [instr]
  989 
  990 loadTemp vreg (ReadMem slot) hreg spills
  991  = do
  992         insn <- loadR (RegReal hreg) slot
  993         recordSpill (SpillLoad $ getUnique vreg)
  994         return  $  {- mkComment (text "spill load") : -} insn ++ spills
  995 
  996 loadTemp _ _ _ spills =
  997    return spills