    {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
    {-# LANGUAGE ConstraintKinds #-}

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

    -----------------------------------------------------------------------------
    --
    -- The register allocator
    --
    -- (c) The University of Glasgow 2004
    --
    -----------------------------------------------------------------------------

    {-
    The algorithm is roughly:

      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
            (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.

         For each instruction:
            (a) For each temporary *read* by the instruction:
                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
                be used soon, then don't use it for allocation).

            (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

            (c) Update the current assignment

            (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.

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

            (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).

            (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.

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

            (i) Rewrite the instruction with the new mapping.

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

    -}

    module GHC.CmmToAsm.Reg.Linear (
            regAlloc,
            module  GHC.CmmToAsm.Reg.Linear.Base,
            module  GHC.CmmToAsm.Reg.Linear.Stats
      ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.CmmToAsm.Reg.Linear.State
    import GHC.CmmToAsm.Reg.Linear.Base
    import GHC.CmmToAsm.Reg.Linear.StackMap
    import GHC.CmmToAsm.Reg.Linear.FreeRegs
    import GHC.CmmToAsm.Reg.Linear.Stats
    import GHC.CmmToAsm.Reg.Linear.JoinToTargets
    import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC
    import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC
    import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86
    import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64
    import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
    import GHC.CmmToAsm.Reg.Target
    import GHC.CmmToAsm.Reg.Liveness
    import GHC.CmmToAsm.Reg.Utils
    import GHC.CmmToAsm.Instr
    import GHC.CmmToAsm.Config
    import GHC.CmmToAsm.Types
    import GHC.Platform.Reg
    import GHC.Platform.Reg.Class (RegClass(..))

    import GHC.Cmm.BlockId
    import GHC.Cmm.Dataflow.Collections
    import GHC.Cmm hiding (RegSet)

    import GHC.Data.Graph.Directed
    import GHC.Types.Unique
    import GHC.Types.Unique.Set
    import GHC.Types.Unique.FM
    import GHC.Types.Unique.Supply
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Platform

    import Data.Maybe
    import Data.List (partition, nub)
    import Control.Monad
    import Control.Applicative

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

    -- Allocate registers
    regAlloc
            :: Instruction instr
            => NCGConfig
            -> LiveCmmDecl statics instr
            -> UniqSM ( NatCmmDecl statics instr
                      , Maybe Int  -- number of extra stack slots required,
                                   -- beyond maxSpillSlots
                      , Maybe RegAllocStats
                      )

    regAlloc :: forall instr statics.
    Instruction instr =>
    NCGConfig
    -> LiveCmmDecl statics instr
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    regAlloc NCGConfig
    _ (CmmData Section
    sec statics
    d)
            = (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                    ( Section -> statics -> NatCmmDecl statics instr
    forall d h g. Section -> d -> GenCmmDecl d h g
    CmmData Section
    sec statics
    d
                    , Maybe Int
    forall a. Maybe a
    Nothing
                    , Maybe RegAllocStats
    forall a. Maybe a
    Nothing )

    regAlloc NCGConfig
    _ (CmmProc (LiveInfo LabelMap RawCmmStatics
    info [BlockId]
    _ BlockMap RegSet
    _ BlockMap IntSet
    _) CLabel
    lbl [GlobalReg]
    live [])
            = (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( LabelMap RawCmmStatics
    -> CLabel
    -> [GlobalReg]
    -> ListGraph instr
    -> NatCmmDecl statics instr
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live ([GenBasicBlock instr] -> ListGraph instr
    forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph [])
                     , Maybe Int
    forall a. Maybe a
    Nothing
                     , Maybe RegAllocStats
    forall a. Maybe a
    Nothing )

    regAlloc NCGConfig
    config (CmmProc LiveInfo
    static CLabel
    lbl [GlobalReg]
    live [SCC (LiveBasicBlock instr)]
    sccs)
            | LiveInfo LabelMap RawCmmStatics
    info entry_ids :: [BlockId]
    entry_ids@(BlockId
    first_id:[BlockId]
    _) BlockMap RegSet
    block_live BlockMap IntSet
    _ <- LiveInfo
    static
            = do
                    -- do register allocation on each component.
                    !(![GenBasicBlock instr]
    final_blocks, !RegAllocStats
    stats, !Int
    stack_use)
                            <- NCGConfig
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([GenBasicBlock instr], RegAllocStats, Int)
    forall instr.
    Instruction instr =>
    NCGConfig
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    linearRegAlloc NCGConfig
    config [BlockId]
    entry_ids BlockMap RegSet
    block_live [SCC (LiveBasicBlock instr)]
    sccs

                    -- make sure the block that was first in the input list
                    --      stays at the front of the output
                    let !(!(!GenBasicBlock instr
    first':[GenBasicBlock instr]
    _), ![GenBasicBlock instr]
    rest')
                                    = (GenBasicBlock instr -> Bool)
    -> [GenBasicBlock instr]
    -> ([GenBasicBlock instr], [GenBasicBlock instr])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    partition ((BlockId -> BlockId -> Bool
    forall a. Eq a => a -> a -> Bool
    == BlockId
    first_id) (BlockId -> Bool)
    -> (GenBasicBlock instr -> BlockId) -> GenBasicBlock instr -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GenBasicBlock instr -> BlockId
    forall i. GenBasicBlock i -> BlockId
    blockId) [GenBasicBlock instr]
    final_blocks

                    let max_spill_slots :: Int
    max_spill_slots = NCGConfig -> Int
    maxSpillSlots NCGConfig
    config
                        extra_stack :: Maybe Int
    extra_stack
                          | Int
    stack_use Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    max_spill_slots
                          = Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Int -> Maybe Int) -> Int -> Maybe Int
    forall a b. (a -> b) -> a -> b
    $! Int
    stack_use Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    max_spill_slots
                          | Bool
    otherwise
                          = Maybe Int
    forall a. Maybe a
    Nothing

                    (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    forall (m :: * -> *) a. Monad m => a -> m a
    return  ( LabelMap RawCmmStatics
    -> CLabel
    -> [GlobalReg]
    -> ListGraph instr
    -> NatCmmDecl statics instr
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live ([GenBasicBlock instr] -> ListGraph instr
    forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph (GenBasicBlock instr
    first' GenBasicBlock instr
    -> [GenBasicBlock instr] -> [GenBasicBlock instr]
    forall a. a -> [a] -> [a]
    : [GenBasicBlock instr]
    rest'))
                            , Maybe Int
    extra_stack
                            , RegAllocStats -> Maybe RegAllocStats
    forall a. a -> Maybe a
    Just RegAllocStats
    stats)

    -- bogus. to make non-exhaustive match warning go away.
    regAlloc NCGConfig
    _ (CmmProc LiveInfo
    _ CLabel
    _ [GlobalReg]
    _ [SCC (LiveBasicBlock instr)]
    _)
            = String
    -> UniqSM
         (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)
    forall a. String -> a
    panic String
    "RegAllocLinear.regAlloc: no match"

    -- -----------------------------------------------------------------------------
    -- Linear sweep to allocate registers

    -- | Do register allocation on some basic blocks.
    --   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.
    --
    linearRegAlloc
            :: forall instr. (Instruction instr)
            => NCGConfig
            -> [BlockId] -- ^ entry points
            -> BlockMap RegSet
                  -- ^ live regs on entry to each basic block
            -> [SCC (LiveBasicBlock instr)]
                  -- ^ instructions annotated with "deaths"
            -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)

    linearRegAlloc :: forall instr.
    Instruction instr =>
    NCGConfig
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    linearRegAlloc NCGConfig
    config [BlockId]
    entry_ids BlockMap RegSet
    block_live [SCC (LiveBasicBlock instr)]
    sccs
     = case Platform -> Arch
    platformArch Platform
    platform of
          Arch
    ArchX86        -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: X86.FreeRegs)
          Arch
    ArchX86_64     -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: X86_64.FreeRegs)
          Arch
    ArchS390X      -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchS390X"
          Arch
    ArchSPARC      -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: SPARC.FreeRegs)
          Arch
    ArchSPARC64    -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchSPARC64"
          Arch
    ArchPPC        -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: PPC.FreeRegs)
          ArchARM ArmISA
    _ [ArmISAExt]
    _ ArmABI
    _  -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchARM"
          Arch
    ArchAArch64    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: AArch64.FreeRegs)
          ArchPPC_64 PPC_64ABI
    _   -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go (FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int))
    -> FreeRegs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a b. (a -> b) -> a -> b
    $ (Platform -> FreeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform :: PPC.FreeRegs)
          Arch
    ArchAlpha      -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchAlpha"
          Arch
    ArchMipseb     -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchMipseb"
          Arch
    ArchMipsel     -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchMipsel"
          Arch
    ArchRISCV64    -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchRISCV64"
          Arch
    ArchJavaScript -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchJavaScript"
          Arch
    ArchUnknown    -> String -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall a. String -> a
    panic String
    "linearRegAlloc ArchUnknown"
     where
      go :: (FR regs, Outputable regs)
         => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
      go :: forall regs.
    (FR regs, Outputable regs) =>
    regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    go regs
    f = NCGConfig
    -> regs
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    NCGConfig
    -> freeRegs
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    linearRegAlloc' NCGConfig
    config regs
    f [BlockId]
    entry_ids BlockMap RegSet
    block_live [SCC (LiveBasicBlock instr)]
    sccs
      platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config

    -- | Constraints on the instruction instances used by the
    -- linear allocator.
    type OutputableRegConstraint freeRegs instr =
            (FR freeRegs, Outputable freeRegs, Instruction instr)

    linearRegAlloc'
            :: OutputableRegConstraint freeRegs instr
            => NCGConfig
            -> freeRegs
            -> [BlockId]                    -- ^ entry points
            -> BlockMap RegSet              -- ^ live regs on entry to each basic block
            -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
            -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)

    linearRegAlloc' :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    NCGConfig
    -> freeRegs
    -> [BlockId]
    -> BlockMap RegSet
    -> [SCC (LiveBasicBlock instr)]
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    linearRegAlloc' NCGConfig
    config freeRegs
    initFreeRegs [BlockId]
    entry_ids BlockMap RegSet
    block_live [SCC (LiveBasicBlock instr)]
    sccs
     = do   UniqSupply
    us      <- UniqSM UniqSupply
    forall (m :: * -> *). MonadUnique m => m UniqSupply
    getUniqueSupplyM
            let !(BlockAssignment freeRegs
    _, !StackMap
    stack, !RegAllocStats
    stats, ![NatBasicBlock instr]
    blocks) =
                    NCGConfig
    -> BlockAssignment freeRegs
    -> freeRegs
    -> RegMap Loc
    -> StackMap
    -> UniqSupply
    -> RegM freeRegs [NatBasicBlock instr]
    -> (BlockAssignment freeRegs, StackMap, RegAllocStats,
        [NatBasicBlock instr])
    forall freeRegs a.
    NCGConfig
    -> BlockAssignment freeRegs
    -> freeRegs
    -> RegMap Loc
    -> StackMap
    -> UniqSupply
    -> RegM freeRegs a
    -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
    runR NCGConfig
    config BlockAssignment freeRegs
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty freeRegs
    initFreeRegs RegMap Loc
    forall a. RegMap a
    emptyRegMap StackMap
    emptyStackMap UniqSupply
    us
                        (RegM freeRegs [NatBasicBlock instr]
     -> (BlockAssignment freeRegs, StackMap, RegAllocStats,
         [NatBasicBlock instr]))
    -> RegM freeRegs [NatBasicBlock instr]
    -> (BlockAssignment freeRegs, StackMap, RegAllocStats,
        [NatBasicBlock instr])
    forall a b. (a -> b) -> a -> b
    $ [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    linearRA_SCCs [BlockId]
    entry_ids BlockMap RegSet
    block_live [] [SCC (LiveBasicBlock instr)]
    sccs
            ([NatBasicBlock instr], RegAllocStats, Int)
    -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return  ([NatBasicBlock instr]
    blocks, RegAllocStats
    stats, StackMap -> Int
    getStackUse StackMap
    stack)

    linearRA_SCCs :: OutputableRegConstraint freeRegs instr
                  => [BlockId]
                  -> BlockMap RegSet
                  -> [NatBasicBlock instr]
                  -> [SCC (LiveBasicBlock instr)]
                  -> RegM freeRegs [NatBasicBlock instr]

    linearRA_SCCs :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    linearRA_SCCs [BlockId]
    _ BlockMap RegSet
    _ [NatBasicBlock instr]
    blocksAcc []
            = [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr])
    -> [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
    forall a b. (a -> b) -> a -> b
    $ [NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a]
    reverse [NatBasicBlock instr]
    blocksAcc

    linearRA_SCCs [BlockId]
    entry_ids BlockMap RegSet
    block_live [NatBasicBlock instr]
    blocksAcc (AcyclicSCC LiveBasicBlock instr
    block : [SCC (LiveBasicBlock instr)]
    sccs)
     = do   [NatBasicBlock instr]
    blocks' <- BlockMap RegSet
    -> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
    processBlock BlockMap RegSet
    block_live LiveBasicBlock instr
    block
            [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    linearRA_SCCs [BlockId]
    entry_ids BlockMap RegSet
    block_live
                    (([NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a]
    reverse [NatBasicBlock instr]
    blocks') [NatBasicBlock instr]
    -> [NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a] -> [a]
    ++ [NatBasicBlock instr]
    blocksAcc)
                    [SCC (LiveBasicBlock instr)]
    sccs

    linearRA_SCCs [BlockId]
    entry_ids BlockMap RegSet
    block_live [NatBasicBlock instr]
    blocksAcc (CyclicSCC [LiveBasicBlock instr]
    blocks : [SCC (LiveBasicBlock instr)]
    sccs)
     = do
            [[NatBasicBlock instr]]
    blockss' <- [BlockId]
    -> BlockMap RegSet
    -> [LiveBasicBlock instr]
    -> RegM freeRegs [[NatBasicBlock instr]]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [GenBasicBlock (LiveInstr instr)]
    -> RegM freeRegs [[NatBasicBlock instr]]
    process [BlockId]
    entry_ids BlockMap RegSet
    block_live [LiveBasicBlock instr]
    blocks
            [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [NatBasicBlock instr]
    -> [SCC (LiveBasicBlock instr)]
    -> RegM freeRegs [NatBasicBlock instr]
    linearRA_SCCs [BlockId]
    entry_ids BlockMap RegSet
    block_live
                    ([NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a]
    reverse ([[NatBasicBlock instr]] -> [NatBasicBlock instr]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[NatBasicBlock instr]]
    blockss') [NatBasicBlock instr]
    -> [NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a] -> [a]
    ++ [NatBasicBlock instr]
    blocksAcc)
                    [SCC (LiveBasicBlock instr)]
    sccs

    {- from John Dias's patch 2008/10/16:
       The linear-scan allocator sometimes allocates a block
       before allocating one of its predecessors, which could lead to
       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
       some reason then this function will loop. We should probably do some
       more sanity checking to guard against this eventuality.
    -}

    process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
            => [BlockId]
            -> BlockMap RegSet
            -> [GenBasicBlock (LiveInstr instr)]
            -> RegM freeRegs [[NatBasicBlock instr]]
    process :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    [BlockId]
    -> BlockMap RegSet
    -> [GenBasicBlock (LiveInstr instr)]
    -> RegM freeRegs [[NatBasicBlock instr]]
    process [BlockId]
    entry_ids BlockMap RegSet
    block_live =
        \[GenBasicBlock (LiveInstr instr)]
    blocks -> [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    -> [[NatBasicBlock instr]]
    -> Bool
    -> RegM freeRegs [[NatBasicBlock instr]]
    go [GenBasicBlock (LiveInstr instr)]
    blocks [] ([NatBasicBlock instr] -> [[NatBasicBlock instr]]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []) Bool
    False
      where
        go :: [GenBasicBlock (LiveInstr instr)]
           -> [GenBasicBlock (LiveInstr instr)]
           -> [[NatBasicBlock instr]]
           -> Bool
           -> RegM freeRegs [[NatBasicBlock instr]]
        go :: [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    -> [[NatBasicBlock instr]]
    -> Bool
    -> RegM freeRegs [[NatBasicBlock instr]]
    go [] []         [[NatBasicBlock instr]]
    accum Bool
    _madeProgress
          = [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]])
    -> [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
    forall a b. (a -> b) -> a -> b
    $ [[NatBasicBlock instr]] -> [[NatBasicBlock instr]]
    forall a. [a] -> [a]
    reverse [[NatBasicBlock instr]]
    accum

        go [] [GenBasicBlock (LiveInstr instr)]
    next_round [[NatBasicBlock instr]]
    accum Bool
    madeProgress
          | Bool -> Bool
    not Bool
    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)) -}
          = [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]])
    -> [[NatBasicBlock instr]] -> RegM freeRegs [[NatBasicBlock instr]]
    forall a b. (a -> b) -> a -> b
    $ [[NatBasicBlock instr]] -> [[NatBasicBlock instr]]
    forall a. [a] -> [a]
    reverse [[NatBasicBlock instr]]
    accum

          | Bool
    otherwise
          = [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    -> [[NatBasicBlock instr]]
    -> Bool
    -> RegM freeRegs [[NatBasicBlock instr]]
    go [GenBasicBlock (LiveInstr instr)]
    next_round [] [[NatBasicBlock instr]]
    accum Bool
    False

        go (b :: GenBasicBlock (LiveInstr instr)
    b@(BasicBlock BlockId
    id [LiveInstr instr]
    _) : [GenBasicBlock (LiveInstr instr)]
    blocks) [GenBasicBlock (LiveInstr instr)]
    next_round [[NatBasicBlock instr]]
    accum Bool
    madeProgress
          = do
              BlockAssignment freeRegs
    block_assig <- RegM freeRegs (BlockAssignment freeRegs)
    forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
    getBlockAssigR
              if Maybe (freeRegs, RegMap Loc) -> Bool
    forall a. Maybe a -> Bool
    isJust (KeyOf LabelMap
    -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id BlockAssignment freeRegs
    block_assig) Bool -> Bool -> Bool
    || BlockId
    id BlockId -> [BlockId] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [BlockId]
    entry_ids
                then do [NatBasicBlock instr]
    b' <- BlockMap RegSet
    -> GenBasicBlock (LiveInstr instr)
    -> RegM freeRegs [NatBasicBlock instr]
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
    processBlock BlockMap RegSet
    block_live GenBasicBlock (LiveInstr instr)
    b
                        [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    -> [[NatBasicBlock instr]]
    -> Bool
    -> RegM freeRegs [[NatBasicBlock instr]]
    go [GenBasicBlock (LiveInstr instr)]
    blocks [GenBasicBlock (LiveInstr instr)]
    next_round ([NatBasicBlock instr]
    b' [NatBasicBlock instr]
    -> [[NatBasicBlock instr]] -> [[NatBasicBlock instr]]
    forall a. a -> [a] -> [a]
    : [[NatBasicBlock instr]]
    accum) Bool
    True

                else do [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    -> [[NatBasicBlock instr]]
    -> Bool
    -> RegM freeRegs [[NatBasicBlock instr]]
    go [GenBasicBlock (LiveInstr instr)]
    blocks (GenBasicBlock (LiveInstr instr)
    b GenBasicBlock (LiveInstr instr)
    -> [GenBasicBlock (LiveInstr instr)]
    -> [GenBasicBlock (LiveInstr instr)]
    forall a. a -> [a] -> [a]
    : [GenBasicBlock (LiveInstr instr)]
    next_round) [[NatBasicBlock instr]]
    accum Bool
    madeProgress

    -- | Do register allocation on this basic block
    --
    processBlock
            :: OutputableRegConstraint freeRegs instr
            => BlockMap RegSet              -- ^ live regs on entry to each basic block
            -> LiveBasicBlock instr         -- ^ block to do register allocation on
            -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated

    processBlock :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> LiveBasicBlock instr -> RegM freeRegs [NatBasicBlock instr]
    processBlock BlockMap RegSet
    block_live (BasicBlock BlockId
    id [LiveInstr instr]
    instrs)
     = do   -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs)
            BlockId -> BlockMap RegSet -> RegM freeRegs ()
    forall freeRegs.
    FR freeRegs =>
    BlockId -> BlockMap RegSet -> RegM freeRegs ()
    initBlock BlockId
    id BlockMap RegSet
    block_live

            ([instr]
    instrs', [NatBasicBlock instr]
    fixups)
                    <- BlockMap RegSet
    -> BlockId
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> BlockId
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    linearRA BlockMap RegSet
    block_live BlockId
    id [LiveInstr instr]
    instrs
            -- pprTraceM "blockResult" $ ppr (instrs', fixups)
            [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return  ([NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr])
    -> [NatBasicBlock instr] -> RegM freeRegs [NatBasicBlock instr]
    forall a b. (a -> b) -> a -> b
    $ BlockId -> [instr] -> NatBasicBlock instr
    forall i. BlockId -> [i] -> GenBasicBlock i
    BasicBlock BlockId
    id [instr]
    instrs' NatBasicBlock instr
    -> [NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. a -> [a] -> [a]
    : [NatBasicBlock instr]
    fixups

    -- | Load the freeregs and current reg assignment into the RegM state
    --      for the basic block with this BlockId.
    initBlock :: FR freeRegs
              => BlockId -> BlockMap RegSet -> RegM freeRegs ()
    initBlock :: forall freeRegs.
    FR freeRegs =>
    BlockId -> BlockMap RegSet -> RegM freeRegs ()
    initBlock BlockId
    id BlockMap RegSet
    block_live
     = do   Platform
    platform    <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
            BlockAssignment freeRegs
    block_assig <- RegM freeRegs (BlockAssignment freeRegs)
    forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
    getBlockAssigR
            case KeyOf LabelMap
    -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id BlockAssignment freeRegs
    block_assig of
                    -- 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.
                    Maybe (freeRegs, RegMap Loc)
    Nothing
                     -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
                            case KeyOf LabelMap -> BlockMap RegSet -> Maybe RegSet
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    id BlockMap RegSet
    block_live of
                              Maybe RegSet
    Nothing ->
                                freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR    (Platform -> freeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform)
                              Just RegSet
    live ->
                                freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR (freeRegs -> RegM freeRegs ()) -> freeRegs -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $ (freeRegs -> RealReg -> freeRegs)
    -> freeRegs -> [RealReg] -> freeRegs
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ((RealReg -> freeRegs -> freeRegs)
    -> freeRegs -> RealReg -> freeRegs
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((RealReg -> freeRegs -> freeRegs)
     -> freeRegs -> RealReg -> freeRegs)
    -> (RealReg -> freeRegs -> freeRegs)
    -> freeRegs
    -> RealReg
    -> freeRegs
    forall a b. (a -> b) -> a -> b
    $ Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frAllocateReg Platform
    platform) (Platform -> freeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform)
                                                      [ RealReg
    r | RegReal RealReg
    r <- RegSet -> [Reg]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet RegSet
    live ]
                                -- See Note [Unique Determinism and code generation]
                            RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR       RegMap Loc
    forall a. RegMap a
    emptyRegMap

                    -- load info about register assignments leading into this block.
                    Just (freeRegs
    freeregs, RegMap Loc
    assig)
                     -> do  freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR    freeRegs
    freeregs
                            RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR       RegMap Loc
    assig

    -- | Do allocation for a sequence of instructions.
    linearRA
            :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
            => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
            -> BlockId                              -- ^ id of the current block, for debugging.
            -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
            -> RegM freeRegs
                    ( [instr]                       --   instructions after register allocation
                    , [NatBasicBlock instr])        --   fresh blocks of fixup code.
    linearRA :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> BlockId
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    linearRA BlockMap RegSet
    block_live BlockId
    block_id = [instr]
    -> [NatBasicBlock instr]
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    go [] []
      where
        go :: [instr]                              -- ^ accumulator for instructions already processed.
           -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
           -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
           -> RegM freeRegs
                   ( [instr]                       --   instructions after register allocation
                   , [NatBasicBlock instr] )       --   fresh blocks of fixup code.
        go :: [instr]
    -> [NatBasicBlock instr]
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    go ![instr]
    accInstr ![NatBasicBlock instr]
    accFixups [] = do
            ([instr], [NatBasicBlock instr])
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( [instr] -> [instr]
    forall a. [a] -> [a]
    reverse [instr]
    accInstr               -- instrs need to be returned in the correct order.
                   , [NatBasicBlock instr]
    accFixups )                    -- it doesn't matter what order the fixup blocks are returned in.

        go [instr]
    accInstr [NatBasicBlock instr]
    accFixups (LiveInstr instr
    instr:[LiveInstr instr]
    instrs) = do
            ([instr]
    accInstr', [NatBasicBlock instr]
    new_fixups) <- BlockMap RegSet
    -> [instr]
    -> BlockId
    -> LiveInstr instr
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> [instr]
    -> BlockId
    -> LiveInstr instr
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    raInsn BlockMap RegSet
    block_live [instr]
    accInstr BlockId
    block_id LiveInstr instr
    instr
            [instr]
    -> [NatBasicBlock instr]
    -> [LiveInstr instr]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    go [instr]
    accInstr' ([NatBasicBlock instr]
    new_fixups [NatBasicBlock instr]
    -> [NatBasicBlock instr] -> [NatBasicBlock instr]
    forall a. [a] -> [a] -> [a]
    ++ [NatBasicBlock instr]
    accFixups) [LiveInstr instr]
    instrs

    -- | Do allocation for a single instruction.
    raInsn
            :: OutputableRegConstraint freeRegs instr
            => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
            -> [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.
            -> RegM freeRegs
                    ( [instr]                       -- new instructions
                    , [NatBasicBlock instr])        -- extra fixup blocks

    raInsn :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> [instr]
    -> BlockId
    -> LiveInstr instr
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    raInsn BlockMap RegSet
    _     [instr]
    new_instrs BlockId
    _ (LiveInstr InstrSR instr
    ii Maybe Liveness
    Nothing)
            | Just Int
    n        <- InstrSR instr -> Maybe Int
    forall instr. Instruction instr => instr -> Maybe Int
    takeDeltaInstr InstrSR instr
    ii
            = do    Int -> RegM freeRegs ()
    forall freeRegs. Int -> RegM freeRegs ()
    setDeltaR Int
    n
                    ([instr], [NatBasicBlock instr])
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr]
    new_instrs, [])

    raInsn BlockMap RegSet
    _     [instr]
    new_instrs BlockId
    _ (LiveInstr ii :: InstrSR instr
    ii@(Instr instr
    i) Maybe Liveness
    Nothing)
            | InstrSR instr -> Bool
    forall instr. Instruction instr => instr -> Bool
    isMetaInstr InstrSR instr
    ii
            = ([instr], [NatBasicBlock instr])
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (instr
    i instr -> [instr] -> [instr]
    forall a. a -> [a] -> [a]
    : [instr]
    new_instrs, [])

    raInsn BlockMap RegSet
    block_live [instr]
    new_instrs BlockId
    id (LiveInstr (Instr instr
    instr) (Just Liveness
    live))
     = do
        RegMap Loc
    assig    <- forall freeRegs. RegM freeRegs (RegMap Loc)
    getAssigR :: RegM freeRegs (UniqFM Reg Loc)

        -- If we have a reg->reg move between virtual registers, where the
        -- src register is not live after this instruction, and the dst
        -- 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.
        -- (we can't eliminate it if the source register is on the stack, because
        --  we do not want to use one spill slot for different virtual registers)
        case instr -> Maybe (Reg, Reg)
    forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
    takeRegRegMoveInstr instr
    instr of
            Just (Reg
    src,Reg
    dst)  | Reg
    src Reg -> RegSet -> Bool
    forall a. Uniquable a => a -> UniqSet a -> Bool
    `elementOfUniqSet` (Liveness -> RegSet
    liveDieRead Liveness
    live),
                              Reg -> Bool
    isVirtualReg Reg
    dst,
                              Bool -> Bool
    not (Reg
    dst Reg -> RegMap Loc -> Bool
    forall key elt. Uniquable key => key -> UniqFM key elt -> Bool
    `elemUFM` RegMap Loc
    assig),
                              Reg -> Bool
    isRealReg Reg
    src Bool -> Bool -> Bool
    || Reg -> RegMap Loc -> Bool
    isInReg Reg
    src RegMap Loc
    assig -> do
               case Reg
    src of
                  (RegReal RealReg
    rr) -> RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> Reg -> Loc -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM RegMap Loc
    assig Reg
    dst (RealReg -> Loc
    InReg RealReg
    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.
                  Reg
    _virt -> case RegMap Loc -> Reg -> Maybe Loc
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM RegMap Loc
    assig Reg
    src of
                             Maybe Loc
    Nothing -> String -> RegM freeRegs ()
    forall a. String -> a
    panic String
    "raInsn"
                             Just Loc
    loc ->
                               RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> Reg -> Loc -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM (RegMap Loc -> Reg -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> UniqFM key elt
    delFromUFM RegMap Loc
    assig Reg
    src) Reg
    dst Loc
    loc)

               -- we have eliminated this instruction
              {-
              freeregs <- getFreeRegsR
              assig <- getAssigR
              pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
                            $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
              -}
               ([instr], [NatBasicBlock instr])
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr]
    new_instrs, [])

            Maybe (Reg, Reg)
    _ -> BlockMap RegSet
    -> [instr]
    -> BlockId
    -> instr
    -> [Reg]
    -> [Reg]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> [instr]
    -> BlockId
    -> instr
    -> [Reg]
    -> [Reg]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    genRaInsn BlockMap RegSet
    block_live [instr]
    new_instrs BlockId
    id instr
    instr
                            (RegSet -> [Reg]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet (RegSet -> [Reg]) -> RegSet -> [Reg]
    forall a b. (a -> b) -> a -> b
    $ Liveness -> RegSet
    liveDieRead Liveness
    live)
                            (RegSet -> [Reg]
    forall elt. UniqSet elt -> [elt]
    nonDetEltsUniqSet (RegSet -> [Reg]) -> RegSet -> [Reg]
    forall a b. (a -> b) -> a -> b
    $ Liveness -> RegSet
    liveDieWrite Liveness
    live)
                            -- See Note [Unique Determinism and code generation]

    raInsn BlockMap RegSet
    _ [instr]
    _ BlockId
    _ LiveInstr instr
    instr
            = do
                Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
                let instr' :: LiveInstr SDoc
    instr' = (instr -> SDoc) -> LiveInstr instr -> LiveInstr SDoc
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Platform -> instr -> SDoc
    forall instr. Instruction instr => Platform -> instr -> SDoc
    pprInstr Platform
    platform) LiveInstr instr
    instr
                String -> SDoc -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "raInsn" (String -> SDoc
    text String
    "no match for:" SDoc -> SDoc -> SDoc
    <> LiveInstr SDoc -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LiveInstr SDoc
    instr')

    -- 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.

    isInReg :: Reg -> RegMap Loc -> Bool
    isInReg :: Reg -> RegMap Loc -> Bool
    isInReg Reg
    src RegMap Loc
    assig | Just (InReg RealReg
    _) <- RegMap Loc -> Reg -> Maybe Loc
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM RegMap Loc
    assig Reg
    src = Bool
    True
                      | Bool
    otherwise = Bool
    False

    genRaInsn :: forall freeRegs instr.
                 (OutputableRegConstraint freeRegs instr)
              => BlockMap RegSet
              -> [instr]
              -> BlockId
              -> instr
              -> [Reg]
              -> [Reg]
              -> RegM freeRegs ([instr], [NatBasicBlock instr])

    genRaInsn :: forall freeRegs instr.
    OutputableRegConstraint freeRegs instr =>
    BlockMap RegSet
    -> [instr]
    -> BlockId
    -> instr
    -> [Reg]
    -> [Reg]
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    genRaInsn BlockMap RegSet
    block_live [instr]
    new_instrs BlockId
    block_id instr
    instr [Reg]
    r_dying [Reg]
    w_dying = do
    -- pprTraceM "genRaInsn" $ ppr (block_id, instr)
      Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
      case Platform -> instr -> RegUsage
    forall instr. Instruction instr => Platform -> instr -> RegUsage
    regUsageOfInstr Platform
    platform instr
    instr of { RU [Reg]
    read [Reg]
    written ->
        do
        let real_written :: [RealReg]
    real_written    = [ RealReg
    rr  | (RegReal     RealReg
    rr) <- [Reg]
    written ] :: [RealReg]
        let virt_written :: [VirtualReg]
    virt_written    = [ VirtualReg
    vr  | (RegVirtual  VirtualReg
    vr) <- [Reg]
    written ]

        -- 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).
        let virt_read :: [VirtualReg]
    virt_read       = [VirtualReg] -> [VirtualReg]
    forall a. Eq a => [a] -> [a]
    nub [ VirtualReg
    vr      | (RegVirtual VirtualReg
    vr) <- [Reg]
    read ] :: [VirtualReg]

    --     do
    --         let real_read       = nub [ rr      | (RegReal rr) <- read]
    --         freeregs <- getFreeRegsR
    --         assig    <- getAssigR

    --         pprTraceM "genRaInsn"
    --                 (          text "block        = " <+> ppr block_id
    --                         $$ text "instruction  = " <+> ppr instr
    --                         $$ text "r_dying      = " <+> ppr r_dying
    --                         $$ text "w_dying      = " <+> ppr w_dying
    --                         $$ text "read         = " <+> ppr real_read    <+> ppr virt_read
    --                         $$ text "written      = " <+> ppr real_written <+> ppr virt_written
    --                         $$ text "freeregs     = " <+> ppr freeregs
    --                         $$ text "assign       = " <+> ppr assig)

        -- (a), (b) allocate real regs for all regs read by this instruction.
        ([instr]
    r_spills, [RealReg]
    r_allocd) <-
            Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    True{-reading-} [VirtualReg]
    virt_read [] [] [VirtualReg]
    virt_read

        -- (c) save any temporaries which will be clobbered by this instruction
        [instr]
    clobber_saves <- [RealReg] -> [Reg] -> RegM freeRegs [instr]
    forall instr freeRegs.
    (Instruction instr, FR freeRegs) =>
    [RealReg] -> [Reg] -> RegM freeRegs [instr]
    saveClobberedTemps [RealReg]
    real_written [Reg]
    r_dying

        -- (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).
        ([NatBasicBlock instr]
    fixup_blocks, instr
    adjusted_instr)
            <- BlockMap RegSet
    -> BlockId -> instr -> RegM freeRegs ([NatBasicBlock instr], instr)
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    BlockMap RegSet
    -> BlockId -> instr -> RegM freeRegs ([NatBasicBlock instr], instr)
    joinToTargets BlockMap RegSet
    block_live BlockId
    block_id instr
    instr

    --     when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks

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

        -- (e) Delete all register assignments for temps which are read
        --     (only) and die here.  Update the free register list.
        [Reg] -> RegM freeRegs ()
    forall freeRegs. FR freeRegs => [Reg] -> RegM freeRegs ()
    releaseRegs [Reg]
    r_dying

        -- (f) Mark regs which are clobbered as unallocatable
        [RealReg] -> RegM freeRegs ()
    forall freeRegs. FR freeRegs => [RealReg] -> RegM freeRegs ()
    clobberRegs [RealReg]
    real_written

        -- (g) Allocate registers for temporaries *written* (only)
        ([instr]
    w_spills, [RealReg]
    w_allocd) <-
            Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    False{-writing-} [VirtualReg]
    virt_written [] [] [VirtualReg]
    virt_written

        -- (h) Release registers for temps which are written here and not
        -- used again.
        [Reg] -> RegM freeRegs ()
    forall freeRegs. FR freeRegs => [Reg] -> RegM freeRegs ()
    releaseRegs [Reg]
    w_dying

        let
            -- (i) Patch the instruction
            patch_map :: UniqFM Reg Reg
            patch_map :: UniqFM Reg Reg
    patch_map
                    = UniqFM VirtualReg Reg -> UniqFM Reg Reg
    forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
    toRegMap (UniqFM VirtualReg Reg -> UniqFM Reg Reg)
    -> UniqFM VirtualReg Reg -> UniqFM Reg Reg
    forall a b. (a -> b) -> a -> b
    $ -- Cast key from VirtualReg to Reg
                                 -- See Note [UniqFM and the register allocator]
                      [(VirtualReg, Reg)] -> UniqFM VirtualReg Reg
    forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
    listToUFM
                            [ (VirtualReg
    t, RealReg -> Reg
    RegReal RealReg
    r)
                                    | (VirtualReg
    t, RealReg
    r) <- [VirtualReg] -> [RealReg] -> [(VirtualReg, RealReg)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [VirtualReg]
    virt_read    [RealReg]
    r_allocd
                                             [(VirtualReg, RealReg)]
    -> [(VirtualReg, RealReg)] -> [(VirtualReg, RealReg)]
    forall a. [a] -> [a] -> [a]
    ++ [VirtualReg] -> [RealReg] -> [(VirtualReg, RealReg)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [VirtualReg]
    virt_written [RealReg]
    w_allocd ]

            patched_instr :: instr
            patched_instr :: instr
    patched_instr
                    = instr -> (Reg -> Reg) -> instr
    forall instr. Instruction instr => instr -> (Reg -> Reg) -> instr
    patchRegsOfInstr instr
    adjusted_instr Reg -> Reg
    patchLookup

            patchLookup :: Reg -> Reg
            patchLookup :: Reg -> Reg
    patchLookup Reg
    x
                    = case UniqFM Reg Reg -> Reg -> Maybe Reg
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM UniqFM Reg Reg
    patch_map Reg
    x of
                            Maybe Reg
    Nothing -> Reg
    x
                            Just Reg
    y  -> Reg
    y

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

        -- erase reg->reg moves where the source and destination are the same.
        --  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 :: [instr]
    squashed_instr  = case instr -> Maybe (Reg, Reg)
    forall instr. Instruction instr => instr -> Maybe (Reg, Reg)
    takeRegRegMoveInstr instr
    patched_instr of
                                    Just (Reg
    src, Reg
    dst)
                                     | Reg
    src Reg -> Reg -> Bool
    forall a. Eq a => a -> a -> Bool
    == Reg
    dst   -> []
                                    Maybe (Reg, Reg)
    _               -> [instr
    patched_instr]

        -- On the use of @reverse@ below.
        -- Since we can have spills and reloads produce multiple instructions
        -- we need to ensure they are emitted in the correct order.  We used to only
        -- emit single instructions in mkSpill/mkReload/mkRegRegMove.
        -- As such order of spills and reloads didn't matter.  However,  with
        -- mutliple instructions potentially issued by those functions we need to be
        -- careful to not break execution order. Reversing the spills (clobber will
        -- also spill), will ensure they are emitted in the right order.
        --
        -- See also Ticket 19910 for changing the return type from [] to OrdList.

        -- For debugging, uncomment the follow line and the mkComment lines.
        -- u <- getUniqueR
        let code :: [instr]
    code = [[instr]] -> [instr]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [ --  mkComment (text "<genRaInsn(" <> ppr u <> text ")>")
                            -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):squashed>")]
                            [instr]
    squashed_instr
                            -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):w_spills>")
                          , [instr] -> [instr]
    forall a. [a] -> [a]
    reverse [instr]
    w_spills
                            -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):r_spills>")
                          , [instr] -> [instr]
    forall a. [a] -> [a]
    reverse [instr]
    r_spills
                            -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):clobber_saves>")
                          , [instr] -> [instr]
    forall a. [a] -> [a]
    reverse [instr]
    clobber_saves
                            -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):new_instrs>")
                          , [instr]
    new_instrs
                            -- ,mkComment (text "</genRaInsn(" <> ppr u <> text ")>")
                          ]

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

        ([instr], [NatBasicBlock instr])
    -> RegM freeRegs ([instr], [NatBasicBlock instr])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr]
    code, [NatBasicBlock instr]
    fixup_blocks)

      }

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

    releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
    releaseRegs :: forall freeRegs. FR freeRegs => [Reg] -> RegM freeRegs ()
    releaseRegs [Reg]
    regs = do
      Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
      RegMap Loc
    assig <- RegM freeRegs (RegMap Loc)
    forall freeRegs. RegM freeRegs (RegMap Loc)
    getAssigR
      freeRegs
    free <- RegM freeRegs freeRegs
    forall freeRegs. RegM freeRegs freeRegs
    getFreeRegsR

      let loop :: RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop RegMap Loc
    assig !freeRegs
    free [] = do RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR RegMap Loc
    assig; freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR freeRegs
    free; () -> RegM freeRegs ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          loop RegMap Loc
    assig !freeRegs
    free (RegReal RealReg
    rr : [Reg]
    rs) = RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop RegMap Loc
    assig (Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frReleaseReg Platform
    platform RealReg
    rr freeRegs
    free) [Reg]
    rs
          loop RegMap Loc
    assig !freeRegs
    free (Reg
    r:[Reg]
    rs) =
             case RegMap Loc -> Reg -> Maybe Loc
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM RegMap Loc
    assig Reg
    r of
             Just (InBoth RealReg
    real Int
    _) -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop (RegMap Loc -> Reg -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> UniqFM key elt
    delFromUFM RegMap Loc
    assig Reg
    r)
                                          (Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frReleaseReg Platform
    platform RealReg
    real freeRegs
    free) [Reg]
    rs
             Just (InReg RealReg
    real)    -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop (RegMap Loc -> Reg -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> UniqFM key elt
    delFromUFM RegMap Loc
    assig Reg
    r)
                                          (Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frReleaseReg Platform
    platform RealReg
    real freeRegs
    free) [Reg]
    rs
             Maybe Loc
    _                    -> RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop (RegMap Loc -> Reg -> RegMap Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> UniqFM key elt
    delFromUFM RegMap Loc
    assig Reg
    r) freeRegs
    free [Reg]
    rs
      RegMap Loc -> freeRegs -> [Reg] -> RegM freeRegs ()
    loop RegMap Loc
    assig freeRegs
    free [Reg]
    regs

    -- -----------------------------------------------------------------------------
    -- Clobber real registers

    -- For each temp in a register that is going to be clobbered:
    --      - 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.
    --
    --      for allocateRegs on the temps *written*,
    --        - clobbered regs are not allocatable.
    --

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

    saveClobberedTemps :: forall instr freeRegs.
    (Instruction instr, FR freeRegs) =>
    [RealReg] -> [Reg] -> RegM freeRegs [instr]
    saveClobberedTemps [] [Reg]
    _
            = [instr] -> RegM freeRegs [instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    saveClobberedTemps [RealReg]
    clobbered [Reg]
    dying
     = do
            RegMap Loc
    assig   <- RegM freeRegs (RegMap Loc)
    forall freeRegs. RegM freeRegs (RegMap Loc)
    getAssigR :: RegM freeRegs (UniqFM Reg Loc)
            -- Unique represents the VirtualReg
            let to_spill :: [(Unique, RealReg)]
                to_spill :: [(Unique, RealReg)]
    to_spill
                    = [ (Unique
    temp,RealReg
    reg)
                            | (Unique
    temp, InReg RealReg
    reg) <- RegMap Loc -> [(Unique, Loc)]
    forall key elt. UniqFM key elt -> [(Unique, elt)]
    nonDetUFMToList RegMap Loc
    assig
                            -- This is non-deterministic but we do not
                            -- currently support deterministic code-generation.
                            -- See Note [Unique Determinism and code generation]
                            , (RealReg -> Bool) -> [RealReg] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (RealReg -> RealReg -> Bool
    realRegsAlias RealReg
    reg) [RealReg]
    clobbered
                            , Unique
    temp Unique -> [Unique] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` (Reg -> Unique) -> [Reg] -> [Unique]
    forall a b. (a -> b) -> [a] -> [b]
    map Reg -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique [Reg]
    dying  ]

            ([instr]
    instrs,RegMap Loc
    assig') <- RegMap Loc
    -> [instr]
    -> [(Unique, RealReg)]
    -> RegM freeRegs ([instr], RegMap Loc)
    clobber RegMap Loc
    assig [] [(Unique, RealReg)]
    to_spill
            RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR RegMap Loc
    assig'
            [instr] -> RegM freeRegs [instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr] -> RegM freeRegs [instr])
    -> [instr] -> RegM freeRegs [instr]
    forall a b. (a -> b) -> a -> b
    $ -- mkComment (text "<saveClobberedTemps>") ++
                     [instr]
    instrs
    --              ++ mkComment (text "</saveClobberedTemps>")
       where
         -- See Note [UniqFM and the register allocator]
         clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)
         clobber :: RegMap Loc
    -> [instr]
    -> [(Unique, RealReg)]
    -> RegM freeRegs ([instr], RegMap Loc)
    clobber RegMap Loc
    assig [instr]
    instrs []
                = ([instr], RegMap Loc) -> RegM freeRegs ([instr], RegMap Loc)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr]
    instrs, RegMap Loc
    assig)

         clobber RegMap Loc
    assig [instr]
    instrs ((Unique
    temp, RealReg
    reg) : [(Unique, RealReg)]
    rest)
           = do Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform

                freeRegs
    freeRegs <- RegM freeRegs freeRegs
    forall freeRegs. RegM freeRegs freeRegs
    getFreeRegsR
                let regclass :: RegClass
    regclass = Platform -> RealReg -> RegClass
    targetClassOfRealReg Platform
    platform RealReg
    reg
                    freeRegs_thisClass :: [RealReg]
    freeRegs_thisClass = Platform -> RegClass -> freeRegs -> [RealReg]
    forall freeRegs.
    FR freeRegs =>
    Platform -> RegClass -> freeRegs -> [RealReg]
    frGetFreeRegs Platform
    platform RegClass
    regclass freeRegs
    freeRegs

                case (RealReg -> Bool) -> [RealReg] -> [RealReg]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (RealReg -> [RealReg] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [RealReg]
    clobbered) [RealReg]
    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.
                  (RealReg
    my_reg : [RealReg]
    _) -> do
                      freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR (Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frAllocateReg Platform
    platform RealReg
    my_reg freeRegs
    freeRegs)

                      let new_assign :: RegMap Loc
    new_assign = RegMap Loc -> Unique -> Loc -> RegMap Loc
    forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
    addToUFM_Directly RegMap Loc
    assig Unique
    temp (RealReg -> Loc
    InReg RealReg
    my_reg)
                      let instr :: instr
    instr = Platform -> Reg -> Reg -> instr
    forall instr. Instruction instr => Platform -> Reg -> Reg -> instr
    mkRegRegMoveInstr Platform
    platform
                                      (RealReg -> Reg
    RegReal RealReg
    reg) (RealReg -> Reg
    RegReal RealReg
    my_reg)

                      RegMap Loc
    -> [instr]
    -> [(Unique, RealReg)]
    -> RegM freeRegs ([instr], RegMap Loc)
    clobber RegMap Loc
    new_assign (instr
    instr instr -> [instr] -> [instr]
    forall a. a -> [a] -> [a]
    : [instr]
    instrs) [(Unique, RealReg)]
    rest

                  -- (2) no free registers: spill the value
                  [] -> do
                      ([instr]
    spill, Int
    slot)   <- Reg -> Unique -> RegM freeRegs ([instr], Int)
    forall instr freeRegs.
    Instruction instr =>
    Reg -> Unique -> RegM freeRegs ([instr], Int)
    spillR (RealReg -> Reg
    RegReal RealReg
    reg) Unique
    temp

                      -- record why this reg was spilled for profiling
                      SpillReason -> RegM freeRegs ()
    forall freeRegs. SpillReason -> RegM freeRegs ()
    recordSpill (Unique -> SpillReason
    SpillClobber Unique
    temp)

                      let new_assign :: RegMap Loc
    new_assign  = RegMap Loc -> Unique -> Loc -> RegMap Loc
    forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
    addToUFM_Directly RegMap Loc
    assig Unique
    temp (RealReg -> Int -> Loc
    InBoth RealReg
    reg Int
    slot)

                      RegMap Loc
    -> [instr]
    -> [(Unique, RealReg)]
    -> RegM freeRegs ([instr], RegMap Loc)
    clobber RegMap Loc
    new_assign ([instr]
    spill [instr] -> [instr] -> [instr]
    forall a. [a] -> [a] -> [a]
    ++ [instr]
    instrs) [(Unique, RealReg)]
    rest

    -- | Mark all these real regs as allocated,
    --      and kick out their vreg assignments.
    --
    clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
    clobberRegs :: forall freeRegs. FR freeRegs => [RealReg] -> RegM freeRegs ()
    clobberRegs []
            = () -> RegM freeRegs ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    clobberRegs [RealReg]
    clobbered
     = do   Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
            freeRegs
    freeregs <- RegM freeRegs freeRegs
    forall freeRegs. RegM freeRegs freeRegs
    getFreeRegsR

            let gpRegs :: [RealReg]
    gpRegs  = Platform -> RegClass -> freeRegs -> [RealReg]
    forall freeRegs.
    FR freeRegs =>
    Platform -> RegClass -> freeRegs -> [RealReg]
    frGetFreeRegs Platform
    platform RegClass
    RcInteger freeRegs
    freeregs :: [RealReg]
                fltRegs :: [RealReg]
    fltRegs = Platform -> RegClass -> freeRegs -> [RealReg]
    forall freeRegs.
    FR freeRegs =>
    Platform -> RegClass -> freeRegs -> [RealReg]
    frGetFreeRegs Platform
    platform RegClass
    RcFloat   freeRegs
    freeregs :: [RealReg]
                dblRegs :: [RealReg]
    dblRegs = Platform -> RegClass -> freeRegs -> [RealReg]
    forall freeRegs.
    FR freeRegs =>
    Platform -> RegClass -> freeRegs -> [RealReg]
    frGetFreeRegs Platform
    platform RegClass
    RcDouble  freeRegs
    freeregs :: [RealReg]

            let extra_clobbered :: [RealReg]
    extra_clobbered = [ RealReg
    r | RealReg
    r <- [RealReg]
    clobbered
                                      , RealReg
    r RealReg -> [RealReg] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` ([RealReg]
    gpRegs [RealReg] -> [RealReg] -> [RealReg]
    forall a. [a] -> [a] -> [a]
    ++ [RealReg]
    fltRegs [RealReg] -> [RealReg] -> [RealReg]
    forall a. [a] -> [a] -> [a]
    ++ [RealReg]
    dblRegs) ]

            freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR (freeRegs -> RegM freeRegs ()) -> freeRegs -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $! (freeRegs -> RealReg -> freeRegs)
    -> freeRegs -> [RealReg] -> freeRegs
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' ((RealReg -> freeRegs -> freeRegs)
    -> freeRegs -> RealReg -> freeRegs
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((RealReg -> freeRegs -> freeRegs)
     -> freeRegs -> RealReg -> freeRegs)
    -> (RealReg -> freeRegs -> freeRegs)
    -> freeRegs
    -> RealReg
    -> freeRegs
    forall a b. (a -> b) -> a -> b
    $ Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frAllocateReg Platform
    platform) freeRegs
    freeregs [RealReg]
    extra_clobbered

            -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered

            RegMap Loc
    assig           <- RegM freeRegs (RegMap Loc)
    forall freeRegs. RegM freeRegs (RegMap Loc)
    getAssigR
            RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $! RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
    clobber RegMap Loc
    assig (RegMap Loc -> [(Unique, Loc)]
    forall key elt. UniqFM key elt -> [(Unique, elt)]
    nonDetUFMToList RegMap Loc
    assig)
              -- This is non-deterministic but we do not
              -- currently support deterministic code-generation.
              -- See Note [Unique Determinism and code generation]

       where
            -- 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 :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
            clobber :: RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
    clobber RegMap Loc
    assig []
                    = RegMap Loc
    assig

            clobber RegMap Loc
    assig ((Unique
    temp, InBoth RealReg
    reg Int
    slot) : [(Unique, Loc)]
    rest)
                    | (RealReg -> Bool) -> [RealReg] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (RealReg -> RealReg -> Bool
    realRegsAlias RealReg
    reg) [RealReg]
    clobbered
                    = RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
    clobber (RegMap Loc -> Unique -> Loc -> RegMap Loc
    forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
    addToUFM_Directly RegMap Loc
    assig Unique
    temp (Int -> Loc
    InMem Int
    slot)) [(Unique, Loc)]
    rest

            clobber RegMap Loc
    assig ((Unique, Loc)
    _:[(Unique, Loc)]
    rest)
                    = RegMap Loc -> [(Unique, Loc)] -> RegMap Loc
    clobber RegMap Loc
    assig [(Unique, Loc)]
    rest

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

    -- 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

    -- 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
            :: forall freeRegs instr. (FR freeRegs, Instruction instr)
            => Bool                 -- True <=> reading (load up spilled regs)
            -> [VirtualReg]         -- don't push these out
            -> [instr]              -- spill insns
            -> [RealReg]            -- real registers allocated (accum.)
            -> [VirtualReg]         -- temps to allocate
            -> RegM freeRegs ( [instr] , [RealReg])

    allocateRegsAndSpill :: forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    _       [VirtualReg]
    _    [instr]
    spills [RealReg]
    alloc []
            = ([instr], [RealReg]) -> RegM freeRegs ([instr], [RealReg])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([instr]
    spills, [RealReg] -> [RealReg]
    forall a. [a] -> [a]
    reverse [RealReg]
    alloc)

    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep [instr]
    spills [RealReg]
    alloc (VirtualReg
    r:[VirtualReg]
    rs)
     = do   UniqFM VirtualReg Loc
    assig <- RegMap Loc -> UniqFM VirtualReg Loc
    forall elt. UniqFM Reg elt -> UniqFM VirtualReg elt
    toVRegMap (RegMap Loc -> UniqFM VirtualReg Loc)
    -> RegM freeRegs (RegMap Loc)
    -> RegM freeRegs (UniqFM VirtualReg Loc)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> RegM freeRegs (RegMap Loc)
    forall freeRegs. RegM freeRegs (RegMap Loc)
    getAssigR
            -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
            -- See Note [UniqFM and the register allocator]
            let doSpill :: SpillLoc -> RegM freeRegs ([instr], [RealReg])
    doSpill = Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> VirtualReg
    -> [VirtualReg]
    -> UniqFM VirtualReg Loc
    -> SpillLoc
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> VirtualReg
    -> [VirtualReg]
    -> UniqFM VirtualReg Loc
    -> SpillLoc
    -> RegM freeRegs ([instr], [RealReg])
    allocRegsAndSpill_spill Bool
    reading [VirtualReg]
    keep [instr]
    spills [RealReg]
    alloc VirtualReg
    r [VirtualReg]
    rs UniqFM VirtualReg Loc
    assig
            case UniqFM VirtualReg Loc -> VirtualReg -> Maybe Loc
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM UniqFM VirtualReg Loc
    assig VirtualReg
    r of
                    -- case (1a): already in a register
                    Just (InReg RealReg
    my_reg) ->
                            Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep [instr]
    spills (RealReg
    my_regRealReg -> [RealReg] -> [RealReg]
    forall a. a -> [a] -> [a]
    :[RealReg]
    alloc) [VirtualReg]
    rs

                    -- 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 RealReg
    my_reg Int
    _)
                     -> do  Bool -> RegM freeRegs () -> RegM freeRegs ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not Bool
    reading) (RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $ UniqFM VirtualReg Loc -> RegMap Loc
    forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
    toRegMap (UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM UniqFM VirtualReg Loc
    assig VirtualReg
    r (RealReg -> Loc
    InReg RealReg
    my_reg)))
                            Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep [instr]
    spills (RealReg
    my_regRealReg -> [RealReg] -> [RealReg]
    forall a. a -> [a] -> [a]
    :[RealReg]
    alloc) [VirtualReg]
    rs

                    -- Not already in a register, so we need to find a free one...
                    Just (InMem Int
    slot) | Bool
    reading   -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
    doSpill (Int -> SpillLoc
    ReadMem Int
    slot)
                                      | Bool
    otherwise -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
    doSpill SpillLoc
    WriteMem
                    Maybe Loc
    Nothing | Bool
    reading   ->
                       String -> SDoc -> RegM freeRegs ([instr], [RealReg])
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "allocateRegsAndSpill: Cannot read from uninitialized register" (VirtualReg -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr VirtualReg
    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
                       -- sensible code into the NCG.  In GHC.Cmm.Pipeline we
                       -- call removeUnreachableBlocks at the end for this
                       -- reason.

                            | Bool
    otherwise -> SpillLoc -> RegM freeRegs ([instr], [RealReg])
    doSpill SpillLoc
    WriteNew

    -- | Given a virtual reg find a preferred real register.
    -- The preferred register is simply the first one the variable
    -- was assigned to (if any). This way when we allocate for a loop
    -- variables are likely to end up in the same registers at the
    -- end and start of the loop, avoiding redundant reg-reg moves.
    -- Note: I tried returning a list of past assignments, but that
    -- turned out to barely matter but added a few tenths of
    -- a percent to compile time.
    findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
    findPrefRealReg :: forall freeRegs. VirtualReg -> RegM freeRegs (Maybe RealReg)
    findPrefRealReg VirtualReg
    vreg = do
      BlockMap (freeRegs, RegMap Loc)
    bassig <- forall freeRegs. RegM freeRegs (BlockAssignment freeRegs)
    getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc))
      Maybe RealReg -> RegM freeRegs (Maybe RealReg)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe RealReg -> RegM freeRegs (Maybe RealReg))
    -> Maybe RealReg -> RegM freeRegs (Maybe RealReg)
    forall a b. (a -> b) -> a -> b
    $ ((freeRegs, RegMap Loc) -> Maybe RealReg -> Maybe RealReg)
    -> Maybe RealReg
    -> BlockMap (freeRegs, RegMap Loc)
    -> Maybe RealReg
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr ((freeRegs, RegMap Loc) -> Maybe RealReg -> Maybe RealReg
    forall freeRegs.
    (freeRegs, RegMap Loc) -> Maybe RealReg -> Maybe RealReg
    findVirtRegAssig) Maybe RealReg
    forall a. Maybe a
    Nothing BlockMap (freeRegs, RegMap Loc)
    bassig
      where
        findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg
        findVirtRegAssig :: forall freeRegs.
    (freeRegs, RegMap Loc) -> Maybe RealReg -> Maybe RealReg
    findVirtRegAssig (freeRegs, RegMap Loc)
    assig Maybe RealReg
    z =
            Maybe RealReg
    z Maybe RealReg -> Maybe RealReg -> Maybe RealReg
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|>   case UniqFM VirtualReg Loc -> VirtualReg -> Maybe Loc
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM (RegMap Loc -> UniqFM VirtualReg Loc
    forall elt. UniqFM Reg elt -> UniqFM VirtualReg elt
    toVRegMap (RegMap Loc -> UniqFM VirtualReg Loc)
    -> RegMap Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $ (freeRegs, RegMap Loc) -> RegMap Loc
    forall a b. (a, b) -> b
    snd (freeRegs, RegMap Loc)
    assig) VirtualReg
    vreg of
                            Just (InReg RealReg
    real_reg) -> RealReg -> Maybe RealReg
    forall a. a -> Maybe a
    Just RealReg
    real_reg
                            Just (InBoth RealReg
    real_reg Int
    _) -> RealReg -> Maybe RealReg
    forall a. a -> Maybe a
    Just RealReg
    real_reg
                            Maybe Loc
    _ -> Maybe RealReg
    z

    -- reading is redundant with reason, but we keep it around because it's
    -- convenient and it maintains the recursive structure of the allocator. -- EZY
    allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
                            => Bool
                            -> [VirtualReg]
                            -> [instr]
                            -> [RealReg]
                            -> VirtualReg
                            -> [VirtualReg]
                            -> UniqFM VirtualReg Loc
                            -> SpillLoc
                            -> RegM freeRegs ([instr], [RealReg])
    allocRegsAndSpill_spill :: forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> VirtualReg
    -> [VirtualReg]
    -> UniqFM VirtualReg Loc
    -> SpillLoc
    -> RegM freeRegs ([instr], [RealReg])
    allocRegsAndSpill_spill Bool
    reading [VirtualReg]
    keep [instr]
    spills [RealReg]
    alloc VirtualReg
    r [VirtualReg]
    rs UniqFM VirtualReg Loc
    assig SpillLoc
    spill_loc
     = do   Platform
    platform <- RegM freeRegs Platform
    forall a. RegM a Platform
    getPlatform
            freeRegs
    freeRegs <- RegM freeRegs freeRegs
    forall freeRegs. RegM freeRegs freeRegs
    getFreeRegsR
            let freeRegs_thisClass :: [RealReg]
    freeRegs_thisClass  = Platform -> RegClass -> freeRegs -> [RealReg]
    forall freeRegs.
    FR freeRegs =>
    Platform -> RegClass -> freeRegs -> [RealReg]
    frGetFreeRegs Platform
    platform (VirtualReg -> RegClass
    classOfVirtualReg VirtualReg
    r) freeRegs
    freeRegs :: [RealReg]

            -- Can we put the variable into a register it already was?
            Maybe RealReg
    pref_reg <- VirtualReg -> RegM freeRegs (Maybe RealReg)
    forall freeRegs. VirtualReg -> RegM freeRegs (Maybe RealReg)
    findPrefRealReg VirtualReg
    r

            case [RealReg]
    freeRegs_thisClass of
             -- case (2): we have a free register
             (RealReg
    first_free : [RealReg]
    _) ->
               do   let !final_reg :: RealReg
    final_reg
                            | Just RealReg
    reg <- Maybe RealReg
    pref_reg
                            , RealReg
    reg RealReg -> [RealReg] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [RealReg]
    freeRegs_thisClass
                            = RealReg
    reg
                            | Bool
    otherwise
                            = RealReg
    first_free
                    [instr]
    spills'   <- VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    forall instr freeRegs.
    Instruction instr =>
    VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    loadTemp VirtualReg
    r SpillLoc
    spill_loc RealReg
    final_reg [instr]
    spills

                    RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $ UniqFM VirtualReg Loc -> RegMap Loc
    forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
    toRegMap
                              (UniqFM VirtualReg Loc -> RegMap Loc)
    -> UniqFM VirtualReg Loc -> RegMap Loc
    forall a b. (a -> b) -> a -> b
    $ (UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM UniqFM VirtualReg Loc
    assig VirtualReg
    r (Loc -> UniqFM VirtualReg Loc) -> Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $! SpillLoc -> RealReg -> Loc
    newLocation SpillLoc
    spill_loc RealReg
    final_reg)
                    freeRegs -> RegM freeRegs ()
    forall freeRegs. freeRegs -> RegM freeRegs ()
    setFreeRegsR (freeRegs -> RegM freeRegs ()) -> freeRegs -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $  Platform -> RealReg -> freeRegs -> freeRegs
    forall freeRegs.
    FR freeRegs =>
    Platform -> RealReg -> freeRegs -> freeRegs
    frAllocateReg Platform
    platform RealReg
    final_reg freeRegs
    freeRegs

                    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep [instr]
    spills' (RealReg
    final_reg RealReg -> [RealReg] -> [RealReg]
    forall a. a -> [a] -> [a]
    : [RealReg]
    alloc) [VirtualReg]
    rs

              -- case (3): we need to push something out to free up a register
             [] ->
               do   let inRegOrBoth :: Loc -> Bool
    inRegOrBoth (InReg RealReg
    _) = Bool
    True
                        inRegOrBoth (InBoth RealReg
    _ Int
    _) = Bool
    True
                        inRegOrBoth Loc
    _ = Bool
    False
                    let candidates' :: UniqFM VirtualReg Loc
                        candidates' :: UniqFM VirtualReg Loc
    candidates' =
                          (UniqFM VirtualReg Loc -> [VirtualReg] -> UniqFM VirtualReg Loc)
    -> [VirtualReg] -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip UniqFM VirtualReg Loc -> [VirtualReg] -> UniqFM VirtualReg Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> [key] -> UniqFM key elt
    delListFromUFM [VirtualReg]
    keep (UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc)
    -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $
                          (Loc -> Bool) -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
    forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
    filterUFM Loc -> Bool
    inRegOrBoth (UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc)
    -> UniqFM VirtualReg Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $
                          UniqFM VirtualReg Loc
    assig
                          -- This is non-deterministic but we do not
                          -- currently support deterministic code-generation.
                          -- See Note [Unique Determinism and code generation]
                    let candidates :: [(Unique, Loc)]
    candidates = UniqFM VirtualReg Loc -> [(Unique, Loc)]
    forall key elt. UniqFM key elt -> [(Unique, elt)]
    nonDetUFMToList UniqFM VirtualReg Loc
    candidates'

                    -- the vregs we could kick out that are already in a slot
                    let candidates_inBoth :: [(Unique, RealReg, StackSlot)]
                        candidates_inBoth :: [(Unique, RealReg, Int)]
    candidates_inBoth
                            = [ (Unique
    temp, RealReg
    reg, Int
    mem)
                              | (Unique
    temp, InBoth RealReg
    reg Int
    mem) <- [(Unique, Loc)]
    candidates
                              , Platform -> RealReg -> RegClass
    targetClassOfRealReg Platform
    platform RealReg
    reg RegClass -> RegClass -> Bool
    forall a. Eq a => a -> a -> Bool
    == VirtualReg -> RegClass
    classOfVirtualReg VirtualReg
    r ]

                    -- 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 :: [(Unique, RealReg)]
    candidates_inReg
                            = [ (Unique
    temp, RealReg
    reg)
                              | (Unique
    temp, InReg RealReg
    reg) <- [(Unique, Loc)]
    candidates
                              , Platform -> RealReg -> RegClass
    targetClassOfRealReg Platform
    platform RealReg
    reg RegClass -> RegClass -> Bool
    forall a. Eq a => a -> a -> Bool
    == VirtualReg -> RegClass
    classOfVirtualReg VirtualReg
    r ]

                    let result :: RegM freeRegs ([instr], [RealReg])
    result

                            -- we have a temporary that is in both register and mem,
                            -- just free up its register for use.
                            | (Unique
    temp, RealReg
    my_reg, Int
    slot) : [(Unique, RealReg, Int)]
    _      <- [(Unique, RealReg, Int)]
    candidates_inBoth
                            = do    [instr]
    spills' <- VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    forall instr freeRegs.
    Instruction instr =>
    VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    loadTemp VirtualReg
    r SpillLoc
    spill_loc RealReg
    my_reg [instr]
    spills
                                    let assig1 :: UniqFM VirtualReg Loc
    assig1  = UniqFM VirtualReg Loc -> Unique -> Loc -> UniqFM VirtualReg Loc
    forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
    addToUFM_Directly UniqFM VirtualReg Loc
    assig Unique
    temp (Int -> Loc
    InMem Int
    slot)
                                    let assig2 :: UniqFM VirtualReg Loc
    assig2  = UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM UniqFM VirtualReg Loc
    assig1 VirtualReg
    r (Loc -> UniqFM VirtualReg Loc) -> Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $! SpillLoc -> RealReg -> Loc
    newLocation SpillLoc
    spill_loc RealReg
    my_reg

                                    RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $ UniqFM VirtualReg Loc -> RegMap Loc
    forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
    toRegMap UniqFM VirtualReg Loc
    assig2
                                    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep [instr]
    spills' (RealReg
    my_regRealReg -> [RealReg] -> [RealReg]
    forall a. a -> [a] -> [a]
    :[RealReg]
    alloc) [VirtualReg]
    rs

                            -- otherwise, we need to spill a temporary that currently
                            -- resides in a register.
                            | (Unique
    temp_to_push_out, (RealReg
    my_reg :: RealReg)) : [(Unique, RealReg)]
    _
                                            <- [(Unique, RealReg)]
    candidates_inReg
                            = do
                                    ([instr]
    spill_store, Int
    slot) <- Reg -> Unique -> RegM freeRegs ([instr], Int)
    forall instr freeRegs.
    Instruction instr =>
    Reg -> Unique -> RegM freeRegs ([instr], Int)
    spillR (RealReg -> Reg
    RegReal RealReg
    my_reg) Unique
    temp_to_push_out

                                    -- record that this temp was spilled
                                    SpillReason -> RegM freeRegs ()
    forall freeRegs. SpillReason -> RegM freeRegs ()
    recordSpill (Unique -> SpillReason
    SpillAlloc Unique
    temp_to_push_out)

                                    -- update the register assignment
                                    let assig1 :: UniqFM VirtualReg Loc
    assig1  = UniqFM VirtualReg Loc -> Unique -> Loc -> UniqFM VirtualReg Loc
    forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
    addToUFM_Directly UniqFM VirtualReg Loc
    assig Unique
    temp_to_push_out   (Int -> Loc
    InMem Int
    slot)
                                    let assig2 :: UniqFM VirtualReg Loc
    assig2  = UniqFM VirtualReg Loc -> VirtualReg -> Loc -> UniqFM VirtualReg Loc
    forall key elt.
    Uniquable key =>
    UniqFM key elt -> key -> elt -> UniqFM key elt
    addToUFM UniqFM VirtualReg Loc
    assig1 VirtualReg
    r                 (Loc -> UniqFM VirtualReg Loc) -> Loc -> UniqFM VirtualReg Loc
    forall a b. (a -> b) -> a -> b
    $! SpillLoc -> RealReg -> Loc
    newLocation SpillLoc
    spill_loc RealReg
    my_reg
                                    RegMap Loc -> RegM freeRegs ()
    forall freeRegs. RegMap Loc -> RegM freeRegs ()
    setAssigR (RegMap Loc -> RegM freeRegs ()) -> RegMap Loc -> RegM freeRegs ()
    forall a b. (a -> b) -> a -> b
    $ UniqFM VirtualReg Loc -> RegMap Loc
    forall elt. UniqFM VirtualReg elt -> UniqFM Reg elt
    toRegMap UniqFM VirtualReg Loc
    assig2

                                    -- if need be, load up a spilled temp into the reg we've just freed up.
                                    [instr]
    spills' <- VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    forall instr freeRegs.
    Instruction instr =>
    VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    loadTemp VirtualReg
    r SpillLoc
    spill_loc RealReg
    my_reg [instr]
    spills

                                    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    forall freeRegs instr.
    (FR freeRegs, Instruction instr) =>
    Bool
    -> [VirtualReg]
    -> [instr]
    -> [RealReg]
    -> [VirtualReg]
    -> RegM freeRegs ([instr], [RealReg])
    allocateRegsAndSpill Bool
    reading [VirtualReg]
    keep
                                            ([instr]
    spill_store [instr] -> [instr] -> [instr]
    forall a. [a] -> [a] -> [a]
    ++ [instr]
    spills')
                                            (RealReg
    my_regRealReg -> [RealReg] -> [RealReg]
    forall a. a -> [a] -> [a]
    :[RealReg]
    alloc) [VirtualReg]
    rs

                            -- there wasn't anything to spill, so we're screwed.
                            | Bool
    otherwise
                            = String -> SDoc -> RegM freeRegs ([instr], [RealReg])
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic (String
    "RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
                            (SDoc -> RegM freeRegs ([instr], [RealReg]))
    -> SDoc -> RegM freeRegs ([instr], [RealReg])
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
                                    [ String -> SDoc
    text String
    "allocating vreg:  " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (VirtualReg -> String
    forall a. Show a => a -> String
    show VirtualReg
    r)
                                    , String -> SDoc
    text String
    "assignment:       " SDoc -> SDoc -> SDoc
    <> UniqFM VirtualReg Loc -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr UniqFM VirtualReg Loc
    assig
                                    , String -> SDoc
    text String
    "freeRegs:         " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (freeRegs -> String
    forall a. Show a => a -> String
    show freeRegs
    freeRegs)
                                    , String -> SDoc
    text String
    "initFreeRegs:     " SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (freeRegs -> String
    forall a. Show a => a -> String
    show (Platform -> freeRegs
    forall freeRegs. FR freeRegs => Platform -> freeRegs
    frInitFreeRegs Platform
    platform freeRegs -> freeRegs -> freeRegs
    forall a. a -> a -> a
    `asTypeOf` freeRegs
    freeRegs)) ]

                    RegM freeRegs ([instr], [RealReg])
    result

    -- | 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 :: SpillLoc -> RealReg -> Loc
    newLocation (ReadMem Int
    slot) RealReg
    my_reg = RealReg -> Int -> Loc
    InBoth RealReg
    my_reg Int
    slot
    -- writes will always result in only the register being available
    newLocation SpillLoc
    _ RealReg
    my_reg = RealReg -> Loc
    InReg RealReg
    my_reg

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

    loadTemp :: forall instr freeRegs.
    Instruction instr =>
    VirtualReg
    -> SpillLoc -> RealReg -> [instr] -> RegM freeRegs [instr]
    loadTemp VirtualReg
    vreg (ReadMem Int
    slot) RealReg
    hreg [instr]
    spills
     = do
            [instr]
    insn <- Reg -> Int -> RegM freeRegs [instr]
    forall instr freeRegs.
    Instruction instr =>
    Reg -> Int -> RegM freeRegs [instr]
    loadR (RealReg -> Reg
    RegReal RealReg
    hreg) Int
    slot
            SpillReason -> RegM freeRegs ()
    forall freeRegs. SpillReason -> RegM freeRegs ()
    recordSpill (Unique -> SpillReason
    SpillLoad (Unique -> SpillReason) -> Unique -> SpillReason
    forall a b. (a -> b) -> a -> b
    $ VirtualReg -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique VirtualReg
    vreg)
            [instr] -> RegM freeRegs [instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return  ([instr] -> RegM freeRegs [instr])
    -> [instr] -> RegM freeRegs [instr]
    forall a b. (a -> b) -> a -> b
    $  {- mkComment (text "spill load") : -} [instr]
    insn [instr] -> [instr] -> [instr]
    forall a. [a] -> [a] -> [a]
    ++ [instr]
    spills

    loadTemp VirtualReg
    _ SpillLoc
    _ RealReg
    _ [instr]
    spills =
       [instr] -> RegM freeRegs [instr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [instr]
    spills